* first library (ikarus interaction) is added.
* the library expander (syntax.ss) is added.
This commit is contained in:
Abdulaziz Ghuloum
parent
fde9424682
commit
c1a946b346
13
.bzrignore
13
.bzrignore
|
|
@ -5,3 +5,16 @@
|
|||
.vimview
|
||||
.DS_Store
|
||||
benchmarks/sys/*
|
||||
benchmarks/results.AWK-r6rs
|
||||
benchmarks/results.Chicken-r6rs
|
||||
benchmarks/results.GCC-r5rs
|
||||
benchmarks/results.GCC-r6rs
|
||||
benchmarks/results.Gambit-C-r6rs
|
||||
benchmarks/results.Ikarus-r6rs
|
||||
benchmarks/results.Java-r5rs
|
||||
benchmarks/results.Java-r6rs
|
||||
benchmarks/results.Larceny-r6rs
|
||||
benchmarks/results.MzScheme-r6rs
|
||||
benchmarks/results.Petite-Chez-Scheme-r5rs
|
||||
benchmarks/results.Petite-Chez-Scheme-r6rs
|
||||
benchmarks/results.Scheme48-r6rs
|
||||
|
|
|
|||
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
|
@ -551,7 +551,8 @@
|
|||
[(funcall) #t]
|
||||
[(conditional) #f]
|
||||
[(bind lhs* rhs* body) (valid-mv-producer? body)]
|
||||
[else (error 'valid-mv-producer? "unhandles ~s"
|
||||
[else #f] ;; FIXME BUG
|
||||
#;[else (error 'valid-mv-producer? "unhandles ~s"
|
||||
(unparse x))]))
|
||||
(record-case rator
|
||||
[(clambda g cls*)
|
||||
|
|
@ -5223,6 +5224,12 @@
|
|||
ls*)])
|
||||
(car code*)))))
|
||||
|
||||
|
||||
(define compile-core-expr-to-port
|
||||
(lambda (expr port)
|
||||
(parameterize ([current-expand (lambda (x) x)])
|
||||
(fasl-write (compile-expr expr) port))))
|
||||
|
||||
(define compile-file
|
||||
(lambda (input-file output-file . rest)
|
||||
(let ([ip (open-input-file input-file)]
|
||||
|
|
@ -5248,6 +5255,8 @@
|
|||
(close-output-port op))))
|
||||
|
||||
|
||||
(primitive-set! 'compile-core-expr-to-port compile-core-expr-to-port)
|
||||
|
||||
(primitive-set! 'compile-file compile-file)
|
||||
(primitive-set! 'alt-compile-file alt-compile-file)
|
||||
(primitive-set! 'assembler-output (make-parameter #f))
|
||||
|
|
|
|||
|
|
@ -68,35 +68,38 @@
|
|||
|
||||
|
||||
;;; Finally, we're ready to evaluate the files and enter the cafe.
|
||||
(let-values ([(files script args)
|
||||
(let f ([args (command-line-arguments)])
|
||||
(cond
|
||||
[(null? args) (values '() #f '())]
|
||||
[(string=? (car args) "--")
|
||||
(values '() #f (cdr args))]
|
||||
[(string=? (car args) "--script")
|
||||
(let ([d (cdr args)])
|
||||
(cond
|
||||
[(null? d)
|
||||
(error #f "--script requires a script name")]
|
||||
[else
|
||||
(values '() (car d) (cdr d))]))]
|
||||
[else
|
||||
(let-values ([(f* script a*) (f (cdr args))])
|
||||
(values (cons (car args) f*) script a*))]))])
|
||||
(current-eval compile)
|
||||
(cond
|
||||
[script ; no greeting, no cafe
|
||||
(command-line-arguments (cons script args))
|
||||
(for-each load files)
|
||||
(load script)
|
||||
(exit 0)]
|
||||
[else
|
||||
(printf "Ikarus Scheme (Build ~a)\n" (compile-time-date-string))
|
||||
(display "Copyright (c) 2006-2007 Abdulaziz Ghuloum\n\n")
|
||||
(command-line-arguments args)
|
||||
(for-each load files)
|
||||
(new-cafe)
|
||||
(exit 0)]))
|
||||
|
||||
(library (ikarus interaction)
|
||||
(export)
|
||||
(import (scheme))
|
||||
(let-values ([(files script args)
|
||||
(let f ([args (command-line-arguments)])
|
||||
(cond
|
||||
[(null? args) (values '() #f '())]
|
||||
[(string=? (car args) "--")
|
||||
(values '() #f (cdr args))]
|
||||
[(string=? (car args) "--script")
|
||||
(let ([d (cdr args)])
|
||||
(cond
|
||||
[(null? d)
|
||||
(error #f "--script requires a script name")]
|
||||
[else
|
||||
(values '() (car d) (cdr d))]))]
|
||||
[else
|
||||
(let-values ([(f* script a*) (f (cdr args))])
|
||||
(values (cons (car args) f*) script a*))]))])
|
||||
(current-eval compile)
|
||||
(cond
|
||||
[script ; no greeting, no cafe
|
||||
(command-line-arguments (cons script args))
|
||||
(for-each load files)
|
||||
(load script)
|
||||
(exit 0)]
|
||||
[else
|
||||
(printf "Ikarus Scheme (Build ~a)\n" "NO 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)
|
||||
(for-each load files)
|
||||
(new-cafe)
|
||||
(exit 0)])))
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@
|
|||
syntax quasisyntax unsyntax unsyntax-splicing datum
|
||||
let let* let-values cond case define-record or and when unless do
|
||||
include parameterize trace untrace trace-lambda trace-define
|
||||
rec
|
||||
rec library
|
||||
time))
|
||||
|
||||
|
||||
|
|
@ -153,6 +153,7 @@
|
|||
*current-output-port* *standard-input-port* *current-input-port*
|
||||
|
||||
;;;
|
||||
compile-core-expr-to-port
|
||||
compiler-giveup-tally
|
||||
))
|
||||
|
||||
|
|
@ -266,42 +267,6 @@
|
|||
(define (expand-file ifile)
|
||||
(map sc-expand (read-file ifile)))
|
||||
|
||||
(define (compile-library ifile ofile which-compile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[interaction-environment system-env])
|
||||
(let ([proc
|
||||
(case which-compile
|
||||
[(onepass) compile-file]
|
||||
[(chaitin) alt-compile-file]
|
||||
[else (error 'compile-library "unknown compile ~s"
|
||||
which-compile)])])
|
||||
(printf "compiling ~a ... \n" ifile)
|
||||
(proc ifile ofile 'replace))))
|
||||
|
||||
|
||||
|
||||
#;(let ()
|
||||
(define (compile-all who)
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(when (eq? who (caddr x))
|
||||
(compile-library (car x) (cadr x) (cadddr x))))
|
||||
scheme-library-files))
|
||||
(define (time x) x)
|
||||
(fork
|
||||
(lambda (pid)
|
||||
(time (compile-all 'p1))
|
||||
(unless (fxzero? (waitpid pid))
|
||||
(exit -1)))
|
||||
(lambda ()
|
||||
(time (compile-all 'p0))
|
||||
(exit))))
|
||||
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x) (cadddr x)))
|
||||
scheme-library-files)
|
||||
|
||||
(define (join s ls)
|
||||
(cond
|
||||
|
|
@ -318,10 +283,54 @@
|
|||
(display s str)
|
||||
(f (car d) (cdr d))])))]))
|
||||
|
||||
(define (compile-all)
|
||||
(define (compile-library ifile ofile which-compile)
|
||||
(parameterize ([assembler-output #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[interaction-environment system-env])
|
||||
(let ([proc
|
||||
(case which-compile
|
||||
[(onepass) compile-file]
|
||||
[(chaitin) alt-compile-file]
|
||||
[else (error 'compile-library "unknown compile ~s"
|
||||
which-compile)])])
|
||||
(printf "compiling ~a ... \n" ifile)
|
||||
(proc ifile ofile 'replace))))
|
||||
|
||||
(system
|
||||
(format "cat ~a > ikarus.boot"
|
||||
(join " " (map cadr scheme-library-files))))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(compile-library (car x) (cadr x) (cadddr x)))
|
||||
scheme-library-files)
|
||||
(system
|
||||
(format "cat ~a > ikarus.boot"
|
||||
(join " " (map cadr scheme-library-files)))))
|
||||
|
||||
(define (new-compile-all)
|
||||
(define (slurp-file file)
|
||||
(with-input-from-file file
|
||||
(lambda ()
|
||||
(let f ()
|
||||
(let ([x (read)])
|
||||
(if (eof-object? x)
|
||||
'()
|
||||
(cons x (f))))))))
|
||||
(define (expand-library ifile)
|
||||
(parameterize ([expand-mode 'bootstrap]
|
||||
[interaction-environment system-env])
|
||||
(expand (cons 'begin (slurp-file ifile)))))
|
||||
(define (expand-all ls)
|
||||
(map (lambda (x) (expand-library (car x))) ls))
|
||||
(printf "expanding ...\n")
|
||||
(let ([core* (expand-all scheme-library-files)])
|
||||
(printf "compiling ...\n")
|
||||
(let ([p (open-output-file "ikarus.boot" 'replace)])
|
||||
(for-each
|
||||
(lambda (x) (#%compile-core-expr-to-port x p))
|
||||
core*)
|
||||
(close-output-port p))))
|
||||
|
||||
;(compile-all)
|
||||
(new-compile-all)
|
||||
|
||||
(printf "Happy Happy Joy Joy\n")
|
||||
;(#%compiler-giveup-tally)
|
||||
|
|
|
|||
|
|
@ -684,6 +684,7 @@
|
|||
|
||||
(define-syntax build-lexical-reference
|
||||
(syntax-rules ()
|
||||
((_ ae var) var)
|
||||
((_ type ae var)
|
||||
var)))
|
||||
|
||||
|
|
@ -1701,6 +1702,7 @@
|
|||
(($import) (values '$import-form #f e w ae))
|
||||
((eval-when) (values 'eval-when-form #f e w ae))
|
||||
((meta) (values 'meta-form #f e w ae))
|
||||
((library) (values 'library-form #f e w ae))
|
||||
((local-syntax)
|
||||
(values 'local-syntax-form (binding-value b) e w ae))
|
||||
(else (values 'call #f e w ae))))
|
||||
|
|
@ -1736,6 +1738,8 @@
|
|||
meta-residualize! #f)))
|
||||
(cons first (dobody (cdr body)))))))))
|
||||
|
||||
|
||||
|
||||
(define chi-top
|
||||
(lambda (e r w ctem rtem meta? top-ribcage meta-residualize! meta-seen?)
|
||||
(let-values (((type value e w ae) (syntax-type e r w no-source top-ribcage)))
|
||||
|
|
@ -1817,6 +1821,7 @@
|
|||
(lambda ()
|
||||
(build-global-definition ae valsym (chi rhs r r w #f)))))))))
|
||||
))))
|
||||
((library-form) (chi-top-library e))
|
||||
(($module-form)
|
||||
(let ((ribcage (make-empty-ribcage)))
|
||||
(let-values (((orig id exports forms)
|
||||
|
|
@ -2045,6 +2050,10 @@
|
|||
(else (error 'sc-expand-internal "unexpected module binding type ~s" t)))))
|
||||
(loop bs))))))))))))
|
||||
|
||||
|
||||
(include "syntax.ss")
|
||||
|
||||
|
||||
(define id-set-diff
|
||||
(lambda (exports defs)
|
||||
(cond
|
||||
|
|
@ -3403,6 +3412,8 @@
|
|||
(global-extend 'alias 'alias '())
|
||||
(global-extend 'begin 'begin '())
|
||||
|
||||
(global-extend 'library 'library '())
|
||||
|
||||
(global-extend '$module-key '$module '())
|
||||
(global-extend '$import '$import '())
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,747 @@
|
|||
|
||||
|
||||
(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 who 'chi-top-library)
|
||||
(define-syntax assert
|
||||
(syntax-rules ()
|
||||
[(_ name pred* ...)
|
||||
(unless (and pred* ...)
|
||||
(error 'name "assertion ~s failed" '(pred* ...)))]))
|
||||
(define top-mark* '(top))
|
||||
(define top-marked?
|
||||
(lambda (m*) (memq 'top m*)))
|
||||
(define gen-lexical
|
||||
(lambda (sym)
|
||||
(cond
|
||||
[(symbol? sym)
|
||||
(gensym (symbol->string sym))]
|
||||
[(stx? sym) (gen-lexical (id->sym sym))]
|
||||
[else (error 'gen-lexical "invalid arg ~s" sym)])))
|
||||
(define gen-label
|
||||
(lambda (_) (gensym)))
|
||||
(define make-rib
|
||||
(lambda (sym* mark** label*)
|
||||
(vector 'rib sym* mark** label*)))
|
||||
(define id/label-rib
|
||||
(lambda (id* label*)
|
||||
(make-rib (map id->sym id*) (map stx-mark* id*) label*)))
|
||||
(define make-empty-rib
|
||||
(lambda ()
|
||||
(make-rib '() '() '())))
|
||||
(define extend-rib!
|
||||
(lambda (rib id label)
|
||||
(if (rib? rib)
|
||||
(let ([sym (id->sym id)] [mark* (stx-mark* id)])
|
||||
(vector-set! rib 1 (cons sym (vector-ref rib 1)))
|
||||
(vector-set! rib 2 (cons mark* (vector-ref rib 2)))
|
||||
(vector-set! rib 3 (cons label (vector-ref rib 3))))
|
||||
(error 'extend-rib! "~s is not a rib" rib))))
|
||||
(define rib?
|
||||
(lambda (x)
|
||||
(and (vector? x)
|
||||
(= (vector-length x) 4)
|
||||
(eq? (vector-ref x 0) 'rib))))
|
||||
(define rib-sym*
|
||||
(lambda (x)
|
||||
(if (rib? x)
|
||||
(vector-ref x 1)
|
||||
(error 'rib-sym* "~s is not a rib" x))))
|
||||
(define rib-mark**
|
||||
(lambda (x)
|
||||
(if (rib? x)
|
||||
(vector-ref x 2)
|
||||
(error 'rib-mark** "~s is not a rib" x))))
|
||||
(define rib-label*
|
||||
(lambda (x)
|
||||
(if (rib? x)
|
||||
(vector-ref x 3)
|
||||
(error 'rib-label* "~s is not a rib" x))))
|
||||
(define make-stx
|
||||
(lambda (e m* s*)
|
||||
(vector 'stx e m* s*)))
|
||||
(define stx?
|
||||
(lambda (x)
|
||||
(and (vector? x)
|
||||
(= (vector-length x) 4)
|
||||
(eq? (vector-ref x 0) 'stx))))
|
||||
(define stx-expr
|
||||
(lambda (x)
|
||||
(if (stx? x)
|
||||
(vector-ref x 1)
|
||||
(error 'stx-expr "~s is not a syntax object" x))))
|
||||
(define stx-mark*
|
||||
(lambda (x)
|
||||
(if (stx? x)
|
||||
(vector-ref x 2)
|
||||
(error 'stx-mark* "~s is not a syntax object" x))))
|
||||
(define stx-subst*
|
||||
(lambda (x)
|
||||
(if (stx? x)
|
||||
(vector-ref x 3)
|
||||
(error 'stx-subst* "~s is not a syntax object" x))))
|
||||
(define join-wraps
|
||||
(lambda (m1* s1* e)
|
||||
(define cancel
|
||||
(lambda (ls1 ls2)
|
||||
(let f ((x (car ls1)) (ls1 (cdr ls1)))
|
||||
(if (null? ls1)
|
||||
(cdr ls2)
|
||||
(cons x (f (car ls1) (cdr ls1)))))))
|
||||
(let ((m2* (stx-mark* e)) (s2* (stx-subst* e)))
|
||||
(if (and (not (null? m1*))
|
||||
(not (null? m2*))
|
||||
(eq? (car m2*) anti-mark))
|
||||
; cancel mark, anti-mark, and corresponding shifts
|
||||
(values (cancel m1* m2*) (cancel s1* s2*))
|
||||
(values (append m1* m2*) (append s1* s2*))))))
|
||||
(define stx
|
||||
(lambda (e m* s*)
|
||||
(if (stx? e)
|
||||
(let-values ([(m* s*) (join-wraps m* s* e)])
|
||||
(make-stx (stx-expr e) m* s*))
|
||||
(make-stx e m* s*))))
|
||||
(define sym->free-id
|
||||
(lambda (x)
|
||||
(stx x top-mark* '())))
|
||||
(define add-subst
|
||||
(lambda (subst e)
|
||||
(if subst
|
||||
(stx e '() (list subst))
|
||||
e)))
|
||||
(define syntax-kind?
|
||||
(lambda (x p?)
|
||||
(if (stx? x)
|
||||
(syntax-kind? (stx-expr x) p?)
|
||||
(p? x))))
|
||||
(define syntax-pair?
|
||||
(lambda (x) (syntax-kind? x pair?)))
|
||||
(define syntax-null?
|
||||
(lambda (x) (syntax-kind? x null?)))
|
||||
(define syntax-list?
|
||||
(lambda (x)
|
||||
(or (syntax-null? x)
|
||||
(and (syntax-pair? x) (syntax-list? (syntax-cdr x))))))
|
||||
(define syntax-car
|
||||
(lambda (x)
|
||||
(if (stx? x)
|
||||
(stx (syntax-car (stx-expr x)) (stx-mark* x) (stx-subst* x))
|
||||
(if (pair? x)
|
||||
(car x)
|
||||
(error 'syntax-car "~s is not a pair" x)))))
|
||||
(define syntax->list
|
||||
(lambda (x)
|
||||
(if (syntax-pair? x)
|
||||
(cons (syntax-car x) (syntax->list (syntax-cdr x)))
|
||||
(if (syntax-null? x)
|
||||
'()
|
||||
(error 'syntax->list "invalid ~s" x)))))
|
||||
(define syntax-cdr
|
||||
(lambda (x)
|
||||
(if (stx? x)
|
||||
(stx (syntax-cdr (stx-expr x)) (stx-mark* x) (stx-subst* x))
|
||||
(if (pair? x)
|
||||
(cdr x)
|
||||
(error 'syntax-cdr "~s is not a pair" x)))))
|
||||
(define id?
|
||||
(lambda (x) (syntax-kind? x symbol?)))
|
||||
(define id->sym
|
||||
(lambda (x)
|
||||
(if (stx? x)
|
||||
(id->sym (stx-expr x))
|
||||
(if (symbol? x)
|
||||
x
|
||||
(error 'id->sym "~s is not an id" x)))))
|
||||
(define same-marks?
|
||||
(lambda (x y)
|
||||
(or (eq? x y)
|
||||
(and (pair? x) (pair? y)
|
||||
(eq? (car x) (car y))
|
||||
(same-marks? (cdr x) (cdr y))))))
|
||||
(define bound-id=?
|
||||
(lambda (x y)
|
||||
(and (eq? (id->sym x) (id->sym y))
|
||||
(same-marks? (stx-mark* x) (stx-mark* y)))))
|
||||
(define free-id=?
|
||||
(lambda (i j)
|
||||
(let ((t0 (id->label i)) (t1 (id->label j)))
|
||||
(if (or t0 t1)
|
||||
(eq? t0 t1)
|
||||
(eq? (id->sym i) (id->sym j))))))
|
||||
(define valid-bound-ids?
|
||||
(lambda (id*)
|
||||
(and (andmap id? id*)
|
||||
(distinct-bound-ids? id*))))
|
||||
(define distinct-bound-ids?
|
||||
(lambda (id*)
|
||||
(or (null? id*)
|
||||
(and (not (bound-id-member? (car id*) (cdr id*)))
|
||||
(distinct-bound-ids? (cdr id*))))))
|
||||
(define bound-id-member?
|
||||
(lambda (id id*)
|
||||
(and (pair? id*)
|
||||
(or (bound-id=? id (car id*))
|
||||
(bound-id-member? id (cdr id*))))))
|
||||
(define self-evaluating?
|
||||
(lambda (x)
|
||||
(or (number? x) (string? x) (char? x) (boolean? x))))
|
||||
(define strip
|
||||
(lambda (x m*)
|
||||
(if (top-marked? m*)
|
||||
x
|
||||
(let f ([x x])
|
||||
(cond
|
||||
[(stx? x) (strip (stx-expr x) (stx-mark* x))]
|
||||
[(pair? x)
|
||||
(let ([a (f (car x))] [d (f (cdr x))])
|
||||
(if (and (eq? a (car x)) (eq? d (cdr x)))
|
||||
x
|
||||
(cons a d)))]
|
||||
[(vector? x)
|
||||
(let ([old (vector->list x)])
|
||||
(let ([new (map f old)])
|
||||
(if (andmap eq? old new)
|
||||
x
|
||||
(list->vector new))))]
|
||||
[else x])))))
|
||||
(define id->label
|
||||
(lambda (id)
|
||||
(assert id->label (id? id))
|
||||
(let ([sym (id->sym id)])
|
||||
(let search ([subst* (stx-subst* id)] [mark* (stx-mark* id)])
|
||||
(cond
|
||||
[(null? subst*) #f]
|
||||
[(eq? (car subst*) 'shift)
|
||||
(search (cdr subst*) (cdr mark*))]
|
||||
[else
|
||||
(let ([rib (car subst*)])
|
||||
(let f ([sym* (rib-sym* rib)]
|
||||
[mark** (rib-mark** rib)]
|
||||
[label* (rib-label* rib)])
|
||||
(cond
|
||||
[(null? sym*) (search (cdr subst*) mark*)]
|
||||
[(and (eq? (car sym*) sym)
|
||||
(same-marks? (car mark**) mark*))
|
||||
(car label*)]
|
||||
[else (f (cdr sym*) (cdr mark**) (cdr label*))])))])))))
|
||||
(define label->binding
|
||||
(lambda (x r)
|
||||
(cond
|
||||
[(not x) (cons 'unbound #f)]
|
||||
[(assq x r) => cdr]
|
||||
[else (cons 'displaced-lexical #f)])))
|
||||
(define syntax-type
|
||||
(lambda (e r)
|
||||
(cond
|
||||
[(id? e)
|
||||
(let ([id e])
|
||||
(let* ([label (id->label id)]
|
||||
[b (label->binding label r)]
|
||||
[type (binding-type b)])
|
||||
(unless label
|
||||
(stx-error e "unbound identifier"))
|
||||
(case type
|
||||
[(lexical core-prim)
|
||||
(values type (binding-value b) id)]
|
||||
[else (values 'other #f #f)])))]
|
||||
[(syntax-pair? e)
|
||||
(let ([id (syntax-car e)])
|
||||
(if (id? id)
|
||||
(let* ([label (id->label id)]
|
||||
[b (label->binding label r)]
|
||||
[type (binding-type b)])
|
||||
(case type
|
||||
[(define core-macro)
|
||||
(values type (binding-value b) id)]
|
||||
[else
|
||||
(values 'call #f #f)]))
|
||||
(values 'call #f #f)))]
|
||||
[else (let ([d (strip e '())])
|
||||
(if (self-evaluating? d)
|
||||
(values 'constant d #f)
|
||||
(values 'other #f #f)))])))
|
||||
(define parse-library
|
||||
(lambda (e)
|
||||
(syntax-case e ()
|
||||
[(_ (name name* ...)
|
||||
(export exp* ...)
|
||||
(import (scheme))
|
||||
b* ...)
|
||||
(and (eq? #'export 'export)
|
||||
(eq? #'import 'import)
|
||||
(eq? #'scheme 'scheme)
|
||||
(symbol? #'name)
|
||||
(andmap symbol? #'(name* ...))
|
||||
(andmap symbol? #'(exp* ...)))
|
||||
(values #'(name name* ...) #'(exp* ...) #'(b* ...))]
|
||||
[_ (error who "malformed library ~s" e)])))
|
||||
(define stx-error
|
||||
(lambda (stx . args)
|
||||
(error 'chi "invalid syntax ~s" (strip stx '()))))
|
||||
(define-syntax syntax-match-test
|
||||
(lambda (stx)
|
||||
(define dots?
|
||||
(lambda (x)
|
||||
(and (identifier? x)
|
||||
(free-identifier=? x #'(... ...)))))
|
||||
(define f
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[id (identifier? #'id) #'(lambda (x) #t)]
|
||||
[(pat dots) (dots? #'dots)
|
||||
(with-syntax ([p (f #'pat)])
|
||||
#'(lambda (x)
|
||||
(and (syntax-list? x)
|
||||
(andmap p (syntax->list x)))))]
|
||||
[(pat dots . last) (dots? #'dots)
|
||||
(with-syntax ([p (f #'pat)] [l (f #'last)])
|
||||
#'(lambda (x)
|
||||
(let loop ([x x])
|
||||
(cond
|
||||
[(syntax-pair? x)
|
||||
(and (p (syntax-car x))
|
||||
(loop (syntax-cdr x)))]
|
||||
[else (l x)]))))]
|
||||
[(a . d)
|
||||
(with-syntax ([pa (f #'a)] [pd (f #'d)])
|
||||
#'(lambda (x)
|
||||
(and (syntax-pair? x)
|
||||
(pa (syntax-car x))
|
||||
(pd (syntax-cdr x)))))]
|
||||
[datum
|
||||
#'(lambda (x)
|
||||
(equal? (strip x '()) 'datum))])))
|
||||
(syntax-case stx ()
|
||||
[(_ x [pat code])
|
||||
(with-syntax ([pat-code (f #'pat)])
|
||||
#'(pat-code x))])))
|
||||
(define-syntax syntax-match-conseq
|
||||
(lambda (stx)
|
||||
(define dots?
|
||||
(lambda (x)
|
||||
(and (identifier? x)
|
||||
(free-identifier=? x #'(... ...)))))
|
||||
(define f
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[id (identifier? #'id)
|
||||
(values (list #'id) #'(lambda (x) x))]
|
||||
[(pat dots) (dots? #'dots)
|
||||
(let-values ([(vars extractor) (f #'pat)])
|
||||
(cond
|
||||
[(null? vars)
|
||||
(values '() #'(lambda (x) (dont-call-me)))]
|
||||
[else
|
||||
(values vars
|
||||
(with-syntax ([(vars ...) vars]
|
||||
[ext extractor]
|
||||
[(t* ...) (generate-temporaries vars)])
|
||||
#'(lambda (x)
|
||||
(let f ([x x] [vars '()] ...)
|
||||
(cond
|
||||
[(syntax-null? x)
|
||||
(values (reverse vars) ...)]
|
||||
[else
|
||||
(let-values ([(t* ...) (ext (syntax-car x))])
|
||||
(f (syntax-cdr x)
|
||||
(cons t* vars)
|
||||
...))])))))]))]
|
||||
[(pat dots . last) (dots? #'dots)
|
||||
(let-values ([(pvars pext) (f #'pat)])
|
||||
(let-values ([(lvars lext) (f #'d)])
|
||||
(cond
|
||||
[(and (null? pvars) (null? lvars))
|
||||
(values '() #'(lambda (x) (dont-call-me)))]
|
||||
[(null? lvars)
|
||||
(values pvars
|
||||
(with-syntax ([(pvars ...) pvars]
|
||||
[(t* ...) (generate-temporaries pvars)]
|
||||
[pext pext])
|
||||
#'(lambda (x)
|
||||
(let loop ([x x] [pvars '()] ...)
|
||||
(cond
|
||||
[(syntax-pair? x)
|
||||
(let-values ([(t* ...) (pext (syntax-car x))])
|
||||
(loop (syntax-cdr x)
|
||||
(cons t* pvars) ...))]
|
||||
[else
|
||||
(values (reverse pvars) ...)])))))]
|
||||
[(null? pvars)
|
||||
(values lvars
|
||||
(with-syntax ([lext lext])
|
||||
#'(let loop ([x x])
|
||||
(cond
|
||||
[(syntax-pair? x) (loop (syntax-cdr x))]
|
||||
[else (lext x)]))))]
|
||||
[else
|
||||
(values (append pvars lvars)
|
||||
(with-syntax ([(pvars ...) pvars]
|
||||
[(t* ...) (generate-temporaries pvars)]
|
||||
[(lvars ...) lvars]
|
||||
[lext lext]
|
||||
[pext pext])
|
||||
#'(lambda (x)
|
||||
(let loop ([x x] [pvars '()] ...)
|
||||
(cond
|
||||
[(syntax-pair? x)
|
||||
(let-values ([(t* ...) (pext (syntax-car x))])
|
||||
(loop (syntax-cdr x)
|
||||
(cons t* pvars) ...))]
|
||||
[else
|
||||
(let-values ([(lvars ...) (lext x)])
|
||||
(values (reverse pvars) ...
|
||||
lvars ...))])))))])))]
|
||||
[(a . d)
|
||||
(let-values ([(avars aextractor) (f #'a)])
|
||||
(let-values ([(dvars dextractor) (f #'d)])
|
||||
(cond
|
||||
[(and (null? avars) (null? dvars))
|
||||
(values '() #'(lambda (x) (dot-call-me)))]
|
||||
[(null? avars)
|
||||
(values dvars
|
||||
(with-syntax ([d dextractor])
|
||||
#'(lambda (x) (d (syntax-cdr x)))))]
|
||||
[(null? dvars)
|
||||
(values avars
|
||||
(with-syntax ([a aextractor])
|
||||
#'(lambda (x) (a (syntax-car x)))))]
|
||||
[else
|
||||
(values (append avars dvars)
|
||||
(with-syntax ([(avars ...) avars]
|
||||
[(dvars ...) dvars]
|
||||
[a aextractor]
|
||||
[d dextractor])
|
||||
#'(lambda (x)
|
||||
(let-values ([(avars ...) (a (syntax-car x))])
|
||||
(let-values ([(dvars ...) (d (syntax-cdr x))])
|
||||
(values avars ... dvars ...))))))])))]
|
||||
[datum
|
||||
(values '() #'(lambda (x) (dot-call-me)))])))
|
||||
(syntax-case stx ()
|
||||
[(_ x [pat code])
|
||||
(let-values ([(vars extractor)
|
||||
(f #'pat)])
|
||||
(with-syntax ([e extractor] [(vs ...) vars])
|
||||
(case (length vars)
|
||||
[(0) #'code]
|
||||
[(1) #'(let ([vs ... (e x)]) code)]
|
||||
[else #'(let-values ([(vs ...) (e x)]) code)])))])))
|
||||
(define-syntax syntax-match
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ expr) #'(stx-error expr)]
|
||||
[(_ expr cls cls* ...)
|
||||
#'(let ([t expr])
|
||||
(if (syntax-match-test t cls)
|
||||
(syntax-match-conseq t cls)
|
||||
(syntax-match t cls* ...)))])))
|
||||
(define parse-define
|
||||
(lambda (x)
|
||||
(syntax-match x
|
||||
[(_ (id . fmls) b b* ...)
|
||||
(if (id? id)
|
||||
(values id
|
||||
(cons 'defun (cons fmls (cons b b*))))
|
||||
(stx-error x))]
|
||||
[(_ id val)
|
||||
(if (id? id)
|
||||
(values id (cons 'expr val))
|
||||
(stx-error x))])))
|
||||
(define scheme-env
|
||||
'([define define-label (define)]
|
||||
[quote quote-label (core-macro . quote)]
|
||||
[let-values let-values-label (core-macro . let-values)]
|
||||
[let let-label (core-macro . let)]
|
||||
[cond cond-label (core-macro . cond)]
|
||||
[cons cons-label (core-prim . cons)]
|
||||
[values values-label (core-prim . values)]
|
||||
[car car-label (core-prim . car)]
|
||||
[cdr cdr-label (core-prim . cdr)]
|
||||
[null? null?-label (core-prim . null?)]
|
||||
[error error-label (core-prim . error)]
|
||||
[exit exit-label (core-prim . exit)]
|
||||
[new-cafe new-cafe-label (core-prim . new-cafe)]
|
||||
[load load-label (core-prim . load)]
|
||||
[for-each for-each-label (core-prim . for-each)]
|
||||
[display display-label (core-prim . display)]
|
||||
[current-eval current-eval-label (core-prim . current-eval)]
|
||||
[compile compile-label (core-prim . compile)]
|
||||
[printf printf-label (core-prim . printf)]
|
||||
[string=? string=?-label (core-prim . string=?)]
|
||||
[command-line-arguments command-line-arguments-label (core-prim . command-line-arguments)]
|
||||
))
|
||||
(define make-scheme-rib
|
||||
(lambda ()
|
||||
(let ([rib (make-empty-rib)])
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(let ([name (car x)] [label (cadr x)])
|
||||
(extend-rib! rib (stx name top-mark* '()) label)))
|
||||
scheme-env)
|
||||
rib)))
|
||||
(define make-scheme-env
|
||||
(lambda ()
|
||||
(map
|
||||
(lambda (x)
|
||||
(let ([name (car x)] [label (cadr x)] [binding (caddr x)])
|
||||
(cons label binding)))
|
||||
scheme-env)))
|
||||
;;; macros
|
||||
(define add-lexicals
|
||||
(lambda (lab* lex* r)
|
||||
(append (map (lambda (lab lex)
|
||||
(cons lab (cons 'lexical lex)))
|
||||
lab* lex*)
|
||||
r)))
|
||||
(define let-values-transformer
|
||||
(lambda (e r mr)
|
||||
(syntax-match e
|
||||
[(_ ([(fml** ...) rhs*] ...) b b* ...)
|
||||
(let ([rhs* (chi-expr* rhs* r mr)])
|
||||
(let ([lex** (map (lambda (ls) (map gen-lexical ls)) fml**)]
|
||||
[lab** (map (lambda (ls) (map gen-label ls)) fml**)])
|
||||
(let ([fml* (apply append fml**)]
|
||||
[lab* (apply append lab**)]
|
||||
[lex* (apply append lex**)])
|
||||
(let f ([lex** lex**] [rhs* rhs*])
|
||||
(cond
|
||||
[(null? lex**)
|
||||
(chi-internal
|
||||
(add-subst
|
||||
(id/label-rib fml* lab*)
|
||||
(cons b b*))
|
||||
(add-lexicals lab* lex* r)
|
||||
mr)]
|
||||
[else
|
||||
(build-application no-source
|
||||
(build-primref no-source 'call-with-values)
|
||||
(list
|
||||
(build-lambda no-source '() (car rhs*))
|
||||
(build-lambda no-source (car lex**)
|
||||
(f (cdr lex**) (cdr rhs*)))))])))))])))
|
||||
(define let-transformer
|
||||
(lambda (e r mr)
|
||||
(syntax-match e
|
||||
[(_ ([lhs* rhs*] ...) b b* ...)
|
||||
(if (not (valid-bound-ids? lhs*))
|
||||
(stx-error e)
|
||||
(let ([rhs* (chi-expr* rhs* r mr)]
|
||||
[lex* (map gen-lexical lhs*)]
|
||||
[lab* (map gen-label lhs*)])
|
||||
(let ([body (chi-internal
|
||||
(add-subst
|
||||
(id/label-rib lhs* lab*)
|
||||
(cons b b*))
|
||||
(add-lexicals lab* lex* r)
|
||||
mr)])
|
||||
(build-application no-source
|
||||
(build-lambda no-source lex* body)
|
||||
rhs*))))]
|
||||
[(_ loop ([lhs* rhs*] ...) b b* ...)
|
||||
(if (and (id? loop) (valid-bound-ids? lhs*))
|
||||
(let ([rhs* (chi-expr* rhs* r mr)]
|
||||
[lex* (map gen-lexical lhs*)]
|
||||
[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*)
|
||||
(cons b b*)))]
|
||||
[r (add-lexicals
|
||||
(cons looplab lab*)
|
||||
(cons looplex lex*)
|
||||
r)])
|
||||
(let ([body (chi-internal b* r mr)])
|
||||
(build-letrec no-source
|
||||
(list looplex)
|
||||
(list (build-lambda no-source lex* body))
|
||||
(build-application no-source
|
||||
looplex rhs*)))))
|
||||
(stx-error e))])))
|
||||
(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 (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 (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
|
||||
(lambda (e r mr)
|
||||
(syntax-match e
|
||||
[(_ datum) (build-data no-source (strip datum '()))])))
|
||||
(define core-macro-transformer
|
||||
(lambda (name)
|
||||
(case name
|
||||
[(quote) quote-transformer]
|
||||
[(let-values) let-values-transformer]
|
||||
[(let) let-transformer]
|
||||
[(cond) cond-transformer]
|
||||
[else (error 'macro-transformer "cannot find ~s" name)])))
|
||||
;;; chi procedures
|
||||
(define chi-expr*
|
||||
(lambda (e* r mr)
|
||||
(map (lambda (e) (chi-expr e r mr)) e*)))
|
||||
(define chi-expr
|
||||
(lambda (e r mr)
|
||||
(let-values ([(type value kwd) (syntax-type e r)])
|
||||
(case type
|
||||
[(core-macro)
|
||||
(let ([transformer (core-macro-transformer value)])
|
||||
(transformer e r mr))]
|
||||
[(core-prim)
|
||||
(let ([name value])
|
||||
(build-primref no-source name))]
|
||||
[(call)
|
||||
(syntax-match e
|
||||
[(rator rands ...)
|
||||
(build-application no-source
|
||||
(chi-expr rator r mr)
|
||||
(chi-expr* rands r mr))])]
|
||||
[(lexical)
|
||||
(let ([lex value])
|
||||
(build-lexical-reference no-source lex))]
|
||||
[(constant)
|
||||
(let ([datum value])
|
||||
(build-data no-source datum))]
|
||||
[else (error 'chi-expr "invalid type ~s for ~s" type
|
||||
(strip e '())) (stx-error e)]))))
|
||||
(define chi-internal
|
||||
(lambda (e* r mr)
|
||||
(define return
|
||||
(lambda (init* r mr lhs* lex* rhs*)
|
||||
(unless (valid-bound-ids? lhs*)
|
||||
(error 'chi-internal "multiple definitions"))
|
||||
(let ([rhs* (chi-expr* rhs* r mr)]
|
||||
[init* (chi-expr* init* r mr)])
|
||||
(build-letrec no-source
|
||||
(reverse lex*) (reverse rhs*)
|
||||
(build-sequence no-source init*)))))
|
||||
(let* ([rib (make-empty-rib)]
|
||||
[e* (map (lambda (x) (add-subst rib x))
|
||||
(syntax->list e*))])
|
||||
(let f ([e* e*] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* '()])
|
||||
(cond
|
||||
[(null? e*) (error 'chi-internal "empty body")]
|
||||
[else
|
||||
(let ([e (car e*)])
|
||||
(let-values ([(type value kwd) (syntax-type e r)])
|
||||
(let ([kwd* (cons kwd kwd*)])
|
||||
(case type
|
||||
[(define)
|
||||
(let-values ([(id rhs) (parse-define e)])
|
||||
(when (bound-id-member? id kwd*)
|
||||
(stx-error id "undefined identifier"))
|
||||
(let ([lex (gen-lexical id)]
|
||||
[label (gen-label)])
|
||||
(extend-rib! rib id label)
|
||||
(f (cdr e*)
|
||||
(cons (cons label (cons 'lexical lex)) r)
|
||||
mr
|
||||
(cons id lhs*)
|
||||
(cons lex lex*)
|
||||
(cons rhs rhs*)
|
||||
kwd*)))]
|
||||
[else
|
||||
(return e* r mr lhs* lex* rhs*)]))))])))))
|
||||
(define chi-library-internal
|
||||
(lambda (e* r rib)
|
||||
(define return
|
||||
(lambda (init* r mr lhs* rhs*)
|
||||
(values init* r mr (reverse lhs*) (reverse rhs*))))
|
||||
(let f ([e* e*] [r r] [mr r] [lhs* '()] [rhs* '()] [kwd* '()])
|
||||
(cond
|
||||
[(null? e*) (return e* r mr lhs* rhs*)]
|
||||
[else
|
||||
(let ([e (car e*)])
|
||||
(let-values ([(type value kwd) (syntax-type e r)])
|
||||
(let ([kwd* (cons kwd kwd*)])
|
||||
(case type
|
||||
[(define)
|
||||
(let-values ([(id rhs) (parse-define e)])
|
||||
(when (bound-id-member? id kwd*)
|
||||
(stx-error id "undefined identifier"))
|
||||
(let ([lexical (gen-lexical (id->sym id))]
|
||||
[label (gen-label)])
|
||||
(extend-rib! rib id label)
|
||||
(f (cdr e*) r mr (cons id lhs*) (cons rhs rhs*)
|
||||
kwd*)))]
|
||||
[else
|
||||
(return e* r mr lhs* rhs*)]))))]))))
|
||||
(define chi-top-library
|
||||
(lambda (e)
|
||||
(let-values ([(name exp* b*) (parse-library e)])
|
||||
(let ([rib (make-scheme-rib)]
|
||||
[r (make-scheme-env)])
|
||||
(let ([b* (map (lambda (x) (stx x top-mark* (list rib))) b*)])
|
||||
(let-values ([(init* r mr lhs* rhs*)
|
||||
(chi-library-internal b* r rib)])
|
||||
(unless (null? lhs*)
|
||||
(error who "cannot handle definitions yet"))
|
||||
(if (null? init*)
|
||||
(chi-void)
|
||||
(build-sequence no-source
|
||||
(chi-expr* init* r mr)))))))))
|
||||
(lambda (x)
|
||||
(let ([x (chi-top-library x)])
|
||||
(pretty-print x)
|
||||
x))
|
||||
))
|
||||
Loading…
Reference in New Issue