conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* working on librarifying syntax.ss

This commit is contained in:
Abdulaziz Ghuloum 2007-04-30 04:51:37 -04:00
parent 2fe1943872
commit bee4776036
6 changed files with 1987 additions and 1575 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

11
src/libcompile.ss
View File

@ -1293,6 +1293,7 @@
(make-bind lhs* rhs* (mk-mvcall body c))]
[else (error 'mk-mvcall "invalid producer ~s" (unparse p))]))
(define (copy-propagate x)
(define who 'copy-propagate)
(define the-void (make-primcall 'void '()))
@ -5293,6 +5294,16 @@
(lambda (x)
((current-eval) x)))
(primitive-set! 'compile-time-core-eval
(make-parameter
(lambda (x)
(parameterize ([current-expand (lambda (x) x)])
(compile-expr x)))
(lambda (f)
(unless (procedure? f)
(error 'compile-time-core-eval "~s is not a procedure" f))
f)))
)

7
src/libtoplevel.ss
View File

@ -88,6 +88,8 @@
string->number exact->inexact
flonum? flonum->string string->flonum
sin cos atan sqrt
chi-top-library
compile-time-core-eval
))
(define (system-primitives)
@ -231,7 +233,10 @@
(load script)
(exit 0)]
[else
(printf "Ikarus Scheme (Build ~a)\n" "NO TIME STRING")
(let ()
(define-syntax compile-time-string
(lambda (x) (date-string)))
(printf "Ikarus Scheme (Build ~a)\n" (compile-time-string)))
;(printf "Ikarus Scheme (Build ~a)\n" (compile-time-date-string))
(display "Copyright (c) 2006-2007 Abdulaziz Ghuloum\n\n")
(command-line-arguments args)

4
src/makefile.ss
View File

@ -100,6 +100,8 @@
flonum? flonum->string string->flonum
sin cos atan sqrt
chi-top-library compile-time-core-eval
))
(define system-primitives
@ -228,7 +230,7 @@
(whack-system-env #t)
(define scheme-library-files
'( ["libhandlers.ss" "libhandlers.fasl" p0 onepass]
'(["libhandlers.ss" "libhandlers.fasl" p0 onepass]
["libcontrol.ss" "libcontrol.fasl" p0 onepass]
["libcollect.ss" "libcollect.fasl" p0 onepass]
["librecord.ss" "librecord.fasl" p0 onepass]

13
src/psyntax-7.1.ss
View File

@ -586,6 +586,10 @@
(lambda (x)
(eval `(,noexpand ,x))))
(define compile-time-eval-hook
(lambda (x)
(eval `(,noexpand ,x))))
(define define-top-level-value-hook
(lambda (sym val)
(top-level-eval-hook
@ -2050,9 +2054,11 @@
(else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
(loop bs))))))))))))
(include "syntax.ss")
(define chi-top-library
(let ()
(include "syntax.ss")
(primitive-set! 'chi-top-library library-expander)
library-expander))
(define id-set-diff
(lambda (exports defs)
@ -3079,6 +3085,7 @@
))
;;; core transformers
(global-extend 'local-syntax 'letrec-syntax #t)

491
src/syntax.ss
View File

@ -1,37 +1,19 @@
(define chi-top-library
(let ()
;(define my-map
; (lambda (ctxt f ls . ls*)
; (cond
; [(and (list? ls)
; (andmap list? ls*)
; (let ([n (length ls)])
; (andmap (lambda (ls) (= (length ls) n)) ls*)))
; (let loop ([ls ls] [ls* ls*])
; (cond
; [(null? ls) '()]
; [else
; (cons (apply f (car ls) (#%map car ls*))
; (loop (cdr ls) (#%map cdr ls*)))]))]
; [else (error ctxt "invalid args ~s" (cons ls ls*))])))
;(define-syntax map
; (syntax-rules ()
; [(_ f ls ls* ...)
; (my-map '(map f ls ls* ...) f ls ls* ...)]))
(define-syntax build-let
(syntax-rules ()
[(_ ae lhs* rhs* body)
(build-application ae
(build-lambda ae lhs* body)
rhs*)]))
(define who 'chi-top-library)
(define-syntax build-let
(lambda (x)
(syntax-case x ()
[(_ ae lhs* rhs* body)
#'(build-application ae
(build-lambda ae lhs* body)
rhs*)])))
(define-syntax assert
(syntax-rules ()
(lambda (x)
(syntax-case x ()
[(_ name pred* ...)
(unless (and pred* ...)
(error 'name "assertion ~s failed" '(pred* ...)))]))
#'(unless (and pred* ...)
(error 'name "assertion ~s failed" '(pred* ...)))])))
(define top-mark* '(top))
(define top-marked?
(lambda (m*) (memq 'top m*)))
@ -47,7 +29,7 @@
(define make-rib
(lambda (sym* mark** label*)
(vector 'rib sym* mark** label*)))
(define id/label-rib
(define make-full-rib
(lambda (id* label*)
(make-rib (map id->sym id*) (map stx-mark* id*) label*)))
(define make-empty-rib
@ -149,6 +131,8 @@
(p? x))))
(define syntax-pair?
(lambda (x) (syntax-kind? x pair?)))
(define syntax-vector?
(lambda (x) (syntax-kind? x vector?)))
(define syntax-null?
(lambda (x) (syntax-kind? x null?)))
(define syntax-list?
@ -218,6 +202,15 @@
(define self-evaluating?
(lambda (x)
(or (number? x) (string? x) (char? x) (boolean? x))))
(define stx->datum
(lambda (x)
(strip x '())))
(define extend-env
(lambda (lab b r)
(cons (cons lab b) r)))
(define extend-env*
(lambda (lab* b* r)
(append (map cons lab* b*) r)))
(define strip
(lambda (x m*)
(if (top-marked? m*)
@ -311,12 +304,10 @@
(error who "malformed library ~s" e))]
[_ (error who "malformed library ~s" e)])))
(define-syntax stx-error
(syntax-rules ()
[(_ stx) (error 'chi "invalid syntax ~s" (strip stx '()))]
[(_ stx msg) (error 'chi "~a: ~s" msg (strip stx '()))]))
;(define stx-error
; (lambda (stx . args)
; (error 'chi "invalid syntax ~s" (strip stx '()))))
(lambda (x)
(syntax-case x ()
[(_ stx) #'(error 'chi "invalid syntax ~s" (strip stx '()))]
[(_ stx msg) #'(error 'chi "~a: ~s" msg (strip stx '()))])))
(define sanitize-binding
(lambda (x)
(cond
@ -327,7 +318,7 @@
[else (error 'expand "invalid transformer ~s" x)])))
(define make-eval-transformer
(lambda (x)
(sanitize-binding (local-eval-hook x))))
(sanitize-binding (compile-time-eval-hook x))))
(define-syntax syntax-match-test
(lambda (stx)
(define dots?
@ -511,9 +502,13 @@
[begin begin-label (begin)]
[set! set!-label (set!)]
[define-record define-record-label (macro . define-record)]
[include include-label (macro . include)]
[with-syntax with-syntax-label (macro . with-syntax)]
[case case-label (core-macro . case)]
[foreign-call foreign-call-label (core-macro . foreign-call)]
[quote quote-label (core-macro . quote)]
[syntax-case syntax-case-label (core-macro . syntax-case)]
[syntax syntax-label (core-macro . syntax)]
[lambda lambda-label (core-macro . lambda)]
[case-lambda case-lambda-label (core-macro . case-lambda)]
[let-values let-values-label (core-macro . let-values)]
@ -794,6 +789,10 @@
[$make-record $make-record-label (core-prim . $make-record)]
[$record? $record?-label (core-prim . $record?)]
[$record/rtd? $record/rtd?-label (core-prim . $record/rtd?)]
;;; syntax-case
[identifier? identifier?-label (core-prim . identifier?)]
[generate-temporaries generate-temporaries-label (core-prim . generate-temporaries)]
[free-identifier=? free-identifier=?-label (core-prim . free-identifier=?)]
;;; codes
[$closure-code $closure-code-label (core-prim . $closure-code)]
[$code? $code?-label (core-prim . $code?)]
@ -875,7 +874,7 @@
[(null? lex**)
(chi-internal
(add-subst
(id/label-rib fml* lab*)
(make-full-rib fml* lab*)
(cons b b*))
(add-lexicals lab* lex* r)
mr)]
@ -897,14 +896,14 @@
[(null? lhs*)
(chi-internal
(add-subst
(id/label-rib subst-lhs* subst-lab*)
(make-full-rib subst-lhs* subst-lab*)
(cons b b*))
r mr)]
[else
(let ([lhs (car lhs*)]
[rhs (chi-expr
(add-subst
(id/label-rib subst-lhs* subst-lab*)
(make-full-rib subst-lhs* subst-lab*)
(car rhs*))
r mr)])
(unless (id? lhs)
@ -924,7 +923,7 @@
(stx-error e)
(let ([lex* (map gen-lexical lhs*)]
[lab* (map gen-label lhs*)])
(let ([rib (id/label-rib lhs* lab*)]
(let ([rib (make-full-rib lhs* lab*)]
[r (add-lexicals lab* lex* r)])
(let ([body (chi-internal
(add-subst rib (cons b b*))
@ -947,7 +946,7 @@
[lab* (map gen-label lhs*)])
(let ([body (chi-internal
(add-subst
(id/label-rib lhs* lab*)
(make-full-rib lhs* lab*)
(cons b b*))
(add-lexicals lab* lex* r)
mr)])
@ -961,8 +960,8 @@
[lab* (map gen-label lhs*)]
[looplex (gen-lexical loop)]
[looplab (gen-label loop)])
(let ([b* (add-subst (id/label-rib (list loop) (list looplab))
(add-subst (id/label-rib lhs* lab*)
(let ([b* (add-subst (make-full-rib (list loop) (list looplab))
(add-subst (make-full-rib lhs* lab*)
(cons b b*)))]
[r (add-lexicals
(cons looplab lab*)
@ -1125,6 +1124,28 @@
[(symbol? x)
(make-stx x top-mark* (list rib))]
[else x])))))
(define with-syntax-macro
(lambda (e)
(syntax-match e
[(_ ([fml* expr*] ...) b b* ...)
(bless
`(syntax-case (list . ,expr*) ()
[,fml* (begin ,b . ,b*)]))])))
(define include-macro
(lambda (e)
(syntax-match e
[(id filename)
(let ([filename (stx->datum filename)])
(unless (string? filename) (stx-error e))
(with-input-from-file filename
(lambda ()
(let f ([ls '()])
(let ([x (read)])
(cond
[(eof-object? x)
(cons (bless 'begin)
(datum->stx id (reverse ls)))]
[else (f (cons x ls))]))))))])))
(define define-record-macro
(lambda (e)
(define enumerate
@ -1252,6 +1273,357 @@
(build-foreign-call no-source
(chi-expr name r mr)
(chi-expr* arg* r mr))])))
;; p in pattern: matches:
;; () empty list
;; _ anything (no binding created)
;; any anything
;; (p1 . p2) pair
;; #(free-id <key>) <key> with free-identifier=?
;; each-any any proper list
;; #(each p) (p*)
;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
;; #(vector p) #(x ...) if p matches (x ...)
;; #(atom <object>) <object> with "equal?"
(define convert-pattern
; returns syntax-dispatch pattern & ids
(lambda (pattern keys)
(define cvt*
(lambda (p* n ids)
(if (null? p*)
(values '() ids)
(let-values (((y ids) (cvt* (cdr p*) n ids)))
(let-values (((x ids) (cvt (car p*) n ids)))
(values (cons x y) ids))))))
(define id-dots?
(lambda (x)
(and (syntax-pair? x)
(let ([d (syntax-cdr x)])
(and (syntax-pair? d)
(syntax-null? (syntax-cdr d))
(ellipsis? (syntax-car d)))))))
(define id-dots-id
(lambda (x) (syntax-car x)))
(define syntax-foo?
(lambda (x)
(and (syntax-pair? x)
(let ((d (syntax-cdr x)))
(and (syntax-pair? d)
(ellipsis? (syntax-car d)))))))
(define syntax-foo-z
(lambda (x)
(let f ([x (syntax-cdr (syntax-cdr x))])
(cond
((syntax-pair? x) (f (syntax-cdr x)))
(else x)))))
(define syntax-foo-ys
(lambda (x)
(let f ([x (syntax-cdr (syntax-cdr x))])
(cond
[(syntax-pair? x)
(cons (syntax-car x) (f (syntax-cdr x)))]
[else '()]))))
(define syntax-foo-x
(lambda (x) (syntax-car x)))
(define cvt
(lambda (p n ids)
(cond
[(not (id? p))
(cond
[(id-dots? p)
(let-values ([(p ids) (cvt (id-dots-id p) (+ n 1) ids)])
(values
(if (eq? p 'any) 'each-any (vector 'each p))
ids))]
[(syntax-foo? p) ; (x dots y ... . z)
(let-values ([(z ids) (cvt (syntax-foo-z p) n ids)])
(let-values ([(y ids) (cvt* (syntax-foo-ys p) n ids)])
(let-values ([(x ids) (cvt (syntax-foo-x p) (+ n 1) ids)])
(values (vector 'each+ x (reverse y) z) ids))))]
[(syntax-pair? p)
(let-values ([(y ids) (cvt (syntax-cdr p) n ids)])
(let-values ([(x ids) (cvt (syntax-car p) n ids)])
(values (cons x y) ids)))]
[(syntax-null? p) (values '() ids)]
[(syntax-vector? p)
(let-values ([(p ids) (cvt (syntax-vector->list p) n ids)])
(values (vector 'vector p) ids))]
[else (values (vector 'atom (strip p '())) ids)])]
[(bound-id-member? p keys)
(values (vector 'free-id p) ids)]
[(free-id=? p (sym->free-id '_))
(values '_ ids)]
[else (values 'any (cons (cons p n) ids))])))
(cvt pattern 0 '())))
(define ellipsis?
(lambda (x)
(and (id? x) (free-id=? x (sym->free-id '...)))))
(define syntax-case-transformer
(let ()
(define build-dispatch-call
(lambda (pvars expr y r mr)
(let ([ids (map car pvars)]
[levels (map cdr pvars)])
(let ([labels (map gen-label ids)]
[new-vars (map gen-lexical ids)])
(let ([body
(chi-expr
(add-subst (make-full-rib ids labels) expr)
(extend-env*
labels
(map (lambda (var level)
(make-binding 'syntax (cons var level)))
new-vars
(map cdr pvars))
r)
mr)])
(build-application no-source
(build-primref no-source 'apply)
(list (build-lambda no-source new-vars body) y)))))))
(define gen-clause
(lambda (x keys clauses r mr pat fender expr)
(let-values (((p pvars) (convert-pattern pat keys)))
(cond
((not (distinct-bound-ids? (map car pvars)))
(invalid-ids-error (map car pvars) pat "pattern variable"))
((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
(stx-error pat "3misplaced ellipsis in syntax-case pattern"))
(else
(let ((y (gen-lexical 'tmp)))
(let ([test
(cond
[(eq? fender #t) y]
[else
(let ([call
(build-dispatch-call
pvars fender y r mr)])
(build-conditional no-source
(build-lexical-reference no-source y)
call
(build-data no-source #f)))])])
(let ([conseq
(build-dispatch-call pvars expr
(build-lexical-reference no-source y)
r mr)])
(let ([altern
(gen-syntax-case x keys clauses r mr)])
(build-application no-source
(build-lambda no-source (list y)
(build-conditional no-source test conseq altern))
(list
(build-application no-source
(build-primref no-source '$syntax-dispatch)
(list
(build-lexical-reference no-source x)
(build-data no-source p))))))))))))))
(define gen-syntax-case
(lambda (x keys clauses r mr)
(if (null? clauses)
(build-application no-source
(build-primref no-source 'syntax-error)
(list (build-lexical-reference no-source x)))
(syntax-match (car clauses)
[(pat expr)
(if (and (id? pat)
(not (bound-id-member? pat keys))
(not (ellipsis? pat)))
(if (free-id=? pat (sym->free-id '_))
(chi-expr expr r mr)
(let ([lab (gen-label pat)]
[lex (gen-lexical pat)])
(let ([body
(chi-expr
(add-subst
(make-full-rib (list pat) (list lab))
expr)
(extend-env lab
(make-binding 'syntax (cons lex 0))
r)
mr)])
(build-application no-source
(build-lambda no-source (list lex) body)
(list (build-lexical-reference no-source x))))))
(gen-clause x keys (cdr clauses) r mr pat #t expr))]
[(pat fender expr)
(gen-clause x keys (cdr clauses) r mr pat fender expr)]))))
(lambda (e r mr)
(syntax-match e
[(_ expr (keys ...) clauses ...)
(unless (andmap (lambda (x) (and (id? x) (not (ellipsis? x)))) keys)
(stx-error e))
(let ((x (gen-lexical 'tmp)))
(let ([body (gen-syntax-case x keys clauses r mr)])
(build-application no-source
(build-lambda no-source (list x) body)
(list (chi-expr expr r mr)))))]))))
(define syntax-transformer
(let ()
(define match2
(lambda (e f? sk fk)
(if (syntax-list? e)
(let ((e (syntax->list e)))
(if (= (length e) 2)
(let ((e0 (car e)) (e1 (cadr e)))
(if (or (eq? f? #t) (f? e0 e1))
(sk e0 e1)
(fk)))
(fk)))
(fk))))
(define gen-syntax
(lambda (src e r maps ellipsis? vec?)
(if (id? e)
(let ((label (id->label e)))
(let ((b (label->binding label r)))
(if (eq? (binding-type b) 'syntax)
(let-values (((var maps)
(let ((var.lev (binding-value b)))
(gen-ref src (car var.lev) (cdr var.lev) maps))))
(values (list 'ref var) maps))
(if (ellipsis? e)
(syntax-error src "1misplaced ellipsis in syntax form")
(begin
(values (list 'quote e) maps))))))
(match2 e (lambda (dots e) (ellipsis? dots))
(lambda (dots e)
(if vec?
(syntax-error src "2misplaced ellipsis in syntax form")
(gen-syntax src e r maps (lambda (x) #f) #f)))
(lambda ()
(cond
((and (syntax-pair? e) ;(x dots . y)
(let ((t (syntax-cdr e)))
(and (syntax-pair? t)
(ellipsis? (syntax-car t)))))
(let f ((y (syntax-cdr (syntax-cdr e)))
(k (lambda (maps)
(let-values (((x maps)
(gen-syntax src (syntax-car e) r
(cons '() maps) ellipsis? #f)))
(if (null? (car maps))
(syntax-error src
"extra ellipsis in syntax form")
(values (gen-map x (car maps)) (cdr maps)))))))
(cond
((syntax-null? y) (k maps))
((and (syntax-pair? y) (ellipsis? (syntax-car y)))
; (dots . y)
(f (syntax-cdr y)
(lambda (maps)
(let-values (((x maps) (k (cons '() maps))))
(if (null? (car maps))
(syntax-error src "extra ellipsis in syntax form")
(values (gen-mappend x (car maps)) (cdr maps)))))))
(else
(let-values (((y maps)
(gen-syntax src y r maps ellipsis? vec?)))
(let-values (((x maps) (k maps)))
(values (gen-append x y) maps)))))))
((syntax-pair? e) ;(x . y)
(let-values (((xnew maps)
(gen-syntax src (syntax-car e) r
maps ellipsis? #f)))
(let-values (((ynew maps)
(gen-syntax src (syntax-cdr e) r
maps ellipsis? vec?)))
(values (gen-cons e (syntax-car e) (syntax-cdr e) xnew ynew)
maps))))
((syntax-vector? e) ;#(x1 x2 ...)
(let ((ls (syntax-vector->list e)))
(let-values (((lsnew maps)
(gen-syntax src ls r maps ellipsis? #t)))
(values (gen-vector e ls lsnew) maps))))
((and (syntax-null? e) vec?) (values '(quote ()) maps))
(else (values `(quote ,e) maps))))))))
(define gen-ref
(lambda (src var level maps)
(if (= level 0)
(values var maps)
(if (null? maps)
(syntax-error src "missing ellipsis in syntax form")
(let-values (((outer-var outer-maps)
(gen-ref src var (- level 1) (cdr maps))))
(cond
((assq outer-var (car maps)) =>
(lambda (b) (values (cdr b) maps)))
(else
(let ((inner-var (gen-var 'tmp)))
(values
inner-var
(cons
(cons (cons outer-var inner-var) (car maps))
outer-maps))))))))))
(define gen-append
(lambda (x y)
(if (equal? y '(quote ())) x (list 'append x y))))
(define gen-mappend
(lambda (e map-env)
(list 'apply '(primitive append) (gen-map e map-env))))
(define gen-map
(lambda (e map-env)
(let ((formals (map cdr map-env))
(actuals (map (lambda (x) (list 'ref (car x))) map-env)))
(cond
; identity map equivalence:
; (map (lambda (x) x) y) == y
((eq? (car e) 'ref)
(car actuals))
; eta map equivalence:
; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
((andmap
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e))
(list* 'map (list 'primitive (car e))
(map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))))
(else (list* 'map (list 'lambda formals e) actuals))))))
(define gen-cons
(lambda (e x y xnew ynew)
(case (car ynew)
((quote)
(if (eq? (car xnew) 'quote)
(let ((xnew (cadr xnew)) (ynew (cadr ynew)))
(if (and (eq? xnew x) (eq? ynew y))
(list 'quote e)
(list 'quote (cons xnew ynew))))
(if (eq? (cadr ynew) '())
(list 'list xnew)
(list 'cons xnew ynew))))
((list) (list* 'list xnew (cdr ynew)))
(else (list 'cons xnew ynew)))))
(define gen-vector
(lambda (e ls lsnew)
(cond
((eq? (car lsnew) 'quote)
(if (eq? (cadr lsnew) ls)
(list 'quote e)
(list 'quote (list->vector (cadr lsnew)))))
;`(quote #(,@(cadr lsnew)))))
((eq? (car lsnew) 'list)
(cons 'vector (cdr lsnew)))
(else (list 'list->vector lsnew)))))
(define regen
(lambda (x)
(case (car x)
((ref) (build-lexical-reference no-source (cadr x)))
((primitive) (build-primref no-source (cadr x)))
((quote) (build-data no-source (cadr x)))
((lambda) (build-lambda no-source (cadr x) (regen (caddr x))))
((map)
(let ((ls (map regen (cdr x))))
(build-application no-source
(build-primref no-source 'map)
ls)))
(else
(build-application no-source
(build-primref no-source (car x))
(map regen (cdr x)))))))
(lambda (e r mr)
(match2 e #t
(lambda (_ x)
(let-values (((e maps) (gen-syntax e x r '() ellipsis? #f)))
(regen e)))
(lambda () (syntax-error e))))))
(define core-macro-transformer
(lambda (name)
(case name
@ -1271,6 +1643,8 @@
[(or) or-transformer]
[(parameterize) parameterize-transformer]
[(foreign-call) foreign-call-transformer]
[(syntax-case) syntax-case-transformer]
[(syntax) syntax-transformer]
[else (error 'macro-transformer "cannot find ~s" name)])))
(define macro-transformer
(lambda (x)
@ -1279,6 +1653,8 @@
[(symbol? x)
(case x
[(define-record) define-record-macro]
[(include) include-macro]
[(with-syntax) with-syntax-macro]
[else (error 'macro-transformer
"invalid macro ~s" x)])]
[else (error 'core-macro-transformer
@ -1354,7 +1730,7 @@
lex*
(chi-internal
(add-subst
(id/label-rib x* lab*)
(make-full-rib x* lab*)
body*)
(add-lexicals lab* lex* r)
mr)))
@ -1369,7 +1745,7 @@
(append lex* lex)
(chi-internal
(add-subst
(id/label-rib (cons x x*) (cons lab lab*))
(make-full-rib (cons x x*) (cons lab lab*))
body*)
(add-lexicals (cons lab lab*)
(cons lex lex*)
@ -1452,6 +1828,22 @@
(cons lex lex*)
(cons rhs rhs*)
kwd*)))]
[(define-syntax)
(let-values ([(id rhs) (parse-define-syntax e)])
(when (bound-id-member? id kwd*)
(syntax-error id "undefined identifier"))
(let ([lab (gen-label id)])
(let ([expanded-rhs (chi-expr rhs mr mr)])
(extend-rib! rib id lab)
(let ([b (make-eval-transformer expanded-rhs)])
(f (cdr e*)
module-init**
(cons (cons lab b) r)
(cons (cons lab b) mr)
lhs* lex* rhs* kwd*)))))]
[(macro)
(f (cons (add-subst rib (chi-macro value e)) (cdr e*))
module-init** r mr lhs* lex* rhs* kwd*)]
[(module)
(let-values ([(m-lhs* m-lex* m-rhs* m-init* m-exp-id* m-exp-lab* r mr kwd*)
(chi-internal-module e r mr kwd*)])
@ -1574,7 +1966,7 @@
r mr lhs* lex* rhs* kwd*)]
[else
(return e* r mr lhs* lex* rhs*)]))))]))))
(define chi-top-library
(define library-expander
(lambda (e)
(let-values ([(name exp* b*) (parse-library e)])
(let ([rib (make-scheme-rib)]
@ -1591,8 +1983,3 @@
(chi-void)
(build-sequence no-source
(chi-expr* init* r mr))))))))))
(lambda (x)
(let ([x (chi-top-library x)])
; (pretty-print x)
x))
))