path: root/csc/macros.csc

(define-library (csc macros)
  (export
    builtins-environment
    expand
    expand-body
    macro-syntax-error?
    make-environment)
  (import (scheme base)
          (only (csc assert) assert)
          (only (csc format) sprintf)
          (only (csc gensym)
            gensym
            gensym=?)
          (only (csc hash-map)
            alist->map
            hash-bytevector
            insert
            key-not-found-error?
            lookup
            map-for-each
            merge)
          (only (csc ir1)
            define-syntax-name
            define-syntax-transformer
            define-syntax?
            lexical-ref-gensym
            lexical-ref?
            library-define-expression
            library-define-ref
            library-define?
            library-ref-name
            library-ref?
            make-call
            make-constant
            make-lambda
            make-letrec
            make-lexical-ref
            make-library-define
            make-library-ref
            make-sequence
            sequence-head
            sequence-tail
            sequence?)
          (only (csc list)
            revappend
            unzip)
          (only (csc loop)
            loop
            return)
          (only (csc match) match)
          (only (csc strings) join)
          (only (csc vec)
            vec
            vec-append
            vec-length
            vec-ref))
  (begin


    (define-record-type <macro-transformer>
      (make-macro-transformer transformer)
      macro-transformer?
      (transformer transformer-function))


    (define-record-type <macro-syntax-error>
      (make-macro-syntax-error message irritants)
      macro-syntax-error?
      (message syntax-error-object-message)
      (irritants syntax-error-object-irritants))


    (define (raise-syntax-error message . irritants)
      (raise (make-macro-syntax-error message irritants)))


    ; symbols is a map with identifiers as keys, and the values can be one of:
    ; - <lexical-ref>,
    ; - <library-ref>,
    ; - or <macro-transformer>.
    ; The first two correspond to variables bound lexically or from a library,
    ; and the third represents a macro transformer bound in the
    ; current context.
    (define-record-type <environment>
      (make-environment symbols library)
      environment?
      (symbols environment-substitutions)
      (library environment-library))


    (define-record-type <syntax-object>
      (make-syntax-object expression environment marks)
      syntax-object?
      (expression syntax-object-expression)
      (environment syntax-object-environment)
      (marks syntax-object-marks))


    (define (wrap-syntax expression environment)
      (if (syntax-object? expression)
        expression
        (make-syntax-object expression environment '())))


    (define (syntax->expression s)
      (if (syntax-object? s)
        (syntax-object-expression s)
        s))


    (define (marks s)
      (if (syntax-object? s)
        (syntax-object-marks s)
        '()))


    (define (add-binding identifier binding environment)
      (make-environment
        (insert (environment-substitutions environment) identifier binding)
        (environment-library environment)))


    (define (with-binding identifier binding syntax)
      (make-syntax-object
        (syntax->expression syntax)
        (add-binding identifier binding (syntax-object-environment syntax))
        (marks syntax)))


    (define (identifier? s)
      (or (symbol? s)
          (and (syntax-object? s)
               (symbol? (syntax-object-expression s)))))


    (define (marks=? m1 m2)
      (and
        (= (length m1) (length m2))
        (let loop ((m1 m1)
                   (m2 m2))
          (if (null? m1)
            #t
            (and (= (car m1) (car m2)) (loop (cdr m1) (cdr m2)))))))


    (define (identifier-name s)
      (if (syntax-object? s)
        (syntax-object-expression s)
        s))


    (define (bound-identifier=? s1 s2)
      (and (symbol=? (identifier-name s1) (identifier-name s2))
           (marks=? (marks s1) (marks s2))))


    (define (binding=? b1 b2)
      (or (and (lexical-ref? b1)
               (lexical-ref? b2)
               (gensym=? (lexical-ref-gensym b1) (lexical-ref-gensym b2)))
          (and (library-ref? b1)
               (library-ref? b2)
               (symbol=? (library-ref-name b1) (library-ref-name b2)))
          (and (macro-transformer? b1)
               (macro-transformer? b2)
               (eq? (transformer-function b1) (transformer-function b2)))))


    ; free-identifier=? only works on wrapped syntax objects.
    (define (free-identifier=? s1 s2)
      (let ((s1-binding (guard (e ((key-not-found-error? e) #f))
                          (lookup (environment-substitutions (syntax-object-environment s1)) s1)))
            (s2-binding (guard (e ((key-not-found-error? e) #f))
                          (lookup (environment-substitutions (syntax-object-environment s2)) s2))))
        (or (and (not s1-binding)
                 (not s2-binding)
                 (symbol=? (identifier-name s1) (identifier-name s2)))
            (binding=? s1-binding s2-binding))))


    (define *next-mark* 0)


    (define (new-mark)
      (let ((m *next-mark*))
        (set! *next-mark* (+ 1 *next-mark*))
        m))


    (define (add-mark mark expression)
      (make-syntax-object
        (syntax-object-expression expression)
        (syntax-object-environment expression)
        (if (and (pair? (syntax-object-marks expression))
                 (not (car (syntax-object-marks expression))))  ; Anti-mark.
          (cdr (syntax-object-marks expression))
          (cons mark (syntax-object-marks expression)))))


    (define (add-marks marks expression)
      (let loop ((marks marks)
                 (expression expression))
        (match marks
          ('() expression)
          ((mark . marks)
           (loop marks (add-mark mark expression))))))


    (define (anti-mark expression)
      (add-mark #f expression))


    (define (decorate marks expression environment)
      (add-marks marks (wrap-syntax expression environment)))


    (define (with-wrap expression parent)
      (decorate (marks parent) expression (syntax-object-environment parent)))


    (define (syntax-map f expr)
      (with-wrap (f (syntax->expression expr)) expr))


    (define-record-type <syntax-case-no-match>
      (make-syntax-case-no-match)
      syntax-case-no-match?)


    (define-syntax syntax-case-match-pattern
      (syntax-rules (_ when)
        ((syntax-case-match-pattern x pattern when condition result result* ...)
          (syntax-case-match-pattern x pattern
            (if condition
              (let () result result* ...)
              (raise (make-syntax-case-no-match)))))
        ((syntax-case-match-pattern x _ result result* ...)
          (let () result result* ...))
        ((syntax-case-match-pattern x '() result result* ...)
          (if (null? (syntax->expression x))
            (let () result result* ...)
            (raise (make-syntax-case-no-match))))
        ((syntax-case-match-pattern x (pattern) result result* ...)
          (let ((y x))
            (if (pair? (syntax->expression y))
              (syntax-case-match-pattern (syntax-map car y) pattern
                (syntax-case-match-pattern (syntax-map cdr y) '() result result* ...))
              (raise (make-syntax-case-no-match)))))
        ((syntax-case-match-pattern x (pattern . rest) result result* ...)
          (let ((y x))
            (if (pair? (syntax->expression y))
              (syntax-case-match-pattern (syntax-map car y) pattern
                (syntax-case-match-pattern (syntax-map cdr y) rest result result* ...))
              (raise (make-syntax-case-no-match)))))
        ((syntax-case-match-pattern x ident result result* ...)
          (let ((ident x)) result result* ...))))


    ; Yes, I just defined syntax-case in terms of syntax-rules.
    ; Are we sure this won't create a black hole?
    (define-syntax syntax-case
      (syntax-rules ()
        ((syntax-case x (arm ...))
          (guard (e ((syntax-case-no-match? e) (error "no match in syntax case")))
            (syntax-case-match-pattern x arm ...)))
        ((syntax-case x (arm ...) clause clause* ...)
          (let ((y x))
            (guard (e ((syntax-case-no-match? e)
                        (syntax-case y clause clause* ...)))
              (syntax-case-match-pattern y arm ...))))))


    (define (expand-procedure-call procedure arguments)
      (let ((expanded-procedure (expand-syntax-object procedure))
            (expanded-arguments
              (let loop ((arguments arguments)
                         (expanded-arguments '()))
                (syntax-case arguments
                  ('() (reverse expanded-arguments))
                  ((argument . rest)
                    (let ((expanded-argument (expand-syntax-object argument)))
                      (loop
                        rest
                        (cons expanded-argument expanded-arguments))))
                  (_ (raise-syntax-error "arguments to a procedure call must be a list" procedure arguments))))))
        (make-call expanded-procedure expanded-arguments)))


    (define (resolve-identifier ident)
      (let* ((environment (syntax-object-environment ident))
             (substitutions (environment-substitutions environment)))
        (or
          ; Check whether the variable is lexically bound to a marked identifier.
          (guard (e ((key-not-found-error? e) #f))
            (lookup substitutions ident))
          ; Check whether the variable is bound to an unmarked identifier.
          (guard (e ((key-not-found-error? e) #f))
            (lookup substitutions (identifier-name ident)))
          ; Otherwise insert a library-ref
          (make-library-ref (identifier-name ident) (environment-library environment)))))


    (define (expand-syntax-object syntax)
      (syntax-case syntax
        ('() (raise-syntax-error "nil by itself is an error (did you mean to use quote?)" syntax))
        ((macro-name . tail) when (identifier? macro-name)
          (let ((macro-body (resolve-identifier macro-name)))
            (if (macro-transformer? macro-body)
              ((transformer-function macro-body) syntax)
              (expand-procedure-call macro-name tail))))
        ((procedure . arguments)
          (expand-procedure-call procedure arguments))
        (_ when (identifier? syntax)
          (let ((binding (resolve-identifier syntax)))
            (if (macro-transformer? binding)
              (raise-syntax-error "macro is not allowed in this context" syntax)
              binding)))
        (_ when (let ((expr (syntax->expression syntax)))
                  (or (boolean? expr)
                      (char? expr)
                      (number? expr)
                      (string? expr)
                      (vector? expr)))
          (make-constant (syntax->expression syntax)))
        (_ (raise-syntax-error "unexpected expression type" (clean-syntax syntax)))))


    ; expand can be thought of as a compiler from Scheme to IR1. Macros
    ; included in the environment can be used to extend the syntax. Returns an
    ; IR1 expression.
    (define (expand expression environment)
      (expand-syntax-object (wrap-syntax expression environment)))


    (define (clean-syntax s)
      (cond
        ((pair? s) (cons (clean-syntax (car s)) (clean-syntax (cdr s))))
        ((syntax-object? s) (clean-syntax (syntax->expression s)))
        (else s)))


    (define builtin-quote
      (make-macro-transformer
        (lambda (syntax)
          (syntax-case syntax
            ((_ datum) (make-constant (clean-syntax datum)))
            (_ (raise-syntax-error "invalid form for quote" (clean-syntax syntax)))))))


    (define (matches-literals literals object)
      (unless (list? (syntax->expression literals))
        (raise-syntax-error "invalid form in literals, expecting list" literals))
      (if (not (identifier? object))
        #f
        (let ((literal-identifiers
                (map
                  (lambda (lit) (with-wrap lit literals))
                  (syntax->expression literals))))
          (let loop ((literal-identifiers literal-identifiers))
            (match literal-identifiers
              ('() #f)
              ((lit . literals)
                (or (free-identifier=? lit object)
                    (loop literals))))))))


    (define (identifier-uuid i)
      ; Join marks by ( because symbols aren't allowed to have ( in the name.
      (sprintf "{}({}" (apply join "(" (map number->string (marks i))) (identifier-name i)))


    (define (hash-identifier i)
      (hash-bytevector (string->utf8 (identifier-uuid i))))


    (define (identifier<? i1 i2)
      (string<? (identifier-uuid i1) (identifier-uuid i2)))


    (define (alist->substitutions l)
      (alist->map hash-identifier identifier<? l))


    (define (is-underscore expression)
      (and
        (identifier? expression)
        (free-identifier=?
          expression
          (wrap-syntax
            '_
            (make-environment
              (alist->substitutions
                (list (cons '_ (make-library-ref '_ '(scheme base)))))
              '(scheme base))))))


    (define (syntax-improper-list-length l)
      (let loop ((l l)
                 (n 0))
        (syntax-case l
          ('() n)
          ((_ . rest) (loop rest (+ 1 n)))
          (_ (+ 1 n)))))


    ; objects is an n-dimensional vec, where n is nesting-level.
    (define-record-type <ellipsis-binding>
      (make-ellipsis-binding objects nesting-level)
      ellipsis-binding?
      (objects ellipsis-binding-objects)
      (nesting-level ellipsis-binding-nesting-level))


    (define (merge-bindings x y)
      (assert (= (ellipsis-binding-nesting-level x) (ellipsis-binding-nesting-level y)))
      (make-ellipsis-binding
        (vec-append (ellipsis-binding-objects x) (ellipsis-binding-objects y))
        (ellipsis-binding-nesting-level x)))


    (define (ellipsis-substitutions-merge s1 s2)
      (map-for-each
        (lambda (k v)
          (let-values (((s1-binding ok)
                         (guard (e ((key-not-found-error? e) (values #f #f)))
                           (values (lookup s1 k) #t))))
            (if ok
              (set! s1 (insert s1 k (merge-bindings s1-binding v)))
              (set! s1 (insert s1 k v)))))
        s2)
      s1)


    (define (map-ellipsis-binding substitutions)
      (let ((res (alist->substitutions '())))
        (map-for-each
          (lambda (k v)
            (if (ellipsis-binding? v)
              (set! res
                (insert
                  res
                  k
                  (make-ellipsis-binding
                    (vec (ellipsis-binding-objects v))
                    (+ 1 (ellipsis-binding-nesting-level v)))))
              (set! res
                (insert
                  res
                  k
                  (make-ellipsis-binding
                    (vec v)
                    1)))))
          substitutions)
        res))


    (define (pattern-bindings ellipsis literals pattern object)
      (syntax-case pattern
        (lit when (matches-literals literals lit)
          (if (and (identifier? object) (free-identifier=? object lit))
            (alist->substitutions '())
            #f))
        ((p ellip . p*) when (and (identifier? ellip) (not (matches-literals literals ellip)) (free-identifier=? ellipsis ellip))
          (let* ((n (syntax-improper-list-length object))
                 (m (syntax-improper-list-length p*))
                 (n-m (- n m)))
            (if (>= n m)
              (let loop ((i 0)
                         (object object)
                         (bindings (alist->substitutions '())))
                (if (< i n-m)
                  (let ((binding (pattern-bindings ellipsis literals p (syntax-map car object))))
                    (and binding
                         (loop
                           (+ 1 i)
                           (syntax-map cdr object)
                           (ellipsis-substitutions-merge bindings (map-ellipsis-binding binding)))))
                  (let ((bindings* (pattern-bindings ellipsis literals p* object)))
                    (and bindings* (merge bindings bindings*)))))
              #f)))
        (underscore when (is-underscore underscore)
          (alist->substitutions '()))
        (ident when (identifier? ident)
          ; Each time the expander encounters a macro use, it applies an
          ; antimark to the input form.
          ;
          ; We would apply it earlier, but the antimark breaks
          ; free-identifier=? to check for literals. -- rose
          (alist->substitutions (list (cons ident (anti-mark object)))))
        ('()
          (syntax-case object
            ('() (alist->substitutions '()))
            (_ #f)))
        ((p . p*)
          (syntax-case object
            ((e . e*)
              (define pbindings (pattern-bindings ellipsis literals p e))
              (define p*bindings (pattern-bindings ellipsis literals p* e*))
              (and pbindings p*bindings (merge pbindings p*bindings)))
            (_ #f)))
        (constant
          (if (equal? (syntax->expression constant) (syntax->expression object))
            (alist->substitutions '())
            #f))))


    (define-record-type <ellipsis-out-of-bounds>
      (make-ellipsis-out-of-bounds)
      ellipsis-out-of-bounds?)


    (define (ellipsis-ref v i)
      (if (< i (vec-length v))
        (vec-ref v i)
        (raise (make-ellipsis-out-of-bounds))))


    ; Can raise key-not-found-error? or ellipsis-out-of-bounds?.
    (define (ellipsis-lookup substitutions ellipsis-nesting key)
      (let ((n-d-vector (lookup substitutions key)))
        (if (ellipsis-binding? n-d-vector)
          (if (= (ellipsis-binding-nesting-level n-d-vector) (vec-length ellipsis-nesting))
            (let loop ((i 0)
                       (value (ellipsis-binding-objects n-d-vector)))
              (if (< i (vec-length ellipsis-nesting))
                (loop
                  (+ 1 i)
                  (ellipsis-ref value (vec-ref ellipsis-nesting i)))
                value))
            (raise-syntax-error "reference to pattern variable at incorrect ellipsis nesting level" (clean-syntax key) (vec-length ellipsis-nesting)))
          n-d-vector)))


    (define (syntax-append s1 s2)
      (syntax-case s1
        ('() (with-wrap s2 s1))
        ((head . tail)
          (with-wrap
            (cons head
                  (syntax-append tail s2))
            s1))))


    (define (expand-template ellipsis ellipsis-nesting substitutions template)
      (syntax-case template
        ('() (with-wrap '() template))
        ((head ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis))
          (let-values (((extra-ellipses tail)
                         (let loop ((tail tail)
                                    (extra-ellipses '()))
                           (syntax-case tail
                             ((ellip . tail) when (and (identifier? ellip) (free-identifier=? ellip ellipsis))
                               (loop tail (cons ellip extra-ellipses)))
                             (_ (values extra-ellipses tail))))))
            (let loop ((i 0)
                       (expansion (with-wrap '() template)))
              (guard (e ((ellipsis-out-of-bounds? e)
                          (if (= 0 i)
                            ; Failure was at a higher level.
                            (raise e)
                            (syntax-append expansion (expand-template ellipsis ellipsis-nesting substitutions tail)))))
                (loop
                  (+ 1 i)
                  (syntax-append
                    expansion
                    (expand-template
                      ellipsis
                      (vec-append ellipsis-nesting i)
                      substitutions
                      (with-wrap
                        (cons
                          head
                          extra-ellipses)
                        template))))))))
        ((head . tail)
          (with-wrap
            (cons (expand-template ellipsis ellipsis-nesting substitutions head)
                  (expand-template ellipsis ellipsis-nesting substitutions tail))
            template))
        (ident when (identifier? ident)
          (guard (e ((key-not-found-error? e) template))
            (ellipsis-lookup substitutions ellipsis-nesting template)))
        (_ template)))


    (define (syntax-match ellipsis literals all-rules object)
      (let loop ((rules all-rules))
        (syntax-case rules
          ('() (raise-syntax-error "form did not match any patterns in syntax-rules" object all-rules))
          ((((_ . pattern) template) . tail)
            (define bindings (pattern-bindings ellipsis literals pattern (syntax-map cdr object)))
            (if bindings
              ; We call expand-syntax-object immediately, since macros are
              ; allowed to be recursive.
              (expand-syntax-object
                ; Each time the expander encounters a macro use, it applies an
                ; antimark to the input form, invokes the associated
                ; transformer, then applies a fresh mark to the output.
                (add-mark (new-mark) (expand-template ellipsis (vec) bindings template)))
              (loop tail)))
          (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules)))))


    (define default-ellipsis
      (wrap-syntax
        '...
        (make-environment
          (alist->substitutions
            (list (cons '...
                        (make-library-ref '... '(scheme base)))))
          '(scheme base))))


    (define builtin-syntax-rules
      (make-macro-transformer
        (lambda (syntax-rules-form)
          (make-macro-transformer
            (lambda (input-form)
              (syntax-case syntax-rules-form
                ((_ ellipsis literals . rules) when (identifier? ellipsis)
                  (syntax-match ellipsis literals rules input-form))
                ((_ literals . rules)
                  (syntax-match default-ellipsis literals rules input-form))
                (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form))))))))


    (define builtin-let-syntax
      (make-macro-transformer
        (lambda (x)
          (syntax-case x
            ((_ (ident transformer-form) body-form) when (identifier? ident)
              (let* ((transformer (expand-syntax-object transformer-form))
                    (body (expand-syntax-object (with-binding ident transformer body-form))))
                body))
            (_ (raise-syntax-error "unexpected form in let-syntax"))))))


    (define (split-args-rest formals)
      (syntax-case formals
        ('()
          (values '() #f))
        ((var . vars) when (identifier? var)
          (let-values (((args rest) (split-args-rest vars)))
            (values (cons (identifier-name var) args) rest)))
        (var when (identifier? var)
          (values '() (identifier-name var)))
        (_ (raise-syntax-error "unexpected form in split-args-rest" formals))))


    (define (expand-lambda-body-rest body)
      (let loop ((body body)
                 (expanded-body (make-constant #f)))
        (syntax-case body
          ('()
            expanded-body)
          ((expr . expr*)
            (define expanded-expr (expand-syntax-object expr))
            (when (or (library-define? expanded-expr)
                      (define-syntax? expanded-expr))
              (raise-syntax-error "define not allowed here" body))
            (loop (syntax-map cdr body)
                  (make-sequence expanded-body expanded-expr))))))


    (define (expand-lambda-body body)
      (let loop ((body body)
                 (names '())
                 (gensyms '())
                 (expressions '()))
        (syntax-case body
          ('()
            (if (null? names)
              (make-constant #f)
              (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (make-constant #f))))
          ((expr . expr*)
            (define expanded-expr (expand-syntax-object expr))
            (cond
              ((library-define? expanded-expr)
                (let ((name (library-ref-name (library-define-ref expanded-expr)))
                      (g (gensym)))
                  (loop (with-binding name (make-lexical-ref name g) (syntax-map cdr body))
                        (cons name names)
                        (cons g gensyms)
                        (cons (library-define-expression expanded-expr) expressions))))
              ((define-syntax? expanded-expr)
                (loop (with-binding (define-syntax-name expanded-expr) (define-syntax-transformer expanded-expr) (syntax-map cdr body))
                      names
                      gensyms
                      expressions))
              (else
                (if (null? names)
                  (expand-lambda-body-rest body)
                  (make-letrec #t (reverse names) (reverse gensyms) (reverse expressions) (expand-lambda-body-rest body)))))))))


    (define builtin-lambda
      (make-macro-transformer
        (lambda (x)
          (syntax-case x
            ((_ formals . body)
              (let-values (((args rest) (split-args-rest formals)))
                (make-lambda
                  (map (lambda (name)
                         (make-lexical-ref name (gensym)))
                       args)
                  (if rest
                    (make-lexical-ref rest (gensym))
                    #f)
                  (expand-lambda-body body))))
            (_ (raise-syntax-error "unexpected form in lambda" x))))))


    (define builtin-define
      (make-macro-transformer
        (lambda (x)
          (syntax-case x
            ((_ symbol expression)
              (make-library-define
                (make-library-ref
                  (identifier-name symbol)
                  (environment-library (syntax-object-environment x)))
                (expand-syntax-object expression)))
            (_ (raise-syntax-error "unexpected form in builtin-define" x))))))


    (define builtins-environment
      (make-environment
        (alist->substitutions
          (list (cons 'syntax-rules builtin-syntax-rules)
                (cons '_ (make-library-ref '_ '(scheme base)))
                (cons '... (make-library-ref '... '(scheme base)))
                (cons 'builtin-let-syntax builtin-let-syntax)
                (cons 'quote builtin-quote)
                (cons 'lambda builtin-lambda)
                (cons 'builtin-define builtin-define)))
        'main))


    ; Expands the body of a library, or top level.
    (define (expand-body body)
      (loop with environment = (syntax-object-environment body)
            for expr in (syntax->expression body)
            for expanded-expr = (expand expr environment)
            for res = expanded-expr then (make-sequence res expanded-expr)
            finally (return res)
            if (define-syntax? expanded-expr)
              do (set! environment
                   (add-binding
                     (define-syntax-name expanded-expr)
                     (define-syntax-transformer expanded-expr)
                     environment))))))