(load "compat-mzscheme.scm")
(define $ex:make-variable-transformer #f)
(define $ex:identifier? #f)
(define $ex:bound-identifier=? #f)
(define $ex:free-identifier=? #f)
(define $ex:generate-temporaries #f)
(define $ex:datum->syntax #f)
(define $ex:syntax->datum #f)
(define $ex:environment #f)
(define $ex:environment-bindings #f)
(define $ex:eval #f)
(define $ex:syntax-violation #f)
(define $ex:expand-file #f)
(define $ex:repl #f)
(define $ex:invalid-form #f)
(define $ex:register-macro! #f)
(define $ex:extend-table-of-envs! #f)
(define $ex:import-libraries #f)
(define $ex:syntax-rename #f)
(define $ex:map-while #f)
(define $ex:dotted-length #f)
(define $ex:dotted-butlast #f)
(define $ex:dotted-last #f)
(define $ex:unspecified #f)
(define (memp proc ls)
(cond ((null? ls) #f)
((pair? ls) (if (proc (car ls))
ls
(memp proc (cdr ls))))
(else (assertion-violation 'memp "Invalid argument" ls))))
(define (filter p? lst)
(if (null? lst)
'()
(if (p? (car lst))
(cons (car lst)
(filter p? (cdr lst)))
(filter p? (cdr lst)))))
(define (for-all proc l . ls)
(or (null? l)
(and (apply proc (car l) (map car ls))
(apply for-all proc (cdr l) (map cdr ls)))))
(begin
(define ex:generate-guid
(let ((token (ex:unique-token))
(ticks 0))
(lambda (symbol)
(set! ticks (+ ticks 1))
(string->symbol
(string-append (symbol->string symbol)
"~"
token
"~"
(number->string ticks))))))
(define (ex:free-name symbol)
(string->symbol (string-append "~" (symbol->string symbol))))
(define (ex:library->symbol postfix name)
(ex:free-name (string->symbol (string-append (ex:list->string name ".")
"~"
(symbol->string postfix)))))
(define-record-type ex:identifier
(ex:make-identifier name colors transformer-envs displacement maybe-library)
ex:identifier?
(name ex:id-name)
(colors ex:id-colors)
(transformer-envs ex:id-transformer-envs)
(displacement ex:id-displacement)
(maybe-library ex:id-maybe-library))
(define (ex:id-library id)
(or (ex:id-maybe-library id)
(ex:*current-library*)))
(define ex:*current-library* (make-parameter '()))
(define (ex:bound-identifier=? x y)
(ex:check x ex:identifier? 'bound-identifier=?)
(ex:check y ex:identifier? 'bound-identifier=?)
(and (eq? (ex:id-name x)
(ex:id-name y))
(equal? (ex:id-colors x)
(ex:id-colors y))))
(define (ex:free-identifier=? x y)
(ex:check x ex:identifier? 'free-identifier=?)
(ex:check y ex:identifier? 'free-identifier=?)
(let ((bx (ex:binding x))
(by (ex:binding y)))
(let ((result (if bx
(and by
(eq? (ex:binding-name bx)
(ex:binding-name by)))
(and (not by)
(eq? (ex:id-name x)
(ex:id-name y))))))
(and result
bx
(begin (ex:check-binding-level x bx)
(ex:check-binding-level y by)))
(and result
(ex:register-use! x bx)
(ex:register-use! y by))
result)))
(define (ex:free=? x symbol)
(and (ex:identifier? x)
(let ((bx (ex:binding x)))
(let ((result
(and bx
(eq? (ex:binding-name bx) symbol))))
(and result
bx
(ex:check-binding-level x bx))
(and result
(ex:register-use! x bx))
result))))
(define (ex:generate-color)
(ex:generate-guid 'c))
(define ex:*color* (make-parameter (ex:generate-color)))
(define (ex:make-binding type name levels content library)
(list type name levels content library))
(define ex:binding-type car)
(define ex:binding-name cadr)
(define ex:binding-levels caddr)
(define ex:binding-content cadddr)
(define (ex:binding-content-set! b x) (set-car! (cdddr b) x))
(define (ex:binding-library b) (car (cddddr b)))
(define (ex:binding id)
(let ((name (ex:id-name id)))
(let loop ((env (ex:*usage-env*))
(envs (ex:id-transformer-envs id))
(colors (ex:id-colors id)))
(or (ex:env-lookup (cons name colors) env #f)
(and (pair? envs)
(loop (car envs)
(cdr envs)
(cdr colors)))))))
(define (ex:make-local-mapping type id content)
(cons (cons (ex:id-name id)
(ex:id-colors id))
(ex:make-binding type
(ex:generate-guid (ex:id-name id))
(list (ex:source-level id))
content
(ex:*current-library*))))
(define (ex:make-toplevel-mapping type id content)
(if (null? (ex:id-colors id))
(cons (cons (ex:id-name id)
(ex:id-colors id))
(ex:make-binding type
(ex:free-name (ex:id-name id))
'(0)
content
(ex:*current-library*)))
(ex:make-local-mapping type id content)))
(define ex:*phase* (make-parameter 0))
(define (ex:source-level id)
(- (ex:*phase*)
(ex:id-displacement id)))
(define (ex:check-binding-level id binding)
(if (not binding)
(or (and (null? (ex:id-library id))
(= (ex:*phase*) 0))
(ex:syntax-violation
"invalid reference"
(string-append "No binding available for " (symbol->string (ex:id-name id))
" in library (" (ex:list->string (ex:id-library id) " ") ")")
id))
(or (memv (ex:source-level id)
(ex:binding-levels binding))
(ex:syntax-violation
"invalid reference"
(string-append "Attempt to use binding of " (symbol->string (ex:id-name id))
" in library (" (ex:list->string (ex:id-library id) " ")
") at invalid level " (number->string (ex:source-level id))
". Binding is only available at levels: "
(ex:list->string (ex:binding-levels binding) " "))
id))))
(define (ex:make-unit-env) (list (ex:make-frame '())))
(define (ex:env-extend mappings env)
(cons (ex:make-frame mappings) env))
(define (ex:env-extend! mappings env)
(ex:frame-extend! mappings (car (ex:env-reify env))))
(define (ex:env-lookup key env default)
(let ((env (ex:env-reify env)))
(cond ((null? env) default)
((ex:frame-lookup key (car env)) => cdr)
(else
(ex:env-lookup key (cdr env) default)))))
(define (ex:duplicate? id env)
(assoc (cons (ex:id-name id)
(ex:id-colors id))
(ex:unbox (car (ex:env-reify env)))))
(define (ex:make-frame mappings) (ex:box mappings))
(define (ex:frame-extend! mappings frame)
(ex:set-box! frame (append mappings (ex:unbox frame))))
(define (ex:frame-lookup key frame)
(assoc key (ex:unbox frame)))
(define ex:box list)
(define ex:unbox car)
(define ex:set-box! set-car!)
(define ex:*table-of-envs* (make-parameter '()))
(define (ex:env-reflect env)
(cond ((symbol? env) env)
((and (not (null? (ex:*table-of-envs*))) (eq? env (cdar (ex:*table-of-envs*)))) (caar (ex:*table-of-envs*))) (else
(let ((key (ex:generate-guid 'env)))
(ex:*table-of-envs*
(cons (cons key env)
(ex:*table-of-envs*)))
key))))
(define (ex:env-reify env)
(if (symbol? env)
(cdr (assq env (ex:*table-of-envs*)))
env))
(define (ex:extend-table-of-envs! envs)
(ex:*table-of-envs*
(append envs (ex:*table-of-envs*))))
(define (ex:syntax-reflect id)
(ex:*syntax-reflected* #t)
`($ex:syntax-rename ',(ex:id-name id)
',(ex:id-colors id)
',(ex:capture-transformer-envs id)
,(- (ex:*phase*) (ex:id-displacement id) 1)
',(ex:id-library id)))
(define (ex:syntax-rename name colors transformer-envs transformer-phase source-library)
(ex:make-identifier name
(cons (ex:*color*) colors)
transformer-envs
(- (ex:*phase*) transformer-phase)
source-library))
(define (ex:capture-transformer-envs id)
(cons (ex:env-reflect (ex:*usage-env*))
(ex:id-transformer-envs id)))
(define ex:*syntax-reflected* (make-parameter #f))
(define (ex:datum->syntax tid datum)
(ex:check tid ex:identifier? 'datum->syntax)
(ex:sexp-map (lambda (leaf)
(cond ((symbol? leaf)
(ex:make-identifier leaf
(ex:id-colors tid)
(ex:id-transformer-envs tid)
(ex:id-displacement tid)
(ex:id-maybe-library tid)))
(else leaf)))
datum))
(define (ex:syntax->datum exp)
(ex:sexp-map (lambda (leaf)
(cond ((ex:identifier? leaf) (ex:id-name leaf))
((symbol? leaf)
(assertion-violation 'syntax->datum "A symbol is not a valid syntax object" leaf))
(else leaf)))
exp))
(define (ex:generate-temporaries ls)
(ex:check ls list? 'generate-temporaries)
(map (lambda (ignore)
(ex:rename 'variable (ex:generate-guid 'gen)))
ls))
(define (ex:rename type symbol)
(ex:make-identifier symbol
(list (ex:*color*))
(list (ex:env-extend
(list (cons (list symbol)
(ex:make-binding type symbol '(0) #f '())))
(ex:make-unit-env)))
(ex:*phase*)
#f))
(define-record-type ex:macro (ex:make-macro type proc) ex:macro?
(type ex:macro-type)
(proc ex:macro-proc))
(define (ex:make-expander proc) (ex:make-macro 'expander proc))
(define (ex:make-transformer proc) (ex:make-macro 'transformer proc))
(define (ex:make-variable-transformer proc) (ex:make-macro 'variable-transformer proc))
(define (ex:make-user-macro procedure-or-macro)
(if (procedure? procedure-or-macro)
(ex:make-transformer procedure-or-macro)
procedure-or-macro))
(define ex:*macro-env* (make-parameter '()))
(define (ex:binding-macro binding)
(or (ex:binding-content binding)
(let ((probe (assq (ex:binding-name binding) (ex:*macro-env*))))
(if probe
(cdr probe)
(ex:syntax-violation #f "Reference to macro keyword out of context" (ex:binding-name binding))))))
(define (ex:register-macro! binding-name procedure-or-macro)
(ex:*macro-env* (cons (cons binding-name (ex:make-user-macro procedure-or-macro))
(ex:*macro-env*))))
(define (ex:expand t)
(ex:trace
t
(lambda ()
(let ((binding (ex:operator-binding t)))
(cond (binding (case (ex:binding-type binding)
((macro)
(let ((macro (ex:binding-macro binding)))
(ex:*color* (ex:generate-color))
(let ((expanded-once ((ex:macro-proc macro) t)))
(case (ex:macro-type macro)
((expander) expanded-once)
(else
(ex:expand expanded-once))))))
((variable)
(check-implicit-import-of-mutable binding t)
(if (list? t)
(cons (ex:binding-name binding)
(map ex:expand (cdr t)))
(ex:binding-name binding)))
((pattern-variable)
(ex:syntax-violation #f "Pattern variable used outside syntax template" t))))
((list? t) (map ex:expand t))
((ex:identifier? t) (ex:free-name (ex:id-name t)))
((pair? t) (ex:syntax-violation #f "Invalid procedure call syntax" t))
((symbol? t) (ex:syntax-violation #f "Symbol may not appear in syntax object" t))
(else t))))))
(define (ex:head-expand t)
(ex:trace
t
(lambda ()
(let ((binding (ex:operator-binding t)))
(cond (binding (case (ex:binding-type binding)
((macro)
(let ((macro (ex:binding-macro binding)))
(ex:*color* (ex:generate-color))
(case (ex:macro-type macro)
((expander) (values t binding))
(else
(ex:head-expand ((ex:macro-proc macro) t))))))
(else (values t binding))))
(else (values t binding)))))))
(define (ex:operator-binding form)
(let ((operator (if (pair? form) (car form) form)))
(and (ex:identifier? operator)
(let ((binding (ex:binding operator)))
(ex:check-binding-level operator binding)
(ex:register-use! operator binding)
binding))))
(define (check-implicit-import-of-mutable binding t)
(or (equal? (ex:binding-library binding) (ex:*current-library*))
(not (ex:binding-content binding))
(ex:syntax-violation
#f
(string-append "Attempt to implicitly import variable that is mutable in library ("
(ex:list->string (ex:binding-library binding) " ") ")")
t)))
(define (ex:expand-quote exp)
(or (and (list? exp)
(= (length exp) 2))
(ex:invalid-form exp))
(ex:syntax->datum exp))
(define (ex:expand-if exp)
(or (and (list? exp)
(<= 3 (length exp) 4))
(ex:invalid-form exp))
`(if ,(ex:expand (cadr exp))
,(ex:expand (caddr exp))
,@(if (= (length exp) 4)
(list (ex:expand (cadddr exp)))
`())))
(define (ex:expand-set! exp)
(or (and (list? exp)
(= (length exp) 3)
(ex:identifier? (cadr exp)))
(ex:invalid-form exp))
(let ((binding (ex:binding (cadr exp))))
(ex:check-binding-level (cadr exp) binding)
(ex:register-use! (cadr exp) binding)
(case (ex:binding-type binding)
((macro)
(let ((macro (ex:binding-macro binding)))
(case (ex:macro-type macro)
((variable-transformer)
(ex:expand ((ex:macro-proc macro) exp)))
(else
(ex:syntax-violation 'set! "Keyword being set! is not a variable transformer" exp (cadr exp))))))
((variable)
(or (eq? (ex:binding-library binding) (ex:*current-library*))
(ex:syntax-violation 'set! "Directly or indirectly imported variable cannot be assigned" exp (cadr exp)))
(ex:binding-content-set! binding #t)
`(set! ,(ex:binding-name binding)
,(ex:expand (caddr exp))))
((pattern-variable)
(ex:syntax-violation 'set! "Pattern variable used outside syntax template" exp (cadr exp))))))
(define (ex:expand-begin exp)
(or (and (list? exp)
(not (null? (cdr exp))))
(ex:invalid-form exp))
(ex:scan-sequence 'expression-sequence
#f
(cdr exp)
(lambda (forms no-syntax-definitions no-bound-variables)
`(begin ,@(map cdr forms)))))
(define (ex:expand-local-syntax t)
(ex:expand-begin `(,(ex:rename 'macro 'begin) ,t)))
(define (ex:expand-and exp)
(or (list? exp)
(ex:invalid-form exp))
(cond ((null? (cdr exp)) #t)
((null? (cddr exp)) (ex:expand (cadr exp)))
(else
`(if ,(ex:expand (cadr exp))
,(ex:expand `(,(ex:rename 'macro 'and) ,@(cddr exp)))
#f))))
(define (ex:expand-or exp)
(or (list? exp)
(ex:invalid-form exp))
(cond ((null? (cdr exp)) #f)
((null? (cddr exp)) (ex:expand (cadr exp)))
(else
`(let ((x ,(ex:expand (cadr exp))))
(if x x ,(ex:expand `(,(ex:rename 'macro 'or) ,@(cddr exp))))))))
(define (ex:expand-lambda exp)
(or (and (pair? exp)
(pair? (cdr exp))
(ex:formals? (cadr exp))
(list? (cddr exp)))
(ex:invalid-form exp))
(let ((formals (cadr exp))
(body (cddr exp)))
(parameterize ((ex:*usage-env*
(ex:env-extend (map (lambda (formal)
(ex:make-local-mapping 'variable formal #f))
(ex:flatten formals))
(ex:*usage-env*))))
(let ((formals (ex:dotted-map (lambda (formal) (ex:binding-name (ex:binding formal))) formals)))
(parameterize ((ex:*usage-env* (ex:env-extend '() (ex:*usage-env*))))
(ex:scan-sequence 'lambda
ex:make-local-mapping
body
(lambda (forms syntax-definitions bound-variables)
`(lambda ,formals
((lambda ,bound-variables
,@(ex:emit-body forms 'set!))
,@(map (lambda (ignore) `($ex:unspecified))
bound-variables))))))))))
(define (ex:formals? s)
(or (null? s)
(ex:identifier? s)
(and (pair? s)
(ex:identifier? (car s))
(ex:formals? (cdr s))
(not (ex:dotted-memp (lambda (x)
(ex:bound-identifier=? x (car s)))
(cdr s))))))
(define-record-type ex:wrap (ex:make-wrap env exp) ex:wrap?
(env ex:wrap-env)
(exp ex:wrap-exp))
(define (ex:scan-sequence body-type make-map body-forms k)
(define (expand-deferred forms)
(map (lambda (form)
(cons (car form)
(let ((exp (cdr form)))
(if (ex:wrap? exp)
(parameterize ((ex:*usage-env* (ex:wrap-env exp)))
(ex:expand (ex:wrap-exp exp)))
exp))))
forms))
(let ((common-env (ex:*usage-env*)))
(ex:add-fresh-used-frame!)
(let loop ((ws (map (lambda (e) (ex:make-wrap common-env e))
body-forms))
(forms '())
(syntax-defs '())
(bound-variables '()))
(cond
((null? ws)
(ex:check-expression-body body-type forms body-forms)
(ex:merge-used-with-parent-frame!)
(k (reverse (expand-deferred forms))
(reverse syntax-defs)
bound-variables))
(else
(parameterize ((ex:*usage-env* (ex:wrap-env (car ws))))
(let-values (((form operator-binding) (ex:head-expand (ex:wrap-exp (car ws)))))
(let ((type (and operator-binding (ex:binding-name operator-binding))))
(ex:check-expression-sequence body-type type form)
(ex:check-toplevel body-type type form)
(case type
((import)
(let-values (((imported-libraries imports) (ex:scan-imports form)))
(ex:import-libraries imported-libraries 0 'compile)
(ex:env-import! (car form) imports common-env)
(loop (cdr ws)
(cons (cons #f `($ex:import-libraries ',imported-libraries 0 'execute))
forms)
syntax-defs
bound-variables)))
((program)
(loop (cdr ws)
(cons (cons #f (ex:expand-program form)) forms)
syntax-defs
bound-variables))
((library)
(loop (cdr ws)
(cons (cons #f (ex:expand-library form)) forms)
syntax-defs
bound-variables))
((define)
(let-values (((id rhs) (ex:parse-definition form)))
(ex:check-valid-definition id common-env body-type form forms type)
(ex:env-extend! (list (make-map 'variable id #f)) common-env)
(loop (cdr ws)
(cons (cons (ex:binding-name (ex:binding id))
(ex:make-wrap (ex:*usage-env*) rhs))
forms)
syntax-defs
(cons (ex:binding-name (ex:binding id)) bound-variables))))
((define-syntax)
(let-values (((id rhs) (ex:parse-definition form)))
(ex:check-valid-definition id common-env body-type form forms type)
(let ((mapping (make-map 'macro id #f)))
(ex:env-extend! (list mapping) common-env)
(let ((rhs (parameterize ((ex:*phase* (+ 1 (ex:*phase*))))
(ex:expand rhs))))
(ex:binding-content-set! (cdr mapping) (ex:make-user-macro (eval rhs)))
(loop (cdr ws)
forms
(cons (cons (ex:binding-name (ex:binding id)) rhs) syntax-defs)
bound-variables)))))
((begin)
(or (list? form)
(ex:invalid-form form))
(loop (append (map (lambda (exp)
(ex:make-wrap (ex:*usage-env*) exp))
(cdr form))
(cdr ws))
forms
syntax-defs
bound-variables))
((let-syntax letrec-syntax)
(let-values (((formals rhs body) (ex:parse-local-syntax form)))
(let* ((original-env (ex:*usage-env*))
(usage-diff (map (lambda (formal)
(ex:make-local-mapping 'macro formal #f))
formals))
(extended-env (ex:env-extend usage-diff original-env))
(rhs-expanded
(parameterize ((ex:*phase* (+ 1 (ex:*phase*)))
(ex:*usage-env*
(case type
((let-syntax) original-env)
((letrec-syntax) extended-env))))
(map ex:expand rhs)))
(macros (map eval rhs-expanded)))
(for-each (lambda (mapping macro)
(ex:binding-content-set! (cdr mapping) (ex:make-user-macro macro)))
usage-diff
macros)
(loop (append (map (lambda (form) (ex:make-wrap extended-env form))
body)
(cdr ws))
forms
syntax-defs
bound-variables))))
(else
(loop (cdr ws)
(cons (cons #f (ex:make-wrap (ex:*usage-env*) form))
forms)
syntax-defs
bound-variables)))))))))))
(define (ex:emit-body body-forms define-or-set)
(map (lambda (body-form)
(if (symbol? (car body-form))
`(,define-or-set ,(car body-form) ,(cdr body-form))
(cdr body-form)))
body-forms))
(define (ex:parse-definition t)
(or (and (pair? t)
(pair? (cdr t)))
(ex:syntax-violation #f "Invalid definition format" t))
(let ((k (car t))
(head (cadr t))
(body (cddr t)))
(cond ((and (ex:identifier? head)
(list? body)
(<= (length body) 1))
(values head (if (null? body)
`(,(ex:rename 'variable '$ex:unspecified))
(car body))))
((and (pair? head)
(ex:identifier? (car head))
(ex:formals? (cdr head)))
(values (car head)
`(,(ex:rename 'macro 'lambda) ,(cdr head) . ,body)))
(else (ex:syntax-violation #f "Invalid definition format" t)))))
(define (ex:parse-local-syntax t)
(or (and (pair? t)
(pair? (cdr t))
(list? (cadr t))
(list? (cddr t))
(for-all (lambda (binding)
(and (pair? binding)
(ex:identifier? (car binding))
(pair? (cdr binding))
(null? (cddr binding))))
(cadr t)))
(ex:syntax-violation #f "Invalid form" t))
(let ((formals (map car (cadr t)))
(exps (map cadr (cadr t)))
(body (cddr t)))
(or (ex:formals? formals)
(ex:syntax-violation #f "Duplicate binding" t))
(values formals
exps
body)))
(define (ex:check-expression-sequence body-type type form)
(and (eq? body-type 'expression-sequence)
(memq type '(import program library define define-syntax))
(ex:syntax-violation type "Invalid form in expression sequence" form)))
(define (ex:check-toplevel body-type type form)
(and (not (eq? body-type 'toplevel))
(memq type '(import program library))
(ex:syntax-violation type "Expression may only occur at toplevel" form)))
(define (ex:check-valid-definition id common-env body-type form forms type)
(and (not (eq? body-type 'toplevel))
(ex:duplicate? id common-env)
(ex:syntax-violation type "Redefinition of identifier in body" form id))
(ex:check-used id body-type form)
(and (not (memq body-type `(toplevel program)))
(not (null? forms))
(not (symbol? (car (car forms))))
(ex:syntax-violation type "Definitions may not follow expressions in a body" form)))
(define (ex:check-expression-body body-type forms body-forms)
(and (eq? body-type 'lambda)
(or (null? forms)
(symbol? (caar forms)))
(ex:syntax-violation body-type "Body must be nonempty and end with an expression" body-forms)))
(define (ex:expand-syntax-case exp)
(if (and (list? exp)
(>= (length exp) 3))
(let ((literals (caddr exp))
(clauses (cdddr exp)))
(if (and (list? literals)
(for-all ex:identifier? literals)
(not (memp (lambda (x) (or (ex:free=? x '_)
(ex:free=? x '...)))
literals)))
(let ((input (ex:generate-guid 'input)))
`(let ((,input ,(ex:expand (cadr exp))))
,(ex:process-clauses clauses input literals)))
(ex:syntax-violation 'syntax-case "Invalid literals list" exp literals)))
(ex:invalid-form exp)))
(define (ex:process-clauses clauses input literals)
(define (process-match input pattern sk fk)
(cond
((not (symbol? input)) (let ((temp (ex:generate-guid 'temp)))
`(let ((,temp ,input))
,(process-match temp pattern sk fk))))
((and (ex:identifier? pattern)
(memp (lambda (x)
(ex:bound-identifier=? x pattern))
literals))
`(if (and ($ex:identifier? ,input)
($ex:free-identifier=? ,input ,(ex:syntax-reflect pattern)))
,sk
,fk))
((ex:ellipses? pattern) (ex:syntax-violation 'syntax-case "Invalid use of ellipses" pattern))
((null? pattern) `(if (null? ,input) ,sk ,fk))
((ex:wildcard? pattern) sk)
((ex:identifier? pattern) `(let ((,(ex:binding-name (ex:binding pattern)) ,input)) ,sk))
((ex:segment-pattern? pattern)
(let ((tail-pattern (cddr pattern)))
(if (null? tail-pattern)
(let ((mapped-pvars (map (lambda (pvar) (ex:binding-name (ex:binding pvar)))
(map car (pattern-vars (car pattern) 0)))))
(if (and (ex:identifier? (car pattern)) (= (length mapped-pvars) 1)) `(if (list? ,input) (let ((,(car mapped-pvars) ,input)) ,sk) ,fk) (let ((columns (ex:generate-guid 'cols))
(rest (ex:generate-guid 'rest)))
`($ex:map-while (lambda (,input)
,(process-match input
(car pattern)
`(list ,@mapped-pvars)
#f))
,input
(lambda (,columns ,rest)
(if (null? ,rest)
(apply (lambda ,mapped-pvars ,sk)
(if (null? ,columns)
',(map (lambda (ignore) '()) mapped-pvars)
(apply map list ,columns)))
,fk))))))
(let ((tail-length (ex:dotted-length tail-pattern)))
`(if (>= ($ex:dotted-length ,input) ,tail-length)
,(process-match `($ex:dotted-butlast ,input ,tail-length)
`(,(car pattern) ,(cadr pattern))
(process-match `($ex:dotted-last ,input ,tail-length)
(cddr pattern)
sk
fk)
fk)
,fk)))))
((pair? pattern) `(if (pair? ,input)
,(process-match `(car ,input)
(car pattern)
(process-match `(cdr ,input) (cdr pattern) sk fk)
fk)
,fk))
((vector? pattern) `(if (vector? ,input)
,(process-match `(vector->list ,input)
(vector->list pattern)
sk
fk)
,fk))
((symbol? pattern) (ex:syntax-violation 'syntax-case "Invalid pattern" pattern))
(else `(if (equal? ,input ',pattern) ,sk ,fk))))
(define (pattern-vars pattern level)
(cond
((ex:identifier? pattern) (if (or (ex:ellipses? pattern)
(ex:wildcard? pattern)
(memp (lambda (x)
(ex:bound-identifier=? x pattern))
literals))
'()
(list (cons pattern level))))
((ex:segment-pattern? pattern) (append (pattern-vars (car pattern) (+ level 1))
(pattern-vars (cddr pattern) level)))
((pair? pattern) (append (pattern-vars (car pattern) level)
(pattern-vars (cdr pattern) level)))
((vector? pattern) (pattern-vars (vector->list pattern) level))
(else '())))
(define (process-clause clause input fk)
(or (and (list? clause)
(>= (length clause) 2))
(ex:syntax-violation 'syntax-case "Invalid clause" clause))
(let* ((pattern (car clause))
(template (cdr clause))
(pvars (pattern-vars pattern 0)))
(ex:check-set? (map car pvars)
ex:bound-identifier=?
(lambda (dup)
(ex:syntax-violation 'syntax-case "Repeated pattern variable" clause dup)))
(let ((mappings (map (lambda (pvar)
(ex:make-local-mapping 'pattern-variable (car pvar) (cdr pvar)))
pvars)))
(parameterize ((ex:*usage-env* (ex:env-extend mappings (ex:*usage-env*))))
(process-match input
pattern
(cond ((null? (cdr template))
(ex:expand (car template)))
((null? (cddr template))
`(if ,(ex:expand (car template))
,(ex:expand (cadr template))
,fk))
(else (ex:syntax-violation 'syntax-case "Invalid clause" clause)))
fk)))))
(if (null? clauses)
`($ex:invalid-form ,input)
(let ((fail (ex:generate-guid 'fail)))
`(let ((,fail (lambda () ,(ex:process-clauses (cdr clauses) input literals))))
,(process-clause (car clauses) input `(,fail))))))
(define (ex:wildcard? x) (ex:free=? x '_))
(define (ex:ellipses? x) (ex:free=? x '...))
(define (ex:segment-pattern? pattern)
(and (ex:segment-template? pattern)
(or (for-all (lambda (p)
(not (ex:ellipses? p)))
(ex:flatten (cddr pattern)))
(ex:syntax-violation 'syntax-case "Invalid segment pattern" pattern))))
(define (ex:segment-template? pattern)
(and (pair? pattern)
(pair? (cdr pattern))
(ex:identifier? (cadr pattern))
(ex:ellipses? (cadr pattern))))
(define (ex:segment-depth pattern)
(if (ex:segment-template? pattern)
(+ 1 (ex:segment-depth (cdr pattern)))
0))
(define (ex:segment-tail pattern)
(let loop ((pattern (cdr pattern)))
(if (and (pair? pattern)
(ex:identifier? (car pattern))
(ex:ellipses? (car pattern)))
(loop (cdr pattern))
pattern)))
(define (ex:ellipses-quote? template)
(and (pair? template)
(ex:ellipses? (car template))
(pair? (cdr template))
(null? (cddr template))))
(define (ex:expand-syntax form)
(or (and (pair? form)
(pair? (cdr form))
(null? (cddr form)))
(ex:invalid-form form))
(ex:process-template (cadr form) 0 #f))
(define (ex:process-template template dim quote-ellipses)
(cond ((and (ex:ellipses? template)
(not quote-ellipses))
(ex:syntax-violation 'syntax "Invalid occurrence of ellipses in syntax template" template))
((ex:identifier? template)
(let ((binding (ex:binding template)))
(cond ((and binding
(eq? (ex:binding-type binding) 'pattern-variable)
(ex:binding-content binding))
=> (lambda (pdim)
(if (<= pdim dim)
(begin
(ex:check-binding-level template binding)
(ex:register-use! template binding)
(ex:binding-name binding))
(ex:syntax-violation 'syntax "Template dimension error (too few ...'s?)" template))))
(else
(ex:syntax-reflect template)))))
((ex:ellipses-quote? template)
(ex:process-template (cadr template) dim #t))
((and (ex:segment-template? template)
(not quote-ellipses))
(let* ((depth (ex:segment-depth template))
(seg-dim (+ dim depth))
(vars
(map (lambda (mapping)
(let ((id (car mapping))
(binding (cdr mapping)))
(ex:check-binding-level id binding)
(ex:register-use! id binding)
(ex:binding-name binding)))
(ex:free-meta-variables (car template) seg-dim '()))))
(if (null? vars)
(ex:syntax-violation 'syntax "Too many ...'s" template)
(let* ((x (ex:process-template (car template) seg-dim quote-ellipses))
(gen (if (equal? (list x) vars) x `(map (lambda ,vars ,x)
,@vars)))
(gen (do ((d depth (- d 1))
(gen gen `(apply append ,gen)))
((= d 1)
gen))))
(if (null? (ex:segment-tail template))
gen `(append ,gen ,(ex:process-template (ex:segment-tail template) dim quote-ellipses)))))))
((pair? template)
`(cons ,(ex:process-template (car template) dim quote-ellipses)
,(ex:process-template (cdr template) dim quote-ellipses)))
((vector? template)
`(list->vector ,(ex:process-template (vector->list template) dim quote-ellipses)))
(else
`(quote ,(ex:expand template)))))
(define (ex:free-meta-variables template dim free)
(cond ((ex:identifier? template)
(if (memp (lambda (x) (ex:bound-identifier=? (car x) template))
free)
free
(let ((binding (ex:binding template)))
(if (and binding
(eq? (ex:binding-type binding) 'pattern-variable)
(let ((pdim (ex:binding-content binding)))
(>= pdim dim)))
(cons (cons template binding) free)
free))))
((ex:segment-template? template)
(ex:free-meta-variables (car template) dim
(ex:free-meta-variables (cddr template) dim free)))
((pair? template)
(ex:free-meta-variables (car template) dim
(ex:free-meta-variables (cdr template) dim free)))
(else free)))
(define ex:*used* (make-parameter (list '())))
(define (ex:add-fresh-used-frame!)
(ex:*used* (cons '() (ex:*used*))))
(define (ex:register-use! id binding)
(ex:*used* (cons (cons (cons id binding)
(car (ex:*used*)))
(cdr (ex:*used*)))))
(define (ex:merge-used-with-parent-frame!)
(ex:*used* (cons (append (car (ex:*used*))
(cadr (ex:*used*)))
(cddr (ex:*used*)))))
(define (ex:check-used id body-type form)
(and (not (eq? body-type 'toplevel))
(let* ((already-used (car (ex:*used*)))
(binding (ex:binding id)))
(if (memp (lambda (mapping)
(and (eq? binding (cdr mapping))
(ex:bound-identifier=? id (car mapping))))
already-used)
(ex:syntax-violation
'definition
"Definition of identifier that may have already affected meaning of undeferred portions of body"
form
id)))))
(define (ex:expand-program t)
(ex:expand-library-or-program
`(,(car t) (,(ex:datum->syntax (car t) (ex:generate-guid 'program)))
(,(ex:datum->syntax (car t) 'export)) . ,(cdr t))
'program))
(define (ex:expand-library t)
(ex:expand-library-or-program t 'library))
(define (ex:expand-library-or-program t library-type)
(or (and (list? t)
(>= (length t) 4))
(ex:syntax-violation 'library "Invalid number of clauses in library" t))
(let ((keyword (car t))
(name (ex:syntax->datum (ex:library-name (cadr t)))))
(let-values (((exports) (ex:scan-exports (caddr t)))
((imported-libraries imports) (ex:scan-imports (cadddr t)))
((body) (cddddr t)))
(parameterize ((ex:*table-of-envs* '())
(ex:*usage-env* (ex:make-unit-env))
(ex:*macro-env* '())
(ex:*current-library* name)
(ex:*syntax-reflected* #f))
(ex:import-libraries imported-libraries 0 'compile)
(ex:env-import! keyword imports (ex:*usage-env*))
(let ((initial-table-of-envs (ex:*table-of-envs*)))
(ex:*usage-env* (ex:env-reflect (ex:*usage-env*)))
(ex:scan-sequence library-type
ex:make-local-mapping
body
(lambda (forms syntax-definitions bound-variables)
(let* ((exports
(map (lambda (mapping)
(cons (ex:id-name (car mapping))
(let ((binding (ex:binding (cadr mapping))))
(or binding
(ex:syntax-violation 'library "Unbound export" t
(cadr mapping)))
(if (eq? (ex:binding-content binding) #t)
(ex:syntax-violation 'library
"Attempt to export mutable variable" t
(cadr mapping)))
(ex:sexp-replace ex:macro? #f binding))))
exports))
(expanded-library
(case library-type
((program) `(begin
($ex:import-libraries ',imported-libraries 0 'execute)
,@(ex:emit-body forms 'define)))
((library)
`(begin
(define ,(ex:library->symbol 'envs name)
',(if (ex:*syntax-reflected*) (ex:sexp-replace
ex:macro?
#f
(ex:amputate-tail (ex:*table-of-envs*) initial-table-of-envs)) '()))
(define ,(ex:library->symbol 'exports name) ',exports)
(define ,(ex:library->symbol 'imports name) ',imported-libraries)
(define (,(ex:library->symbol 'visit name))
,@(map (lambda (def)
`($ex:register-macro! ',(car def) ,(cdr def)))
syntax-definitions)
($ex:unspecified))
,@(map (lambda (var)
`(define ,var ($ex:unspecified)))
bound-variables)
(define (,(ex:library->symbol 'invoke name))
,@(ex:emit-body forms 'set!)
($ex:unspecified)))))))
(if (eq? library-type 'library)
(eval expanded-library))
expanded-library))))))))
(define (ex:env-import! keyword imports env)
(ex:env-extend! (map (lambda (import)
(cons (cons (car import)
(ex:id-colors keyword))
(cdr import)))
imports)
env))
(define (ex:import-libraries imports level session)
(define *visited* '())
(define *invoked* '())
(define *imported* '())
(define (import-libraries* imports level session)
(for-each (lambda (import)
(let ((name (car import))
(levels (cdr import)))
(for-each (lambda (level*)
(import-library name (+ level level*) session))
levels)))
imports))
(define (import-library name level session)
(and (not (member (cons name level) *imported*))
(let ((imports (eval (ex:library->symbol 'imports name))))
(set! *imported* (cons (cons name level) *imported*))
(import-libraries* imports level session)
(and (>= level 0)
(case session
((compile)
(and (>= level 0)
(or (member name *visited*)
(begin
(ex:extend-table-of-envs! (eval (ex:library->symbol 'envs name)))
(parameterize ((ex:*phase* level))
(eval `(,(ex:library->symbol 'visit name))))
(set! *visited* (cons name *visited*)))))
(and (>= level 1)
(or (member name *invoked*)
(begin
(parameterize ((ex:*phase* level))
(eval `(,(ex:library->symbol 'invoke name))))
(set! *invoked* (cons name *invoked*))))))
((execute)
(and (= level 0)
(eval `(,(ex:library->symbol 'invoke name))))))))))
(import-libraries* imports level session))
(define (ex:scan-exports clause)
(and (pair? clause)
(ex:free=? (car clause) 'export)
(list? (cdr clause)))
(let ((exports (apply append
(map ex:scan-export-spec (cdr clause)))))
(ex:check-set? exports
(lambda (x y)
(eq? (ex:id-name (car x))
(ex:id-name (car y))))
(lambda (dup) (ex:syntax-violation 'export "Duplicate export" clause dup)))
exports))
(define (ex:scan-export-spec spec)
(let ((levels `(0)) (export-sets (list spec))) (map (lambda (rename-pair)
(cons (car rename-pair)
(cons (cdr rename-pair)
levels)))
(apply append (map ex:scan-export-set export-sets)))))
(define (ex:scan-export-set set)
(cond ((ex:identifier? set)
(list (cons set set)))
((ex:rename-export-set? set)
(map (lambda (mapping)
(cons (cadr mapping)
(car mapping)))
(cdr set)))
(else
(ex:syntax-violation 'export "Invalid export set" set))))
(define (ex:scan-levels spec)
(cond ((ex:for-spec? spec)
(let ((levels
(map (lambda (level)
(cond ((ex:free=? level 'run) 0)
((ex:free=? level 'expand) 1)
((ex:meta-spec? level) (cadr level))
(else (ex:syntax-violation 'for "Invalid level in for spec" spec level))))
(cddr spec))))
(ex:check-set? levels
=
(lambda (dup) (ex:syntax-violation 'for "Repeated level in for spec" spec dup)))
levels))
(else '(0))))
(define (ex:scan-imports clause)
(or (and (pair? clause)
(ex:free=? (car clause) 'import)
(list? (cdr clause)))
(ex:syntax-violation 'import "Invalid import clause" clause))
(ex:scan-import-specs (cdr clause)))
(define (ex:scan-import-specs all-specs)
(let loop ((specs all-specs)
(imported-libraries '())
(imports '()))
(if (null? specs)
(values imported-libraries (ex:unify-imports imports))
(let-values (((library-ref levels more-imports) (ex:scan-import-spec (car specs))))
(loop (cdr specs)
(if library-ref
(cons (cons library-ref levels)
imported-libraries)
imported-libraries)
(append more-imports imports))))))
(define (ex:scan-import-spec spec)
(let ((levels (ex:scan-levels spec)))
(let loop ((import-set (if (ex:for-spec? spec)
(cadr spec)
spec))
(adjuster (lambda (set) set)))
(cond ((ex:primitive-set? import-set)
(values #f
levels
(map (lambda (mapping)
(cons (car mapping) (ex:make-binding 'variable (cdr mapping) levels #f '())))
(adjuster (map (lambda (name) (cons name name))
(ex:syntax->datum (cdr import-set)))))))
((or (ex:only-set? import-set)
(ex:except-set? import-set)
(ex:prefix-set? import-set)
(ex:rename-set? import-set))
(loop (cadr import-set)
(let ((args (ex:syntax->datum (cddr import-set))))
(define (check-presence names mappings from)
(for-each (lambda (name)
(or (assq name mappings)
(ex:syntax-violation from
(string-append "Identifier not in set: "
(ex:list->string (map car mappings) " "))
import-set
name)))
names))
(ex:compose adjuster
(cond
((ex:only-set? import-set)
(lambda (mappings)
(check-presence args mappings 'only)
(filter (lambda (mapping)
(memq (car mapping) args))
mappings)))
((ex:except-set? import-set)
(lambda (mappings)
(check-presence args mappings 'except)
(filter (lambda (mapping)
(not (memq (car mapping) args)))
mappings)))
((ex:prefix-set? import-set)
(lambda (mappings)
(map (lambda (mapping)
(cons (string->symbol
(string-append (symbol->string (car args))
(symbol->string (car mapping))))
(cdr mapping)))
mappings)))
((ex:rename-set? import-set)
(lambda (mappings)
(check-presence (map car args) mappings 'rename)
(map (lambda (mapping)
(cons (cond ((assq (car mapping) args) => cadr)
(else (car mapping)))
(cdr mapping)))
mappings)))
(else (ex:syntax-violation 'import "Invalid import set" import-set)))))))
((ex:library-ref import-set)
=> (lambda (library-ref)
(let* ((exports (eval (ex:library->symbol 'exports (ex:syntax->datum library-ref))))
(imports
(map (lambda (mapping)
(cons (car mapping)
(let ((binding (cdr (assq (cdr mapping) exports))))
(ex:make-binding (ex:binding-type binding)
(ex:binding-name binding)
(ex:compose-levels levels (ex:binding-levels binding))
(ex:binding-content binding)
(ex:binding-library binding)))))
(adjuster (map (lambda (name) (cons name name))
(map car exports))))))
(values (ex:syntax->datum library-ref)
levels
imports))))
(else (ex:syntax-violation 'import "Invalid import set" import-set))))))
(define (ex:compose-levels levels levels*)
(apply ex:unionv
(map (lambda (level)
(map (lambda (level*)
(+ level level*))
levels*))
levels)))
(define (ex:unify-imports imports)
(let ((seen '()))
(let loop ((imports imports))
(if (null? imports)
seen
(let* ((mapping (car imports))
(probe (assq (car mapping) seen)))
(if probe
(begin
(or (eq? (ex:binding-name (cdr mapping))
(ex:binding-name (cdr probe)))
(ex:syntax-violation
'import
(string-append "Different bindings for identifier imported from libraries ("
(ex:list->string (ex:binding-library (cdr mapping)) " ")
") and ("
(ex:list->string (ex:binding-library (cdr probe)) " ") ")")
(car mapping)))
(set-cdr! probe
(ex:make-binding (ex:binding-type (cdr probe))
(ex:binding-name (cdr probe))
(ex:unionv (ex:binding-levels (cdr probe))
(ex:binding-levels (cdr mapping)))
(ex:binding-content (cdr probe))
(ex:binding-library (cdr probe)))))
(set! seen (cons mapping seen)))
(loop (cdr imports)))))))
(define (ex:for-spec? spec)
(and (list? spec)
(>= (length spec) 2)
(ex:free=? (car spec) 'for)))
(define (ex:meta-spec? level)
(and (list? level)
(= (length level) 2)
(ex:free=? (car level) 'meta)
(integer? (cadr level))))
(define (ex:only-set? set)
(and (list? set)
(>= (length set) 2)
(ex:free=? (car set) 'only)
(for-all ex:identifier? (cddr set))))
(define (ex:except-set? set)
(and (list? set)
(>= (length set) 2)
(ex:free=? (car set) 'except)
(for-all ex:identifier? (cddr set))))
(define (ex:prefix-set? set)
(and (list? set)
(>= (length set) 2)
(ex:free=? (car set) 'prefix)
(= (length set) 3)
(ex:identifier? (caddr set))))
(define (ex:rename-set? set)
(and (list? set)
(>= (length set) 2)
(ex:free=? (car set) 'rename)
(ex:rename-list? (cddr set))))
(define (ex:primitive-set? set)
(and (list? set)
(pair? set)
(ex:free=? (car set) 'primitives)
(for-all ex:identifier? (cdr set))))
(define (ex:rename-export-set? set)
(and (list? set)
(>= (length set) 1)
(ex:free=? (car set) 'rename)
(ex:rename-list? (cdr set))))
(define (ex:rename-list? ls)
(for-all (lambda (e)
(and (list? e)
(= (length e) 2)
(for-all ex:identifier? e)))
ls))
(define (ex:library-name e)
(ex:library-ref-helper e ex:version?))
(define (ex:library-ref e)
(ex:library-ref-helper
(if (and (list? e)
(= (length e) 2)
(ex:free=? (car e) 'library))
(cadr e)
e)
ex:version-reference?))
(define (ex:library-ref-helper e version?)
(or (and (list? e)
(pair? e)
(let ((re (reverse e)))
(and (for-all ex:identifier? (cdr re))
(if (ex:identifier? (car re))
e
(and (version? (car re))
(reverse (cdr re)))))))
(ex:syntax-violation 'library "Invalid library name" e)))
(define (ex:version? e)
(and (list? e)
(for-all ex:subversion? e)))
(define (ex:subversion? x)
(and (integer? x)
(>= x 0)))
(define (ex:version-reference? e)
(and (list? e)
(or (for-all ex:subversion-reference? e)
(and (pair? e)
(for-all ex:version-reference? (cdr e))
(or (ex:free=? (car e) 'and)
(ex:free=? (car e) 'or)
(and (ex:free=? (car e) 'not)
(= (length e) 2)))))))
(define (ex:subversion-reference? e)
(or (ex:subversion? e)
(ex:subversion-condition? e)))
(define (ex:subversion-condition? e)
(and (list? e)
(pair? e)
(cond
((or (ex:free=? (car e) '>=)
(ex:free=? (car e) '<=))
(and (= (length e) 2)
(ex:subversion? (cadr e))))
((or (ex:free=? (car e) 'and)
(ex:free=? (car e) 'or))
(for-all ex:subversion-reference? (cdr e)))
((ex:free=? (car e) 'not)
(and (= (length e) 2)
(ex:subversion-reference? (cadr e))))
(else #f))))
(define ex:*trace* (make-parameter '()))
(define (ex:trace term thunk)
(parameterize ((ex:*trace* (cons term (ex:*trace*))))
(thunk)))
(define (ex:syntax-violation who message form . maybe-subform)
(newline)
(display "Syntax violation: ")
(let ((who (if who
who
(cond ((ex:identifier? form)
(ex:syntax->datum form))
((and (list? form)
(ex:identifier? (car form)))
(ex:syntax->datum (car form)))
(else ""))))
(subform (cond ((null? maybe-subform) #f)
((and (pair? maybe-subform)
(null? (cdr maybe-subform)))
(car maybe-subform))
(else (assertion-violation 'syntax-violation
"Invalid subform in syntax violation"
maybe-subform)))))
(display who)
(newline)
(newline)
(display message)
(newline)
(newline)
(if subform
(begin (display "Subform: ")
(pretty-print (ex:syntax-debug subform))
(newline)))
(display "Form: ")
(pretty-print (ex:syntax-debug form))
(newline)
(display "Trace: ")
(newline)
(newline)
(for-each (lambda (exp)
(display " ")
(pretty-print (ex:syntax-debug exp))
(newline))
(ex:*trace*))
(error 'syntax-violation "Integrate with host error handling here")))
(define (ex:syntax-debug exp)
(ex:sexp-map (lambda (leaf)
(cond ((ex:identifier? leaf)
(ex:id-name leaf))
(else leaf)))
exp))
(define ex:eval-template
(ex:make-identifier 'eval-template
'()
'()
0
`(,(ex:generate-guid 'secret-eval-library))))
(define-record-type ex:r6rs-environment (ex:make-r6rs-environment imported-libraries imports)
ex:r6rs-environment?
(imported-libraries ex:r6rs-environment-imported-libraries)
(imports ex:r6rs-environment-imports))
(define (ex:environment . import-specs)
(parameterize ((ex:*usage-env* (ex:make-unit-env)))
(ex:env-import! ex:eval-template ex:library-language (ex:*usage-env*))
(let-values (((imported-libraries imports)
(ex:scan-import-specs
(map (lambda (spec)
(ex:datum->syntax ex:eval-template spec))
import-specs))))
(ex:make-r6rs-environment imported-libraries imports))))
(define (ex:eval exp env)
(parameterize ((ex:*usage-env* (ex:make-unit-env)))
(ex:env-import! ex:eval-template (ex:r6rs-environment-imports env) (ex:*usage-env*))
(let ((exp (ex:datum->syntax ex:eval-template exp)))
(ex:import-libraries (ex:r6rs-environment-imported-libraries env) 0 'compile)
(ex:import-libraries (ex:r6rs-environment-imported-libraries env) 0 'execute)
(eval (ex:expand-begin
`(,(ex:rename 'macro 'begin) ,exp))))))
(define (ex:environment-bindings r6rs-env)
(map format-mapping
(ex:r6rs-environment-imports r6rs-env)))
(define (format-mapping mapping)
`((name ,(car mapping))
(type ,(ex:binding-type (cdr mapping)))
(from ,(ex:binding-library (cdr mapping)))
(levels ,(ex:binding-levels (cdr mapping)))))
(define (ex:flatten l)
(cond ((null? l) l)
((pair? l) (cons (car l)
(ex:flatten (cdr l))))
(else (list l))))
(define (ex:sexp-map f s)
(cond ((null? s) '())
((pair? s) (cons (ex:sexp-map f (car s))
(ex:sexp-map f (cdr s))))
((vector? s)
(apply vector (ex:sexp-map f (vector->list s))))
(else (f s))))
(define (ex:sexp-replace pred? value sexp)
(ex:sexp-map (lambda (leaf)
(if (pred? leaf)
value
leaf))
sexp))
(define (ex:dotted-memp proc ls)
(cond ((null? ls) #f)
((pair? ls) (if (proc (car ls))
ls
(ex:dotted-memp proc (cdr ls))))
(else (and (proc ls)
ls))))
(define (ex:dotted-map f lst)
(cond ((null? lst) '())
((pair? lst) (cons (f (car lst))
(ex:dotted-map f (cdr lst))))
(else (f lst))))
(define (ex:dotted-length dl)
(cond ((null? dl) 0)
((pair? dl) (+ 1 (ex:dotted-length (cdr dl))))
(else 0)))
(define (ex:dotted-butlast ls n)
(let recurse ((ls ls)
(length-left (ex:dotted-length ls)))
(cond ((< length-left n) (assertion-violation 'dotted-butlast "List too short" ls n))
((= length-left n) '())
(else
(cons (car ls)
(recurse (cdr ls)
(- length-left 1)))))))
(define (ex:dotted-last ls n)
(let recurse ((ls ls)
(length-left (ex:dotted-length ls)))
(cond ((< length-left n) (assertion-violation 'dotted-last "List too short" ls n))
((= length-left n) ls)
(else
(recurse (cdr ls)
(- length-left 1))))))
(define (ex:map-while f lst k)
(cond ((null? lst) (k '() '()))
((pair? lst)
(let ((head (f (car lst))))
(if head
(ex:map-while f
(cdr lst)
(lambda (answer rest)
(k (cons head answer)
rest)))
(k '() lst))))
(else (k '() lst))))
(define (ex:check-set? ls = fail)
(or (null? ls)
(if (memp (lambda (x)
(= x (car ls)))
(cdr ls))
(fail (car ls))
(ex:check-set? (cdr ls) = fail))))
(define (ex:unionv . sets)
(cond ((null? sets) '())
((null? (car sets))
(apply ex:unionv (cdr sets)))
(else
(let ((rest (apply ex:unionv
(cdr (car sets))
(cdr sets))))
(if (memv (car (car sets)) rest)
rest
(cons (car (car sets)) rest))))))
(define (ex:amputate-tail list tail)
(cond ((null? list) '())
((eq? list tail) '())
(else
(cons (car list)
(ex:amputate-tail (cdr list) tail)))))
(define (ex:list->string e separator)
(define (tostring x)
(cond ((symbol? x)
(symbol->string x))
((number? x)
(number->string x))
(else
(assertion-violation 'ex:list->string "Invalid argument" e))))
(if (null? e)
""
(string-append
(tostring (car e))
(apply string-append
(map (lambda (x)
(string-append separator (tostring x)))
(cdr e))))))
(define (ex:compose f g)
(lambda (x) (f (g x))))
(define (ex:check x p? from)
(or (p? x)
(ex:syntax-violation from "Invalid argument" x)))
(define (ex:invalid-form exp)
(ex:syntax-violation #f "Invalid form" exp))
(define ex:syntax-error (ex:make-expander ex:invalid-form))
(define ex:unspecified
(let ((x (if #f #f)))
(lambda () x)))
(define (ex:repl exps)
(for-each (lambda (exp)
(for-each (lambda (exp)
(for-each (lambda (result)
(display result)
(newline))
(call-with-values
(lambda ()
(eval exp))
list)))
(ex:expand-toplevel-sequence (list exp))))
exps))
(define (ex:reset-toplevel!)
(ex:*trace* '())
(ex:*current-library* '())
(ex:*phase* 0)
(ex:*used* (list '()))
(ex:*color* (ex:generate-color))
(ex:*usage-env* (ex:*toplevel-env*)))
(define (ex:expand-toplevel-sequence forms)
(ex:reset-toplevel!)
(ex:scan-sequence 'toplevel
ex:make-toplevel-mapping
(ex:source->syntax forms)
(lambda (forms syntax-definitions bound-variables)
(ex:emit-body forms 'define))))
(define (ex:expand-file filename target-filename . dependencies)
(for-each load dependencies)
(ex:write-file (ex:expand-toplevel-sequence (ex:normalize (ex:read-file filename)))
target-filename))
(define (ex:normalize exps)
(define (error)
(let ((newline (string #\newline)))
(ex:syntax-violation
'expand-file
(string-append
"File should be of the form:" newline
" <library>*" newline
" | <library>* <toplevel program>")
exps)))
(let loop ((exps exps)
(normalized '()))
(if (null? exps)
(reverse normalized)
(if (pair? (car exps))
(case (caar exps)
((library)
(loop (cdr exps)
(cons (car exps) normalized)))
((import)
(loop '()
(cons (cons 'program exps)
normalized)))
(else (error)))
(error)))))
(define ex:read-file
(lambda (fn)
(let ((p (open-input-file fn)))
(let f ((x (read p)))
(if (eof-object? x)
(begin (close-input-port p) '())
(cons x
(f (read p))))))))
(define ex:write-file
(lambda (exps fn)
(if (file-exists? fn)
(delete-file fn))
(let ((p (open-output-file fn)))
(for-each (lambda (exp)
(write exp p)
(newline p)
(newline p))
exps)
(close-output-port p))))
(define ex:toplevel-template
(ex:make-identifier 'toplevel-template
'()
'()
0
#f))
(define (ex:source->syntax datum)
(ex:datum->syntax ex:toplevel-template datum))
(define ex:*toplevel-env* (make-parameter (ex:make-unit-env)))
(define ex:*usage-env* (make-parameter (ex:*toplevel-env*)))
(define ex:library-language
(map (lambda (x)
(cons (car x) (ex:make-binding 'macro (car x) '(0) (cdr x) '())))
`((program . ,ex:syntax-error)
(library . ,ex:syntax-error)
(export . ,ex:syntax-error)
(import . ,ex:syntax-error)
(for . ,ex:syntax-error)
(run . ,ex:syntax-error)
(expand . ,ex:syntax-error)
(meta . ,ex:syntax-error)
(only . ,ex:syntax-error)
(except . ,ex:syntax-error)
(prefix . ,ex:syntax-error)
(rename . ,ex:syntax-error)
(primitives . ,ex:syntax-error)
(>= . ,ex:syntax-error)
(<= . ,ex:syntax-error)
(and . ,ex:syntax-error)
(or . ,ex:syntax-error)
(not . ,ex:syntax-error)
(>= . ,ex:syntax-error))))
(define ex:primitive-macros
`((lambda . ,(ex:make-expander ex:expand-lambda))
(if . ,(ex:make-expander ex:expand-if))
(set! . ,(ex:make-expander ex:expand-set!))
(begin . ,(ex:make-expander ex:expand-begin))
(syntax . ,(ex:make-expander ex:expand-syntax))
(quote . ,(ex:make-expander ex:expand-quote))
(let-syntax . ,(ex:make-expander ex:expand-local-syntax))
(letrec-syntax . ,(ex:make-expander ex:expand-local-syntax))
(syntax-case . ,(ex:make-expander ex:expand-syntax-case))
(and . ,(ex:make-expander ex:expand-and))
(or . ,(ex:make-expander ex:expand-or))
(define . ,ex:syntax-error)
(define-syntax . ,ex:syntax-error)
(_ . ,ex:syntax-error)
(... . ,ex:syntax-error)))
(ex:env-import! ex:toplevel-template ex:library-language (ex:*toplevel-env*))
(set! $ex:make-variable-transformer ex:make-variable-transformer)
(set! $ex:identifier? ex:identifier?)
(set! $ex:bound-identifier=? ex:bound-identifier=?)
(set! $ex:free-identifier=? ex:free-identifier=?)
(set! $ex:generate-temporaries ex:generate-temporaries)
(set! $ex:datum->syntax ex:datum->syntax)
(set! $ex:syntax->datum ex:syntax->datum)
(set! $ex:environment ex:environment)
(set! $ex:environment-bindings ex:environment-bindings)
(set! $ex:eval ex:eval)
(set! $ex:syntax-violation ex:syntax-violation)
(set! $ex:expand-file ex:expand-file)
(set! $ex:repl ex:repl)
(set! $ex:invalid-form ex:invalid-form)
(set! $ex:register-macro! ex:register-macro!)
(set! $ex:extend-table-of-envs! ex:extend-table-of-envs!)
(set! $ex:import-libraries ex:import-libraries)
(set! $ex:syntax-rename ex:syntax-rename)
(set! $ex:map-while ex:map-while)
(set! $ex:dotted-length ex:dotted-length)
(set! $ex:dotted-butlast ex:dotted-butlast)
(set! $ex:dotted-last ex:dotted-last)
(set! $ex:unspecified ex:unspecified)
)
(define ~core.primitive-macros~envs '())
(define ~core.primitive-macros~exports
(map (lambda (name)
(cons name (ex:make-binding 'macro name '(0) #f '())))
(map car ex:primitive-macros)))
(define ~core.primitive-macros~imports '())
(define ~core.primitive-macros~visit
(lambda ()
(for-each (lambda (mapping)
(ex:register-macro! (car mapping) (cdr mapping)))
ex:primitive-macros)))
(define ~core.primitive-macros~invoke
(lambda () ($ex:unspecified)))