[plt-scheme] Macro techniques for implementing lexical scoped binding constructs

Is there a "canoncial" way of implementing lexical scoped
binding constructs "from scratch"?

Below I use the "names" module to keep track of which
names are bound in the current lexical context. It maintains
a standard ribcage, where the spine is cons-cells and the
individual ribs are module-identifier-mappings from identifiers to
values.

When a new scope is entered, a new mapping is consed onto the list,
and it is removed when the scope is left


As an example, a silly macro letn is implemented:

   (letn ((x 1))
         (letn ((y 2))
               (+ (ref x) (ref y))))
   ; => 3

   (letn ((x (begin (display 'hello!) 1)))
         (+ (ref x)
            (ref x)))
   ; displays: hello! hello!
   ; => 2


   (define-syntax (letn stx)
     (syntax-case stx ()
       [(_ ((name val) ...) body ...)
        (begin
          ; new scope is entered, add new mapping
          (register-new-level)
          ; bind the variables
          (for-each register
                    (syntax->list #'(name ...))
                    (syntax->list #'(val ...)))
          (begin0
            ; expand the body (now the variables are bound)
            (local-expand #'(begin body ...)
                          (syntax-local-context)
                          '() #f)
            ; to leave the scope, we remove outmost mapping
            (register-remove-level)))]))

What bothers me here is the use of local-expand.

Should it bother me?

Is there alternatives? (syntax-parameters perhaps - but how?)


/Jens Axel Søgaard



(module names mzscheme
   (provide display-registered-names
            lookup
            register
            unregister
            register-new-level
            register-remove-level)

   (require (lib "boundmap.ss" "syntax"))

   ; This is a list of module-identifier-mappings from identifiers
   ; to values.
   ; The last mapping corresponds to the top-level.
   (define registered-names
     (make-parameter (list (make-module-identifier-mapping))))

   (define (display-registered-names)
     (display (cons 'registered-names:
                    (map (lambda (mapping)
                           (module-identifier-mapping-map
                            mapping
                            (lambda (name type) (list name type))))
                         (registered-names))))
     (newline))

   (define (lookup name)
     (define (lookup-in name mappings)
       (if (null? mappings)
           #f
           (module-identifier-mapping-get
            (car mappings) name
            (lambda() (lookup-in name (cdr mappings))))))
     (lookup-in name (registered-names)))

   (define (register name type)
     (module-identifier-mapping-put! (car (registered-names))
                                     name type))

   (define (unregister name)
     (register name #f))

   (define (register-new-level)
     (registered-names (cons (make-module-identifier-mapping)
                             (registered-names))))

   (define (register-remove-level)
     (registered-names (cdr (registered-names))))
   )

(module letn mzscheme
   (provide letn ref)

   (require-for-syntax names)

   (define-syntax (letn stx)
     (syntax-case stx ()
       [(_ ((name val) ...) body ...)
        (begin
          (register-new-level)
          (for-each register
                    (syntax->list #'(name ...))
                    (syntax->list #'(val ...)))
          (begin0
            (local-expand #'(begin body ...)
                          (syntax-local-context)
                          '() #f)
            (register-remove-level)))]))

   (define-syntax (ref stx)
     (syntax-case stx ()
       [(_ name)
        (identifier? #'name)
        (begin
          ;(display-registered-names)
          (with-syntax ([val (lookup #'name)])
            #'val))])))


;;
;; TESTING
;;

(require letn)

(letn ((foo 42))
       (+ 1 (ref foo)))
; => 43

(letn ((x 1))
       (letn ((y 2))
             (+ (ref x) (ref y))))
; => 3

(letn ((x 1) (y 2))
       (letn ((x 7))
             (+ (ref x) (ref y))))
; => 9

(letn ((x (+ 1 2)) (y 2))
       (letn ((x 7))
             (display (+ (ref x) (ref y))))
       (ref x))
; displays: 9
; => 3

(letn ((x (begin (display 'hello!) 1)))
       (+ (ref x)
          (ref x)))
; displays: hello! hello!
; => 2

(letn ((x 4))
       (let ((x 7))  ; shadows
         (ref x)))
; => #f
; (because the x is "unbound")
; (an alternative choice is to signal an error)