bkyk8rc3zvpnsf5inmcqq4n3k98cv6hj-my-site-hyper-literate-git.test.suzanne.soy-0.0.1

Unnamed repository; edit this file 'description' to name the repository.
Log | Files | Refs | README | LICENSE

manual-method.rkt (1876B)

      1 #lang scheme/base
      2 (require "../struct.rkt"
      3          "../search.rkt"
      4          "../scheme.rkt"
      5          "../basic.rkt"
      6          "manual-scheme.rkt"
      7          (for-syntax scheme/base))
      8 
      9 (provide ;; public:
     10          method xmethod)
     11 ; XXX unknown contracts
     12 (provide *method **method
     13          method-tag
     14          constructor-tag
     15          name-this-object)
     16 
     17 (define-syntax-rule (method class/interface method-name)
     18   (*method 'method-name (quote-syntax class/interface)))
     19 
     20 (define-syntax-rule (xmethod class/intf-id method-id)
     21   (elem (method class/intf-id method-id) " in " (racket class/intf-id)))
     22 
     23 (define (*method sym id
     24                  #:defn? [defn? #f])
     25   (**method sym id #:defn? defn?))
     26 
     27 (define (**method sym id/tag
     28                   #:defn? [defn? #f])
     29   (define content (list (symbol->string sym)))
     30   (define (mk tag)
     31     (make-element symbol-color
     32                   (list (make-link-element (if defn?
     33                                                value-def-color 
     34                                                value-link-color)
     35                                            content
     36                                            (method-tag tag sym)))))
     37   (if (identifier? id/tag)
     38       (make-delayed-element
     39        (λ (ren p ri)
     40          (let ([tag (find-scheme-tag p ri id/tag #f)])
     41            (if tag (list (mk tag)) content)))
     42        (λ () (car content))
     43        (λ () (car content)))
     44       (mk id/tag)))
     45 
     46 (define (method-tag vtag sym)
     47   (list 'meth (list (cadr vtag) sym)))
     48 
     49 (define (constructor-tag vtag)
     50   (list 'constructor (cadr vtag)))
     51 
     52 (define (name-this-object type-sym)
     53   (to-element
     54    (string->symbol
     55     (regexp-replace
     56      #rx"(%|<%>|-mixin)$"
     57      (format "_a~a-~s"
     58              (if (member (string-ref (symbol->string type-sym) 0)
     59                          '(#\a #\e #\i #\o #\u))
     60                "n"
     61                "")
     62              type-sym)
     63      ""))))