path: root/csc/macros.csc

(define-library (csc macros)
  (export
    expand
    test-environment)
  (import (scheme base)
          (only (csc format) sprintf)
          (only (csc gensym)
            gensym
            gensym=?)
          (only (csc hash-map)
            alist->map
            hash-bytevector
            insert
            key-not-found-error?
            lookup
            merge)
          (only (csc ir1)
            lexical-ref-gensym
            lexical-ref?
            library-ref-library
            library-ref-name
            library-ref?
            make-call
            make-constant
            make-lambda
            make-lambda-case
            make-library-ref)
          (only (csc list) revappend)
          (only (csc match) match)
          (only (csc strings) join))
  (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 module,
    ; and the third represents a macro transformer bound in the
    ; current context.
    ;
    ; library is the current library name being compiled. A nil library
    ; corresponds to top level expressions.
    (define-record-type <environment>
      (make-environment symbols library)
      environment?
      (symbols environment-substitutions)
      (library environment-library))


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


    (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 (identifier? s)
      (or (symbol? s)
          (and (syntax-object? s)
               (symbol? (syntax-object-expression s)))))


    (define (marks s)
      (if (syntax-object? s)
        (syntax-object-marks 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)
               (equal? (library-ref-library b1) (library-ref-library 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))
            (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
              (begin result result* ...)
              (raise (make-syntax-case-no-match)))))
        ((syntax-case-match-pattern x _ result result* ...)
          (begin result result* ...))
        ((syntax-case-match-pattern x '() result result* ...)
          (if (null? (syntax->expression x))
            (begin result result* ...)
            (raise (make-syntax-case-no-match))))
        ((syntax-case-match-pattern x (pattern) result result* ...)
          (if (= 1 (length (syntax->expression x)))
            (syntax-case-match-pattern (syntax-map car x) pattern 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* ...)))))
        ((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) (if #f #f)))
            (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-values (((expanded-procedure environment) (expand-syntax-object procedure))
                   ((expanded-arguments)
                     (let loop ((arguments arguments)
                                (expanded-arguments '()))
                       (syntax-case arguments
                         ('() (reverse expanded-arguments))
                         ((argument . rest)
                           (let-values (((expanded-argument environment) (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)))


    ; From R6RS:
    ; 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.
    ;
    ; In cute scheme, macros compile themselves, and syntax-rules is therefore
    ; responsible for applying a mark to an expanded expression before
    ; expanding it with expand-syntax-object.
    (define (expand-macro-use transformer syntax)
      ((transformer-function transformer) (anti-mark syntax)))


    (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
                  (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" macro-name)))
                    (lookup (environment-substitutions (syntax-object-environment macro-name)) macro-name))))
            (if (macro-transformer? macro-body)
              (expand-macro-use macro-body syntax)
              (values (expand-procedure-call macro-name tail) (syntax-object-environment syntax)))))
        ((procedure . arguments)
          (values (expand-procedure-call procedure arguments) (syntax-object-environment syntax)))
        (_ (when (identifier? syntax))
          (let ((binding
                  (guard (e ((key-not-found-error? e) (raise-syntax-error "undefined symbol" syntax)))
                    (lookup (environment-substitutions (syntax-object-environment syntax)) syntax))))
            (if (macro-transformer? binding)
              (raise-syntax-error "macro is not allowed in this context" syntax)
              (values binding (syntax-object-environment syntax)))))
        (_ (when (let ((expr (syntax->expression syntax)))
                   (or (boolean? expr)
                       (char? expr)
                       (number? expr)
                       (string? expr)
                       (vector? expr))))
          (values (make-constant (syntax->expression syntax)) (syntax-object-environment syntax)))
        (_ (raise-syntax-error "unexpected expression type" 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 and an environment which has been modified with any new
    ; bindings introduced by the expression.
    (define (expand expression environment)
      (expand-syntax-object (wrap-syntax expression environment)))


    (define builtin-quote
      (make-macro-transformer
        (lambda (syntax)
          (syntax-case syntax
            ((_ datum) (values (make-constant (syntax->expression datum)) (syntax-object-environment syntax)))
            (_ (raise-syntax-error "invalid form for quote" syntax))))))


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


    (define (matches-literals literals object)
      (unless (list? (syntax->expression literals))
        (raise-syntax-error "invalid form in literals, expecting list" literals))
      (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 (cmp-identifier i1 i2)
      (cond
        ((string<? (identifier-uuid i1) (identifier-uuid i2)) -1)
        ((string=? (identifier-uuid i1) (identifier-uuid i2)) 0)
        (else 1)))


    (define (alist->substitutions l)
      (alist->map hash-identifier cmp-identifier l))


    (define (is-underscore expression)
      (free-identifier=?
        expression
        (wrap-syntax '_ (make-environment (alist->substitutions (list (cons '_ (make-library-ref '(csc builtins) '_ #t)))) '()))))


    (define (pattern-bindings pattern literals object)
      (syntax-case pattern
        (lit (when (and (free-identifier=? object lit)
                        (matches-literals literals object)))
          (alist->substitutions '()))
        (underscore (when (is-underscore underscore))
          (alist->substitutions '()))
        (ident (when (identifier? ident))
          (alist->substitutions (list (cons ident object))))
        ('()
          (syntax-case object
            ('() (alist->substitutions '()))
            (_ #f)))
        ((p . p*)
          (syntax-case object
            ((e . e*)
              (merge (pattern-bindings p literals e)
                     (pattern-bindings p* literals e*)))
            (_ #f)))
        (constant
          (if (equal? constant (syntax->expression object))
            (alist->substitutions '())
            #f))))


    (define (expand-template substitutions template)
      (syntax-case template
        ('() (with-wrap '() template))
        ((head . tail)
          (with-wrap
            (cons (expand-template substitutions head)
                  (expand-template substitutions tail))
            template))
        (ident (when (identifier? ident))
          (guard (e ((key-not-found-error? e) template))
            (lookup substitutions template)))
        (_ template)))


    (define (syntax-match 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 (map car all-rules)))
          ((((_ . pattern) template) . tail)
            (let ((bindings (pattern-bindings pattern literals (with-wrap (cdr (syntax->expression object)) object))))
              (if bindings
                ; 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.
                ;
                ; We also call expand-syntax-object immediately,
                ; since macros are allowed to be recursive -- rose
                (expand-syntax-object (add-mark (new-mark) (expand-template bindings template)))
                (loop tail))))
          (_ (raise-syntax-error "unexpected form in syntax-rules" all-rules)))))


    (define builtin-syntax-rules
      (make-macro-transformer
        (lambda (syntax-rules-form)
          (syntax-case syntax-rules-form
            ((_ literals . rules)
              (values
                (make-macro-transformer
                  (lambda (input-form)
                    (syntax-match literals rules input-form)))
                (syntax-object-environment syntax-rules-form)))
            (_ (raise-syntax-error "unexpected form in syntax-rules" syntax-rules-form))))))


    (define test-environment
      (make-environment
        (alist->substitutions
          (list (cons 'syntax-rules builtin-syntax-rules)
                (cons 'quote builtin-quote)
                (cons '_ (make-library-ref '(csc builtins) '_ #t))))
        '()))))