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

* before trying libcompile

This commit is contained in:
Abdulaziz Ghuloum 2007-05-01 04:36:53 -04:00
parent 705e8f386b
commit 5ae6f6bc76
5 changed files with 448 additions and 290 deletions

BIN
src/ikarus.boot
View File

Binary file not shown.

36
src/libfasl.ss
View File

@ -70,8 +70,8 @@
(cond (cond
[(pair? x) [(pair? x)
(write-char #\P p) (write-char #\P p)
(fasl-write (cdr x) p h (fasl-write-object (cdr x) p h
(fasl-write (car x) p h m))] (fasl-write-object (car x) p h m))]
[(vector? x) [(vector? x)
(write-char #\V p) (write-char #\V p)
(write-int (vector-length x) p) (write-int (vector-length x) p)
@ -80,7 +80,7 @@
[(fx= i n) m] [(fx= i n) m]
[else [else
(f x (fxadd1 i) n (f x (fxadd1 i) n
(fasl-write (vector-ref x i) p h m))]))] (fasl-write-object (vector-ref x i) p h m))]))]
[(string? x) [(string? x)
(write-char #\S p) (write-char #\S p)
(write-int (string-length x) p) (write-int (string-length x) p)
@ -92,11 +92,11 @@
(f x (fxadd1 i) n)]))] (f x (fxadd1 i) n)]))]
[(gensym? x) [(gensym? x)
(write-char #\G p) (write-char #\G p)
(fasl-write (gensym->unique-string x) p h (fasl-write-object (gensym->unique-string x) p h
(fasl-write (symbol->string x) p h m))] (fasl-write-object (symbol->string x) p h m))]
[(symbol? x) [(symbol? x)
(write-char #\M p) (write-char #\M p)
(fasl-write (symbol->string x) p h m)] (fasl-write-object (symbol->string x) p h m)]
[(code? x) [(code? x)
(write-char #\x p) (write-char #\x p)
(write-int (code-size x) p) (write-int (code-size x) p)
@ -105,7 +105,7 @@
(unless (fx= i n) (unless (fx= i n)
(write-char (integer->char (code-ref x i)) p) (write-char (integer->char (code-ref x i)) p)
(f (fxadd1 i) n))) (f (fxadd1 i) n)))
(fasl-write (code-reloc-vector x) p h m)] (fasl-write-object (code-reloc-vector x) p h m)]
[(record? x) [(record? x)
(let ([rtd (record-type-descriptor x)]) (let ([rtd (record-type-descriptor x)])
(cond (cond
@ -114,33 +114,33 @@
(write-char #\R p) (write-char #\R p)
(let ([names (record-type-field-names x)] (let ([names (record-type-field-names x)]
[m [m
(fasl-write (record-type-symbol x) p h (fasl-write-object (record-type-symbol x) p h
(fasl-write (record-type-name x) p h m))]) (fasl-write-object (record-type-name x) p h m))])
(write-int (length names) p) (write-int (length names) p)
(let f ([names names] [m m]) (let f ([names names] [m m])
(cond (cond
[(null? names) m] [(null? names) m]
[else [else
(f (cdr names) (f (cdr names)
(fasl-write (car names) p h m))])))] (fasl-write-object (car names) p h m))])))]
[else [else
;;; non-rtd record ;;; non-rtd record
(write-char #\{ p) (write-char #\{ p)
(write-int (length (record-type-field-names rtd)) p) (write-int (length (record-type-field-names rtd)) p)
(let f ([names (record-type-field-names rtd)] (let f ([names (record-type-field-names rtd)]
[m (fasl-write rtd p h m)]) [m (fasl-write-object rtd p h m)])
(cond (cond
[(null? names) m] [(null? names) m]
[else [else
(f (cdr names) (f (cdr names)
(fasl-write (fasl-write-object
((record-field-accessor rtd (car names)) x) ((record-field-accessor rtd (car names)) x)
p h m))]))]))] p h m))]))]))]
[(procedure? x) [(procedure? x)
(write-char #\Q p) (write-char #\Q p)
(fasl-write ($closure-code x) p h m)] (fasl-write-object ($closure-code x) p h m)]
[else (error 'fasl-write "~s is not fasl-writable" x)]))) [else (error 'fasl-write "~s is not fasl-writable" x)])))
(define fasl-write (define fasl-write-object
(lambda (x p h m) (lambda (x p h m)
(cond (cond
[(immediate? x) (fasl-write-immediate x p) m] [(immediate? x) (fasl-write-immediate x p) m]
@ -211,7 +211,7 @@
(code-freevars code))) (code-freevars code)))
(make-graph code h))] (make-graph code h))]
[else (error 'fasl-write "~s is not fasl-writable" x)])])))) [else (error 'fasl-write "~s is not fasl-writable" x)])]))))
(define do-fasl-write (define fasl-write-to-port
(lambda (x port) (lambda (x port)
(let ([h (make-hash-table)]) (let ([h (make-hash-table)])
(make-graph x h) (make-graph x h)
@ -221,15 +221,15 @@
(write-char #\K port) (write-char #\K port)
(write-char #\0 port) (write-char #\0 port)
(write-char #\1 port) (write-char #\1 port)
(fasl-write x port h 1) (fasl-write-object x port h 1)
(void)))) (void))))
(primitive-set! 'fasl-write (primitive-set! 'fasl-write
(case-lambda (case-lambda
[(x) (do-fasl-write x (current-output-port))] [(x) (fasl-write-to-port x (current-output-port))]
[(x port) [(x port)
(unless (output-port? port) (unless (output-port? port)
(error 'fasl-write "~s is not an output port" port)) (error 'fasl-write "~s is not an output port" port))
(do-fasl-write x port)]))) (fasl-write-to-port x port)])))

11
src/libintelasm.ss
View File

@ -953,7 +953,8 @@
;;; (make-code-executable! x) ;;; (make-code-executable! x)
;;; x))))) ;;; x)))))
(define list*->code* (let ()
(define list*->code*
(lambda (thunk?-label ls*) (lambda (thunk?-label ls*)
(let ([closure-size* (map car ls*)] (let ([closure-size* (map car ls*)]
[ls* (map cdr ls*)]) [ls* (map cdr ls*)])
@ -974,11 +975,11 @@
(for-each set-code-reloc-vector! code* relv*) (for-each set-code-reloc-vector! code* relv*)
code*))))))) code*)))))))
;(define list->code ;(define list->code
; (lambda (ls) ; (lambda (ls)
; (car (list*->code* (list ls))))) ; (car (list*->code* (list ls)))))
(primitive-set! 'list*->code* list*->code*) (primitive-set! 'list*->code* list*->code*))
) )

315
src/syntax.ss
View File

@ -110,9 +110,6 @@
(let-values ([(m* s*) (join-wraps m* s* e)]) (let-values ([(m* s*) (join-wraps m* s* e)])
(make-stx (stx-expr e) m* s*)) (make-stx (stx-expr e) m* s*))
(make-stx e m* s*)))) (make-stx e m* s*))))
(define sym->free-id
(lambda (x)
(stx x top-mark* '())))
(define add-subst (define add-subst
(lambda (subst e) (lambda (subst e)
(if subst (if subst
@ -129,6 +126,15 @@
(if (stx? x) (if (stx? x)
(syntax-kind? (stx-expr x) p?) (syntax-kind? (stx-expr x) p?)
(p? x)))) (p? x))))
(define syntax-vector->list
(lambda (x)
(cond
[(stx? x)
(let ([ls (syntax-vector->list (stx-expr x))]
[m* (stx-mark* x)] [s* (stx-subst* x)])
(map (lambda (x) (stx x m* s*)) ls))]
[(vector? x) (vector->list x)]
[else (error 'syntax-vector->list "not a syntax vector ~s" x)])))
(define syntax-pair? (define syntax-pair?
(lambda (x) (syntax-kind? x pair?))) (lambda (x) (syntax-kind? x pair?)))
(define syntax-vector? (define syntax-vector?
@ -340,8 +346,9 @@
(define make-eval-transformer (define make-eval-transformer
(lambda (x) (lambda (x)
(sanitize-binding (compile-time-eval-hook x)))) (sanitize-binding (compile-time-eval-hook x))))
(module (syntax-match)
(define-syntax syntax-match-test (define-syntax syntax-match-test
(lambda (stx) (lambda (ctx)
(define dots? (define dots?
(lambda (x) (lambda (x)
(and (identifier? x) (and (identifier? x)
@ -350,15 +357,11 @@
(lambda (x ls) (lambda (x ls)
(and (ormap (lambda (y) (free-identifier=? x y)) ls) #t))) (and (ormap (lambda (y) (free-identifier=? x y)) ls) #t)))
(define f (define f
(lambda (stx lits) (lambda (ctx lits)
(syntax-case stx () (syntax-case ctx ()
[id (identifier? #'id) [id (identifier? #'id)
(if (free-identifier-member? #'id lits) (if (free-identifier-member? #'id lits)
#'(lambda (x) #'(lambda (x) (and (id? x) (free-id=? x (scheme-stx 'id))))
(and (id? x)
(free-id=? x
(add-subst (make-scheme-rib)
(stx 'id top-mark* '())))))
#'(lambda (x) #t))] #'(lambda (x) #t))]
[(pat dots) (dots? #'dots) [(pat dots) (dots? #'dots)
(with-syntax ([p (f #'pat lits)]) (with-syntax ([p (f #'pat lits)])
@ -380,15 +383,20 @@
(and (syntax-pair? x) (and (syntax-pair? x)
(pa (syntax-car x)) (pa (syntax-car x))
(pd (syntax-cdr x)))))] (pd (syntax-cdr x)))))]
[#(pats ...)
(with-syntax ([p (f #'(pats ...) lits)])
#'(lambda (x)
(and (syntax-vector? x)
(p (syntax-vector->list x)))))]
[datum [datum
#'(lambda (x) #'(lambda (x)
(equal? (strip x '()) 'datum))]))) (equal? (strip x '()) 'datum))])))
(syntax-case stx () (syntax-case ctx ()
[(_ x (lits ...) [pat code code* ...]) [(_ x (lits ...) [pat code code* ...])
(with-syntax ([pat-code (f #'pat #'(lits ...))]) (with-syntax ([pat-code (f #'pat #'(lits ...))])
#'(pat-code x))]))) #'(pat-code x))])))
(define-syntax syntax-match-conseq (define-syntax syntax-match-conseq
(lambda (stx) (lambda (ctx)
(define free-identifier-member? (define free-identifier-member?
(lambda (x ls) (lambda (x ls)
(and (ormap (lambda (y) (free-identifier=? x y)) ls) #t))) (and (ormap (lambda (y) (free-identifier=? x y)) ls) #t)))
@ -492,9 +500,18 @@
(let-values ([(avars ...) (a (syntax-car x))]) (let-values ([(avars ...) (a (syntax-car x))])
(let-values ([(dvars ...) (d (syntax-cdr x))]) (let-values ([(dvars ...) (d (syntax-cdr x))])
(values avars ... dvars ...))))))])))] (values avars ... dvars ...))))))])))]
[#(pats ...)
(let-values ([(vars extractor) (f #'(pats ...) lits)])
(cond
[(null? vars) (values '() #f)]
[else
(values vars
(with-syntax ([extractor extractor])
#'(lambda (x)
(extractor (syntax-vector->list x)))))]))]
[datum [datum
(values '() #'(lambda (x) (dot-call-me)))]))) (values '() #'(lambda (x) (dot-call-me)))])))
(syntax-case stx () (syntax-case ctx ()
[(_ x (lits ...) [pat code code* ...]) [(_ x (lits ...) [pat code code* ...])
(let-values ([(vars extractor) (let-values ([(vars extractor)
(f #'pat #'(lits ...))]) (f #'pat #'(lits ...))])
@ -511,7 +528,7 @@
#'(let ([t expr]) #'(let ([t expr])
(if (syntax-match-test t (lits ...) cls) (if (syntax-match-test t (lits ...) cls)
(syntax-match-conseq t (lits ...) cls) (syntax-match-conseq t (lits ...) cls)
(syntax-match t (lits ...) cls* ...)))]))) (syntax-match t (lits ...) cls* ...)))]))))
(define parse-define (define parse-define
(lambda (x) (lambda (x)
(syntax-match x () (syntax-match x ()
@ -531,6 +548,16 @@
(if (id? id) (if (id? id)
(values id val) (values id val)
(stx-error x))]))) (stx-error x))])))
(define scheme-stx
(lambda (sym)
(cond
[(assq sym scheme-env) =>
(lambda (x)
(let ([name (car x)] [label (cadr x)])
(add-subst
(make-rib (list name) (list top-mark*) (list label))
(stx sym top-mark* '()))))]
[else (stx sym top-mark* '())])))
(define scheme-env ; the-env (define scheme-env ; the-env
'([define define-label (define)] '([define define-label (define)]
[define-syntax define-syntax-label (define-syntax)] [define-syntax define-syntax-label (define-syntax)]
@ -540,6 +567,7 @@
[define-record define-record-label (macro . define-record)] [define-record define-record-label (macro . define-record)]
[include include-label (macro . include)] [include include-label (macro . include)]
[syntax-rules syntax-rules-macro (macro . syntax-rules)] [syntax-rules syntax-rules-macro (macro . syntax-rules)]
[quasiquote quasiquote-macro (macro . quasiquote)]
[with-syntax with-syntax-label (macro . with-syntax)] [with-syntax with-syntax-label (macro . with-syntax)]
[case case-label (core-macro . case)] [case case-label (core-macro . case)]
[foreign-call foreign-call-label (core-macro . foreign-call)] [foreign-call foreign-call-label (core-macro . foreign-call)]
@ -550,9 +578,10 @@
[case-lambda case-lambda-label (core-macro . case-lambda)] [case-lambda case-lambda-label (core-macro . case-lambda)]
[let-values let-values-label (core-macro . let-values)] [let-values let-values-label (core-macro . let-values)]
[let let-label (core-macro . let)] [let let-label (core-macro . let)]
[type-descriptor type-descriptor-label (core-macro . type-descriptor)]
[letrec letrec-label (core-macro . letrec)] [letrec letrec-label (core-macro . letrec)]
[let* let*-label (core-macro . let*)] [let* let*-label (core-macro . let*)]
[cond cond-label (core-macro . cond)] [cond cond-label (macro . cond)]
[if if-label (core-macro . if)] [if if-label (core-macro . if)]
[when when-label (core-macro . when)] [when when-label (core-macro . when)]
[unless unless-label (core-macro . unless)] [unless unless-label (core-macro . unless)]
@ -590,6 +619,22 @@
[cdadr cdadr-label (core-prim . cdadr)] [cdadr cdadr-label (core-prim . cdadr)]
[caddr caddr-label (core-prim . caddr)] [caddr caddr-label (core-prim . caddr)]
[cdddr cdddr-label (core-prim . cdddr)] [cdddr cdddr-label (core-prim . cdddr)]
[caaaar caaaar-label (core-prim . caaaar)]
[cdaaar cdaaar-label (core-prim . cdaaar)]
[cadaar cadaar-label (core-prim . cadaar)]
[cddaar cddaar-label (core-prim . cddaar)]
[caadar caadar-label (core-prim . caadar)]
[cdadar cdadar-label (core-prim . cdadar)]
[caddar caddar-label (core-prim . caddar)]
[cdddar cdddar-label (core-prim . cdddar)]
[caaadr caaadr-label (core-prim . caaadr)]
[cdaadr cdaadr-label (core-prim . cdaadr)]
[cadadr cadadr-label (core-prim . cadadr)]
[cddadr cddadr-label (core-prim . cddadr)]
[caaddr caaddr-label (core-prim . caaddr)]
[cdaddr cdaddr-label (core-prim . cdaddr)]
[cadddr cadddr-label (core-prim . cadddr)]
[cddddr cddddr-label (core-prim . cddddr)]
[list list-label (core-prim . list)] [list list-label (core-prim . list)]
[list-ref list-ref-label (core-prim . list-ref)] [list-ref list-ref-label (core-prim . list-ref)]
[make-list make-list-label (core-prim . make-list)] [make-list make-list-label (core-prim . make-list)]
@ -722,6 +767,8 @@
[>= >=-label (core-prim . >=)] [>= >=-label (core-prim . >=)]
[* *-label (core-prim . *)] [* *-label (core-prim . *)]
[+ plus-label (core-prim . +)] [+ plus-label (core-prim . +)]
[add1 add1-label (core-prim . add1)]
[sub1 sub1-label (core-prim . sub1)]
[number? number?-label (core-prim . number?)] [number? number?-label (core-prim . number?)]
[bignum? bignum?-label (core-prim . bignum?)] [bignum? bignum?-label (core-prim . bignum?)]
[integer? integer?-label (core-prim . integer?)] [integer? integer?-label (core-prim . integer?)]
@ -874,8 +921,14 @@
[compile compile-label (core-prim . compile)] [compile compile-label (core-prim . compile)]
[eval eval-label (core-prim . eval)] [eval eval-label (core-prim . eval)]
[load load-label (core-prim . load)] [load load-label (core-prim . load)]
[expand-mode expand-mode-label (core-prim . expand-mode)]
[assembler-output assembler-output-label (core-prim . assembler-output)]
[current-expand current-expand-label (core-prim . current-expand)]
[expand expand-label (core-prim . expand)]
[fasl-write fasl-write-label (core-prim . fasl-write)]
[new-cafe new-cafe-label (core-prim . new-cafe)] [new-cafe new-cafe-label (core-prim . new-cafe)]
[command-line-arguments command-line-arguments-label (core-prim . command-line-arguments)] [command-line-arguments command-line-arguments-label (core-prim . command-line-arguments)]
[list*->code* list*->code*-label (core-prim . list*->code*)]
;;; record/mid-level ;;; record/mid-level
[record? record?-label (core-prim . record?)] [record? record?-label (core-prim . record?)]
[make-record-type make-record-type-label (core-prim . make-record-type)] [make-record-type make-record-type-label (core-prim . make-record-type)]
@ -1049,6 +1102,19 @@
r mr)]) r mr)])
(build-letrec no-source (build-letrec no-source
lex* rhs* body)))))]))) lex* rhs* body)))))])))
(define type-descriptor-transformer
(lambda (e r mr)
(syntax-match e ()
[(_ id)
(unless (id? id) (stx-error e))
(let* ([lab (id->label id)]
[b (label->binding lab r)]
[type (binding-type b)])
(unless lab (stx-error e "unbound identifier"))
(case type
[($rtd)
(build-data no-source (binding-value b))]
[else (stx-error e "invalid type")]))])))
(define let-transformer (define let-transformer
(lambda (e r mr) (lambda (e r mr)
(syntax-match e () (syntax-match e ()
@ -1140,7 +1206,7 @@
(build-one t cls (chi-void))] (build-one t cls (chi-void))]
[(else-kwd x x* ...) [(else-kwd x x* ...)
(if (and (id? else-kwd) (if (and (id? else-kwd)
(free-id=? else-kwd (sym->free-id 'else))) (free-id=? else-kwd (scheme-stx 'else)))
(build-sequence no-source (build-sequence no-source
(chi-expr* (cons x x*) r mr)) (chi-expr* (cons x x*) r mr))
(stx-error e))] (stx-error e))]
@ -1159,55 +1225,6 @@
[else [else
(build-one t cls (build-one t cls
(f (car cls*) (cdr cls*)))]))))]))) (f (car cls*) (cdr cls*)))]))))])))
(define cond-transformer
(lambda (expr r mr)
(define handle-arrow
(lambda (e v altern)
(let ([t (gen-lexical 't)])
(build-let no-source
(list t) (list (chi-expr e r mr))
(build-conditional no-source
(build-lexical-reference no-source t)
(build-application no-source
(chi-expr v r mr)
(list (build-lexical-reference no-source t)))
altern)))))
(define chi-last
(lambda (e)
(syntax-match e ()
[(e0 e1 e2* ...)
(if (and (id? e0)
(free-id=? e0 (sym->free-id 'else)))
(build-sequence no-source
(chi-expr* (cons e1 e2*) r mr))
(chi-one e (chi-void)))]
[_ (chi-one e (chi-void))])))
(define chi-one
(lambda (e rest)
(define chi-test
(lambda (e rest)
(syntax-match e ()
[(e0 e1 e2 ...)
(build-conditional no-source
(chi-expr e0 r mr)
(build-sequence no-source
(chi-expr* (cons e1 e2) r mr))
rest)]
[_ (stx-error expr)])))
(syntax-match e ()
[(e0 e1 e2)
(if (and (id? e1)
(free-id=? e1 (sym->free-id '=>)))
(handle-arrow e0 e2 rest)
(chi-test e rest))]
[_ (chi-test e rest)])))
(syntax-match expr ()
[(_) (chi-void)]
[(_ e e* ...)
(let f ([e e] [e* e*])
(cond
[(null? e*) (chi-last e)]
[else (chi-one e (f (car e*) (cdr e*)))]))])))
(define quote-transformer (define quote-transformer
(lambda (e r mr) (lambda (e r mr)
(syntax-match e () (syntax-match e ()
@ -1230,14 +1247,11 @@
(build-lambda no-source fmls body))]))) (build-lambda no-source fmls body))])))
(define bless (define bless
(lambda (x) (lambda (x)
(let ([rib (make-scheme-rib)])
(let f ([x x]) (let f ([x x])
(cond (cond
[(pair? x) [(pair? x) (cons (f (car x)) (f (cdr x)))]
(cons (f (car x)) (f (cdr x)))] [(symbol? x) (scheme-stx x)]
[(symbol? x) [else x]))))
(make-stx x top-mark* (list rib))]
[else x])))))
(define with-syntax-macro (define with-syntax-macro
(lambda (e) (lambda (e)
(syntax-match e () (syntax-match e ()
@ -1245,6 +1259,27 @@
(bless (bless
`(syntax-case (list . ,expr*) () `(syntax-case (list . ,expr*) ()
[,fml* (begin ,b . ,b*)]))]))) [,fml* (begin ,b . ,b*)]))])))
(define cond-macro
(lambda (stx)
(syntax-match stx ()
[(_ cls cls* ...)
(bless
(let f ([cls cls] [cls* cls*])
(cond
[(null? cls*)
(syntax-match cls (else =>)
[(else e e* ...) `(begin ,e . ,e*)]
[(e => p) `(let ([t ,e]) (if t (,p t) (void)))]
[(e) `(or ,e (void))]
[(e e* ...) `(if ,e (begin . ,e*) (void))]
[_ (stx-error stx "invalid last clause")])]
[else
(syntax-match cls (else =>)
[(else e e* ...) (stx-error stx "incorrect position of keyword else")]
[(e => p) `(let ([t ,e]) (if t (,p t) ,(f (car cls*) (cdr cls*))))]
[(e) `(or ,e ,(f (car cls*) (cdr cls*)))]
[(e e* ...) `(if ,e (begin . ,e*) ,(f (car cls*) (cdr cls*)))]
[_ (stx-error stx "invalid last clause")])])))])))
(define include-macro (define include-macro
(lambda (e) (lambda (e)
(syntax-match e () (syntax-match e ()
@ -1268,8 +1303,8 @@
(unless (andmap (unless (andmap
(lambda (x) (lambda (x)
(and (id? x) (and (id? x)
(not (free-id=? x (sym->free-id '...))) (not (free-id=? x (scheme-stx '...)))
(not (free-id=? x (sym->free-id '_))))) (not (free-id=? x (scheme-stx '_)))))
lits) lits)
(stx-error e "invalid literals")) (stx-error e "invalid literals"))
(bless `(lambda (x) (bless `(lambda (x)
@ -1277,6 +1312,112 @@
,@(map (lambda (pat tmp) ,@(map (lambda (pat tmp)
`[,pat (syntax ,tmp)]) `[,pat (syntax ,tmp)])
pat* tmp*))))]))) pat* tmp*))))])))
(define quasiquote-macro
(let ()
(define-syntax app
(syntax-rules (quote)
[(_ 'x arg* ...)
(list (scheme-stx 'x) arg* ...)]))
(define-syntax app*
(syntax-rules (quote)
[(_ 'x arg* ... last)
(list* (scheme-stx 'x) arg* ... last)]))
(define quasilist*
(lambda (x y)
(let f ((x x))
(if (null? x) y (quasicons (car x) (f (cdr x)))))))
(define quasicons
(lambda (x y)
(syntax-match y (quote list)
[(quote dy)
(syntax-match x (quote)
[(quote dx) (app 'quote (cons dx dy))]
[_
(syntax-match dy ()
[() (app 'list x)]
[_ (app 'cons x y)])])]
[(list stuff ...)
(app* 'list x stuff)]
[_ (app 'cons x y)])))
(define quasiappend
(lambda (x y)
(let ([ls (let f ((x x))
(if (null? x)
(syntax-match y (quote)
[(quote ()) '()]
[_ (list y)])
(syntax-match (car x) (quote)
[(quote ()) (f (cdr x))]
[_ (cons (car x) (f (cdr x)))])))])
(cond
[(null? ls) (app 'quote '())]
[(null? (cdr ls)) (car ls)]
[else (app* 'append ls)]))))
(define quasivector
(lambda (x)
(let ((pat-x x))
(syntax-match pat-x (quote)
[(quote (x* ...)) (app 'quote (list->vector x*))]
[_ (let f ((x x) (k (lambda (ls) (app* 'vector ls))))
(syntax-match x (quote list cons)
[(quote (x* ...))
(k (map (lambda (x) (app 'quote x)) x*))]
[(list x* ...)
(k x*)]
[(cons x y)
(f y (lambda (ls) (k (cons x ls))))]
[_ (app 'list->vector pat-x)]))]))))
(define vquasi
(lambda (p lev)
(syntax-match p ()
[(p . q)
(syntax-match p (unquote unquote-splicing)
[(unquote p ...)
(if (= lev 0)
(quasilist* p (vquasi q lev))
(quasicons
(quasicons (app 'quote 'unquote)
(quasi p (- lev 1)))
(vquasi q lev)))]
[(unquote-splicing p ...)
(if (= lev 0)
(quasiappend p (vquasi q lev))
(quasicons
(quasicons
(app 'quote 'unquote-splicing)
(quasi p (- lev 1)))
(vquasi q lev)))]
[p (quasicons (quasi p lev) (vquasi q lev))])]
[() (app 'quote '())])))
(define quasi
(lambda (p lev)
(syntax-match p (unquote unquote-splicing quasiquote)
[(unquote p)
(if (= lev 0)
p
(quasicons (app 'quote 'unquote) (quasi (list p) (- lev 1))))]
[((unquote p ...) . q)
(if (= lev 0)
(quasilist* p (quasi q lev))
(quasicons
(quasicons (app 'quote 'unquote) (quasi p (- lev 1)))
(quasi q lev)))]
[((unquote-splicing p ...) . q)
(if (= lev 0)
(quasiappend p (quasi q lev))
(quasicons
(quasicons
(app 'quote 'unquote-splicing)
(quasi p (- lev 1)))
(quasi q lev)))]
[(quasiquote p)
(quasicons (app 'quote 'quasiquote) (quasi (list p) (+ lev 1)))]
[(p . q) (quasicons (quasi p lev) (quasi q lev))]
[#(x ...) (quasivector (vquasi x lev))]
[p (app 'quote p)])))
(lambda (x)
(syntax-match x ()
[(_ e) (quasi e 0)]))))
(define define-record-macro (define define-record-macro
(lambda (e) (lambda (e)
(define enumerate (define enumerate
@ -1481,7 +1622,7 @@
[else (values (vector 'atom (strip p '())) ids)])] [else (values (vector 'atom (strip p '())) ids)])]
[(bound-id-member? p keys) [(bound-id-member? p keys)
(values (vector 'free-id p) ids)] (values (vector 'free-id p) ids)]
[(free-id=? p (sym->free-id '_)) [(free-id=? p (scheme-stx '_))
(values '_ ids)] (values '_ ids)]
[else (values 'any (cons (cons p n) ids))]))) [else (values 'any (cons (cons p n) ids))])))
(cvt pattern 0 '()))) (cvt pattern 0 '())))
@ -1605,7 +1746,7 @@
(match e p '() '() '()))) (match e p '() '() '())))
(define ellipsis? (define ellipsis?
(lambda (x) (lambda (x)
(and (id? x) (free-id=? x (sym->free-id '...))))) (and (id? x) (free-id=? x (scheme-stx '...)))))
(define syntax-case-transformer (define syntax-case-transformer
(let () (let ()
(define build-dispatch-call (define build-dispatch-call
@ -1675,7 +1816,7 @@
(if (and (id? pat) (if (and (id? pat)
(not (bound-id-member? pat keys)) (not (bound-id-member? pat keys))
(not (ellipsis? pat))) (not (ellipsis? pat)))
(if (free-id=? pat (sym->free-id '_)) (if (free-id=? pat (scheme-stx '_))
(chi-expr expr r mr) (chi-expr expr r mr)
(let ([lab (gen-label pat)] (let ([lab (gen-label pat)]
[lex (gen-lexical pat)]) [lex (gen-lexical pat)])
@ -1893,6 +2034,7 @@
[(foreign-call) foreign-call-transformer] [(foreign-call) foreign-call-transformer]
[(syntax-case) syntax-case-transformer] [(syntax-case) syntax-case-transformer]
[(syntax) syntax-transformer] [(syntax) syntax-transformer]
[(type-descriptor) type-descriptor-transformer]
[else (error 'macro-transformer "cannot find ~s" name)]))) [else (error 'macro-transformer "cannot find ~s" name)])))
(define macro-transformer (define macro-transformer
(lambda (x) (lambda (x)
@ -1902,7 +2044,9 @@
(case x (case x
[(define-record) define-record-macro] [(define-record) define-record-macro]
[(include) include-macro] [(include) include-macro]
[(cond) cond-macro]
[(syntax-rules) syntax-rules-macro] [(syntax-rules) syntax-rules-macro]
[(quasiquote) quasiquote-macro]
[(with-syntax) with-syntax-macro] [(with-syntax) with-syntax-macro]
[else (error 'macro-transformer [else (error 'macro-transformer
"invalid macro ~s" x)])] "invalid macro ~s" x)])]
@ -2096,7 +2240,7 @@
module-init** module-init**
(cons (cons lab b) r) (cons (cons lab b) r)
(cons (cons lab b) mr) (cons (cons lab b) mr)
lhs* lex* rhs* kwd*)))))] (cons id lhs*) lex* rhs* kwd*)))))]
[(begin) [(begin)
(syntax-match e () (syntax-match e ()
[(_ x* ...) [(_ x* ...)
@ -2176,6 +2320,19 @@
(cons lex lex*) (cons lex lex*)
(cons rhs rhs*) (cons rhs rhs*)
kwd*)))] 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*)
(cons (cons lab b) r)
(cons (cons lab b) mr)
(cons id lhs*)
lex* rhs* kwd*)))))]
[(begin) [(begin)
(syntax-match e () (syntax-match e ()
[(_ x* ...) [(_ x* ...)
@ -2228,7 +2385,7 @@
module-init** module-init**
(cons (cons lab b) r) (cons (cons lab b) r)
(cons (cons lab b) mr) (cons (cons lab b) mr)
lhs* lex* rhs* kwd*)))))] (cons id lhs*) lex* rhs* kwd*)))))]
[(module) [(module)
(let-values ([(m-lhs* m-lex* m-rhs* m-init* m-exp-id* m-exp-lab* r mr kwd*) (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*)]) (chi-internal-module e r mr kwd*)])