imported compiler3
This commit is contained in:
Abdulaziz Ghuloum
parent
bd94bedc04
commit
03e9649064
|
|
@ -2,7 +2,7 @@
|
|||
all: ikarus.fasl
|
||||
|
||||
ikarus.fasl:
|
||||
echo '(load "compiler-6.1.ss")' | petite
|
||||
echo '(load "compiler-6.2.ss")' | petite
|
||||
|
||||
clean:
|
||||
rm -f *.fasl
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
2006-07-28
|
||||
2006-08-02
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@
|
|||
(define scheme-library-files
|
||||
'(["libhandlers-6.0.ss" "libhandlers.fasl"]
|
||||
["libcontrol-6.1.ss" "libcontrol.fasl"]
|
||||
["libcollect-6.0.ss" "libcollect.fasl"]
|
||||
["libcollect-6.1.ss" "libcollect.fasl"]
|
||||
["librecord-6.1.ss" "librecord.fasl"]
|
||||
["libcxr-6.0.ss" "libcxr.fasl"]
|
||||
["libcore-6.1.ss" "libcore.fasl"]
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
BIN
src/ikarus.fasl
BIN
src/ikarus.fasl
Binary file not shown.
|
|
@ -7,7 +7,7 @@
|
|||
(let ([code-size (fxsll (fxsra (fx+ code-size 3) 2) 2)])
|
||||
(make-code
|
||||
closure-size
|
||||
(make-string code-size)
|
||||
(make-string code-size (integer->char 0))
|
||||
(make-vector (fxsra reloc-size 2)))))))
|
||||
|
||||
(define set-code-byte!
|
||||
|
|
|
|||
BIN
src/libcafe.fasl
BIN
src/libcafe.fasl
Binary file not shown.
|
|
@ -0,0 +1,36 @@
|
|||
|
||||
;(primitive-set! 'do-overflow
|
||||
; (lambda ()
|
||||
; ($do-overflow 4096)))
|
||||
|
||||
(primitive-set! 'do-overflow
|
||||
(lambda (n)
|
||||
(foreign-call "ik_collect" n)
|
||||
(void)))
|
||||
|
||||
(primitive-set! 'do-overflow-words
|
||||
(lambda (n)
|
||||
(foreign-call "ik_collect" ($fxsll n 2))
|
||||
(void)))
|
||||
|
||||
(primitive-set! 'do-vararg-overflow
|
||||
(lambda (n)
|
||||
(foreign-call "ik_collect_vararg" n)
|
||||
(void)))
|
||||
|
||||
(primitive-set! 'collect
|
||||
(lambda ()
|
||||
(do-overflow 4096)))
|
||||
|
||||
(primitive-set! 'do-stack-overflow
|
||||
(lambda ()
|
||||
(foreign-call "ik_stack_overflow")))
|
||||
|
||||
(primitive-set! 'dump-metatable
|
||||
(lambda ()
|
||||
(foreign-call "ik_dump_metatable")))
|
||||
|
||||
(primitive-set! 'dump-dirty-vector
|
||||
(lambda ()
|
||||
(foreign-call "ik_dump_dirty_vector")))
|
||||
|
||||
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
BIN
src/libcore.fasl
BIN
src/libcore.fasl
Binary file not shown.
BIN
src/libcxr.fasl
BIN
src/libcxr.fasl
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
|
|
@ -189,22 +189,22 @@
|
|||
[else (error 'fasl-write "unrecognized reloc ~s" b)]
|
||||
)))))]
|
||||
[else (error 'fasl-write "~s is not fasl-writable" x)])]))))
|
||||
(define do-fasl-write
|
||||
(lambda (x port)
|
||||
(let ([h (make-hash-table)])
|
||||
(make-graph x h)
|
||||
(write-char #\# port)
|
||||
(write-char #\@ port)
|
||||
(write-char #\I port)
|
||||
(write-char #\K port)
|
||||
(write-char #\0 port)
|
||||
(write-char #\1 port)
|
||||
(fasl-write x port h 1))))
|
||||
(primitive-set! 'fasl-write
|
||||
(lambda (x . rest)
|
||||
(let ([port
|
||||
(if (null? rest)
|
||||
(current-output-port)
|
||||
(let ([a (car rest)])
|
||||
(unless (output-port? a)
|
||||
(error 'fasl-write "~s is not an output port" a))
|
||||
a))])
|
||||
(let ([h (make-hash-table)])
|
||||
(make-graph x h)
|
||||
(write-char #\# port)
|
||||
(write-char #\@ port)
|
||||
(write-char #\I port)
|
||||
(write-char #\K port)
|
||||
(write-char #\0 port)
|
||||
(write-char #\1 port)
|
||||
(fasl-write x port h 1))))))
|
||||
(case-lambda
|
||||
[(x) (do-fasl-write x (current-output-port))]
|
||||
[(x port)
|
||||
(unless (output-port? port)
|
||||
(error 'fasl-write "~s is not an output port" port))
|
||||
(do-fasl-write x port)])))
|
||||
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -0,0 +1,200 @@
|
|||
|
||||
(let ([hash-rtd (make-record-type '"hash-table" '(hash-vec count tc))])
|
||||
;;; accessors
|
||||
(define get-vec (record-field-accessor hash-rtd 0))
|
||||
(define set-vec! (record-field-mutator hash-rtd 0))
|
||||
(define get-count (record-field-accessor hash-rtd 1))
|
||||
(define set-count! (record-field-mutator hash-rtd 1))
|
||||
(define get-tc (record-field-accessor hash-rtd 2))
|
||||
;;; implementation
|
||||
|
||||
;;; directly from Dybvig's
|
||||
(define tc-pop
|
||||
(lambda (tc)
|
||||
(let ([x ($car tc)])
|
||||
(if (eq? x ($cdr tc))
|
||||
#f
|
||||
(let ([v ($car x)])
|
||||
($set-car! tc ($cdr x))
|
||||
($set-car! x #f)
|
||||
($set-cdr! x #f)
|
||||
v)))))
|
||||
|
||||
(define inthash
|
||||
(lambda (key)
|
||||
;static int inthash(int key) {
|
||||
; key += ~(key << 15);
|
||||
; key ^= (key >> 10);
|
||||
; key += (key << 3);
|
||||
; key ^= (key >> 6);
|
||||
; key += ~(key << 11);
|
||||
; key ^= (key >> 16);
|
||||
; return key;
|
||||
;}
|
||||
(let* ([key ($fx+ key ($fxlognot ($fxsll key 15)))]
|
||||
[key ($fxlogxor key ($fxsra key 10))]
|
||||
[key ($fx+ key ($fxsll key 3))]
|
||||
[key ($fxlogxor key ($fxsra key 6))]
|
||||
[key ($fx+ key ($fxlognot ($fxsll key 11)))]
|
||||
[key ($fxlogxor key ($fxsra key 16))])
|
||||
key)))
|
||||
|
||||
;;; assq-like lookup
|
||||
(define direct-lookup
|
||||
(lambda (x b)
|
||||
(if (fixnum? b)
|
||||
#f
|
||||
(if (eq? x ($tcbucket-key b))
|
||||
b
|
||||
(direct-lookup x ($tcbucket-next b))))))
|
||||
|
||||
(define rehash-lookup
|
||||
(lambda (h tc x)
|
||||
(cond
|
||||
[(tc-pop tc) =>
|
||||
(lambda (b)
|
||||
(re-add! h b)
|
||||
(if (eq? x ($tcbucket-key b))
|
||||
b
|
||||
(rehash-lookup h tc x)))]
|
||||
[else #f])))
|
||||
|
||||
(define get-bucket-index
|
||||
(lambda (b)
|
||||
(let ([next ($tcbucket-next b)])
|
||||
(if (fixnum? next)
|
||||
next
|
||||
(get-bucket-index next)))))
|
||||
|
||||
(define replace!
|
||||
(lambda (lb x y)
|
||||
(let ([n ($tcbucket-next lb)])
|
||||
(cond
|
||||
[(eq? n x)
|
||||
($set-tcbucket-next! lb y)
|
||||
(void)]
|
||||
[else
|
||||
(replace! n x y)]))))
|
||||
|
||||
(define re-add!
|
||||
(lambda (h b)
|
||||
(let ([vec (get-vec h)]
|
||||
[next ($tcbucket-next b)])
|
||||
;;; first remove it from its old place
|
||||
(let ([idx
|
||||
(if (fixnum? next)
|
||||
next
|
||||
(get-bucket-index next))])
|
||||
(let ([fst ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(eq? fst b)
|
||||
($vector-set! vec idx next)]
|
||||
[else
|
||||
(replace! fst b next)])))
|
||||
;;; then add it to the new place
|
||||
(let ([k ($tcbucket-key b)])
|
||||
(let ([ih (inthash (pointer-value k))])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([n ($vector-ref vec idx)])
|
||||
($set-tcbucket-next! b n)
|
||||
($vector-set! vec idx b)
|
||||
($set-tcbucket-tconc! b (get-tc h))
|
||||
(void))))))))
|
||||
|
||||
(define get-hash
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (get-vec h)])
|
||||
(let ([ih (inthash pv)])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($tcbucket-val b))]
|
||||
[else v])))))))
|
||||
|
||||
(define put-hash!
|
||||
(lambda (h x v)
|
||||
(let ([pv (pointer-value x)]
|
||||
[vec (get-vec h)])
|
||||
(let ([ih (inthash pv)])
|
||||
(let ([idx ($fxlogand ih ($fx- ($vector-length vec) 1))])
|
||||
(let ([b ($vector-ref vec idx)])
|
||||
(cond
|
||||
[(or (direct-lookup x b) (rehash-lookup h (get-tc h) x))
|
||||
=>
|
||||
(lambda (b)
|
||||
($set-tcbucket-val! b v)
|
||||
(void))]
|
||||
[else
|
||||
($vector-set! vec idx
|
||||
($make-tcbucket (get-tc h) x v
|
||||
($vector-ref vec idx)))
|
||||
(let ([ct (get-count h)])
|
||||
(set-count! h ($fxadd1 ct))
|
||||
(when ($fx> ct ($vector-length vec))
|
||||
(enlarge-table h)))])))))))
|
||||
|
||||
(define insert-b
|
||||
(lambda (b vec mask)
|
||||
(let* ([x ($tcbucket-key b)]
|
||||
[pv (pointer-value x)]
|
||||
[ih (inthash pv)]
|
||||
[idx ($fxlogand ih mask)]
|
||||
[next ($tcbucket-next b)])
|
||||
($set-tcbucket-next! b ($vector-ref vec idx))
|
||||
($vector-set! vec idx b)
|
||||
(unless (fixnum? next)
|
||||
(insert-b next vec mask)))))
|
||||
|
||||
(define move-all
|
||||
(lambda (vec1 i n vec2 mask)
|
||||
(unless ($fx= i n)
|
||||
(let ([b ($vector-ref vec1 i)])
|
||||
(unless (fixnum? b)
|
||||
(insert-b b vec2 mask))
|
||||
(move-all vec1 ($fxadd1 i) n vec2 mask)))))
|
||||
|
||||
(define enlarge-table
|
||||
(lambda (h)
|
||||
(let* ([vec1 (get-vec h)]
|
||||
[n1 ($vector-length vec1)]
|
||||
[n2 ($fxsll n1 1)]
|
||||
[vec2 (make-base-vec n2)])
|
||||
(move-all vec1 0 n1 vec2 ($fx- n2 1))
|
||||
(set-vec! h vec2))))
|
||||
|
||||
|
||||
|
||||
(define init-vec
|
||||
(lambda (v i n)
|
||||
(if ($fx= i n)
|
||||
v
|
||||
(begin
|
||||
($vector-set! v i i)
|
||||
(init-vec v ($fxadd1 i) n)))))
|
||||
|
||||
(define make-base-vec
|
||||
(lambda (n)
|
||||
(init-vec (make-vector n) 0 n)))
|
||||
|
||||
;;; public interface
|
||||
(primitive-set! 'hash-table? (record-predicate hash-rtd))
|
||||
(primitive-set! 'make-hash-table
|
||||
(let ([make (record-constructor hash-rtd)])
|
||||
(lambda ()
|
||||
(let ([x (cons #f #f)])
|
||||
(let ([tc (cons x x)])
|
||||
(make (make-base-vec 32) 0 tc))))))
|
||||
(primitive-set! 'get-hash-table
|
||||
(lambda (h x v)
|
||||
(if (hash-table? h)
|
||||
(get-hash h x v)
|
||||
(error 'get-hash-table "~s is not a hash table" h))))
|
||||
(primitive-set! 'put-hash-table!
|
||||
(lambda (h x v)
|
||||
(if (hash-table? h)
|
||||
(put-hash! h x v)
|
||||
(error 'put-hash-table! "~s is not a hash table" h)))))
|
||||
|
|
@ -32,6 +32,7 @@
|
|||
;;; ret
|
||||
;;; sall
|
||||
;;; sarl
|
||||
;;; shrl
|
||||
;;; sete
|
||||
;;; setg
|
||||
|
||||
|
|
@ -110,6 +111,7 @@
|
|||
[subl s d]
|
||||
[sall s d]
|
||||
[sarl s d]
|
||||
[shrl s d]
|
||||
[andl s d]
|
||||
[xorl s d]
|
||||
[orl s d]
|
||||
|
|
@ -499,6 +501,17 @@
|
|||
[(and (eq? src '%cl) (reg? dst))
|
||||
(CODE #xD3 (ModRM 3 '/4 dst ac))]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(shrl)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
(cond
|
||||
[(and (equal? '(int 1) src) (reg? dst))
|
||||
(CODE #xD1 (ModRM 3 '/5 dst ac))]
|
||||
[(and (imm8? src) (reg? dst))
|
||||
(CODE #xC1 (ModRM 3 '/5 dst (IMM8 src ac)))]
|
||||
[(and (eq? src '%cl) (reg? dst))
|
||||
(CODE #xD3 (ModRM 3 '/5 dst ac))]
|
||||
[else (error who "invalid ~s" a)])))]
|
||||
[(sarl)
|
||||
(with-args a
|
||||
(lambda (src dst)
|
||||
|
|
|
|||
Binary file not shown.
BIN
src/libio.fasl
BIN
src/libio.fasl
Binary file not shown.
Binary file not shown.
|
|
@ -0,0 +1,534 @@
|
|||
|
||||
;;; 6.2: initial syncase implementation
|
||||
;;;
|
||||
|
||||
|
||||
;;; Expand : Scheme -> Core Scheme
|
||||
;;;
|
||||
;;; <CS> ::= (quote datum)
|
||||
;;; | <gensym>
|
||||
;;; | (if <CS> <CS> <CS>)
|
||||
;;; | (set! <gensym> <CS>)
|
||||
;;; | (begin <CS> <CS> ...)
|
||||
;;; | (letrec ([<gensym> <CS>] ...) <CS> <CS> ...)
|
||||
;;; | (lambda <FMLS> <CS> <CS> ...)
|
||||
;;; | (<prim> <CS> <CS> ...)
|
||||
;;; | (#primitive| <primname>)
|
||||
;;; | (<CS> <CS> ...)
|
||||
;;; <FML> ::= ()
|
||||
;;; | <gensym>
|
||||
;;; | (<gensym> . <FML>)
|
||||
;;; <prim> ::= void | memv | top-level-value | set-top-level-value!
|
||||
;;; | primitive-set! | foreign-call | $apply
|
||||
|
||||
(let ([*stx* (make-record-type "*stx*" '(e marks ribcage))]
|
||||
[*rib* (make-record-type "*rib*" '(sym* marks* lab*))]
|
||||
[*top* (make-record-type "*top*" '())])
|
||||
|
||||
(define stx? (record-predicate *stx*))
|
||||
(define make-stx (record-constructor *stx*))
|
||||
(define stx-e (record-field-accessor *stx* 'e))
|
||||
(define stx-marks (record-field-accessor *stx* 'marks))
|
||||
(define stx-ribcage (record-field-accessor *stx* 'ribcage))
|
||||
(define make-rib (record-constructor *rib*))
|
||||
(define rib-sym* (record-field-accessor *rib* 'sym*))
|
||||
(define rib-marks* (record-field-accessor *rib* 'marks*))
|
||||
(define rib-lab* (record-field-accessor *rib* 'lab*))
|
||||
(define *top-ribcage* ((record-constructor *top*)))
|
||||
(define (top? x) (eq? x *top-ribcage*))
|
||||
(define *syncase-macro* (gensym "*syncase-macro*"))
|
||||
|
||||
(define (build-data x) `(quote ,x))
|
||||
(define (build-global-ref x) `(top-level-value ',x))
|
||||
(define (build-lexical-ref x) x)
|
||||
(define (build-app a d) `(,a . ,d))
|
||||
(define (build-lambda fml* body)
|
||||
(cond
|
||||
[(and (pair? body) (eq? (car body) 'begin))
|
||||
`(lambda ,fml* . ,(cdr body))]
|
||||
[else
|
||||
`(lambda ,fml* ,body)]))
|
||||
(define (build-begin body*) `(begin . ,body*))
|
||||
|
||||
|
||||
(define (build-void) `(void))
|
||||
(define (build-if e0 e1 e2) `(if ,e0 ,e1 ,e2))
|
||||
(define (build-foreign-call e e*) `(foreign-call ,e ,e*))
|
||||
|
||||
|
||||
|
||||
(define (id? x)
|
||||
(and (stx? x)
|
||||
(symbol? (stx-e x))))
|
||||
|
||||
(define (stx->datum x) ;;;; use strip
|
||||
(cond
|
||||
[(stx? x) (stx-e x)]
|
||||
[else x]))
|
||||
|
||||
(define (stx-pair? x)
|
||||
(and (stx? x)
|
||||
(pair? (stx-e x))))
|
||||
|
||||
(define (strip x)
|
||||
(cond
|
||||
[(stx? x) (stx-e x)]
|
||||
[else x]))
|
||||
|
||||
(define label? string?)
|
||||
|
||||
(define (eqmarks? m1* m2*)
|
||||
(cond
|
||||
[(null? m1*) (null? m2*)]
|
||||
[(memq (car m1*) m2*) (eqmarks? (cdr m1*) (remq (car m1*) m2*))]
|
||||
[else #f]))
|
||||
|
||||
(define (rib-lookup sym m* sym* m** lab*)
|
||||
(and (pair? sym*)
|
||||
(if (and (eq? sym (car sym*))
|
||||
(eqmarks? m* (car m**)))
|
||||
(car lab*)
|
||||
(rib-lookup sym m* (cdr sym*) (cdr m**) (cdr lab*)))))
|
||||
|
||||
(define (ribcage-lookup sym m* rc)
|
||||
(cond
|
||||
[(pair? rc)
|
||||
(let ([r (car rc)])
|
||||
(cond
|
||||
[(eq? r 'shift)
|
||||
(ribcage-lookup sym (cdr m*) (cdr rc))]
|
||||
[else
|
||||
(or (rib-lookup sym m* (rib-sym* r) (rib-marks* r) (rib-lab* r))
|
||||
(ribcage-lookup sym m* (cdr rc)))]))]
|
||||
[(top? rc) #f]
|
||||
[else (error "BUG1")]))
|
||||
|
||||
(define (resolve x)
|
||||
(unless (id? x) (error "BUG2"))
|
||||
(let ([sym (stx-e x)]
|
||||
[m* (stx-marks x)]
|
||||
[rc (stx-ribcage x)])
|
||||
(or (ribcage-lookup sym m* rc) ; bound -> label
|
||||
(getprop sym *syncase-macro*) ; top-level-macros -> pair
|
||||
sym ; global -> symbol
|
||||
)))
|
||||
|
||||
(define (remove-last ls)
|
||||
(let ([d (cdr ls)])
|
||||
(cond
|
||||
[(null? d) '()]
|
||||
[else (cons (car ls) (remove-last d))])))
|
||||
|
||||
(define (unshift rc)
|
||||
(cond
|
||||
[(pair? rc)
|
||||
(if (eq? (car rc) 'shift)
|
||||
(cdr rc)
|
||||
(cons (car rc) (unshift (cdr rc))))]
|
||||
[else (error "BUG3: missing shift")]))
|
||||
|
||||
(define (push-wrap m r x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(let ([xm (stx-marks x)])
|
||||
(cond
|
||||
[(and (pair? xm) (eq? (car xm) #f))
|
||||
(make-stx (stx-e x)
|
||||
(append (remove-last m) (cdr xm))
|
||||
(unshift (append r (stx-ribcage x))))]
|
||||
[else
|
||||
(make-stx (stx-e x)
|
||||
(append m xm)
|
||||
(append r (stx-ribcage x)))]))]
|
||||
[else (make-stx x m r)]))
|
||||
|
||||
(define (push-subst sym* marks* lab* x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(make-stx (stx-e x)
|
||||
(stx-marks x)
|
||||
(cons (make-rib sym* marks* lab*) (stx-ribcage x)))]
|
||||
[else
|
||||
(make-stx x
|
||||
'()
|
||||
(cons (make-rib sym* marks* lab*) '()))]))
|
||||
|
||||
(define (push-antimark x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(make-stx (stx-e x)
|
||||
(cons #f (stx-marks x))
|
||||
(stx-ribcage x))]
|
||||
[else (make-stx x (cons #f '()) '())]))
|
||||
|
||||
(define (push-mark m x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(let ([m* (stx-marks x)])
|
||||
(cond
|
||||
[(and (pair? m*) (eq? (car m*) #f))
|
||||
(make-stx (stx-e x) (cdr m*) (stx-ribcage x))]
|
||||
[else
|
||||
(make-stx (stx-e x) (cons m m*) (cons 'shift (stx-ribcage x)))]))]
|
||||
[else
|
||||
(make-stx x (list m) '(shift))]))
|
||||
|
||||
(define (push-rib rib x)
|
||||
(cond
|
||||
[(stx? x)
|
||||
(make-stx (stx-e x) (stx-marks x) (cons rib (stx-ribcage x)))]
|
||||
[else (make-stx x '() (list rib))]))
|
||||
|
||||
(define (expose-stx x)
|
||||
(let ([e (stx-e x)])
|
||||
(cond
|
||||
[(pair? e)
|
||||
(let ([m (stx-marks x)]
|
||||
[r (stx-ribcage x)])
|
||||
(cons
|
||||
(push-wrap m r (car e))
|
||||
(push-wrap m r (cdr e))))]
|
||||
[(vector? e)
|
||||
(let ([m (stx-marks x)]
|
||||
[r (stx-ribcage x)])
|
||||
(list->vector
|
||||
(map (lambda (x) (push-wrap m r x))
|
||||
(vector->list e))))]
|
||||
[(null? e) e]
|
||||
[else x])))
|
||||
|
||||
(define (expose x)
|
||||
(cond
|
||||
[(stx? x) (expose-stx x)]
|
||||
[else x]))
|
||||
|
||||
(define (expose-ls ox)
|
||||
(let loop ([x (expose ox)])
|
||||
(cond
|
||||
[(pair? x) (cons (car x) (loop (expose (cdr x))))]
|
||||
[(null? x) '()]
|
||||
[else (error 'expose-ls "BUG: not a list: ~s" x)])))
|
||||
|
||||
(define (expose* x)
|
||||
(cond
|
||||
[(id? x) x]
|
||||
[(stx? x) (expose* (expose x))]
|
||||
[(pair? x) (cons (expose* (car x)) (expose* (cdr x)))]
|
||||
[(vector? x)
|
||||
(list->vector (map expose* (vector->list x)))]
|
||||
[else x]))
|
||||
|
||||
(define (lookup lab r)
|
||||
(define (lookup1 lab lab* g*)
|
||||
(cond
|
||||
[(null? lab*) #f]
|
||||
[(eq? lab (car lab*)) (car g*)]
|
||||
[else (lookup1 lab (cdr lab*) (cdr g*))]))
|
||||
(cond
|
||||
[(null? r) #f]
|
||||
[(eq? (car r) 'lexical-barrier)
|
||||
(let ([v (lookup lab (cdr r))])
|
||||
(cond
|
||||
[(not (symbol? v)) v]
|
||||
[else #f]))]
|
||||
[else
|
||||
(or (lookup1 lab (caar r) (cdar r))
|
||||
(lookup lab (cdr r)))]))
|
||||
|
||||
(define (genmark) (gensym "M"))
|
||||
(define (newsym x)
|
||||
(gensym))
|
||||
;(gensym (symbol->string x)))
|
||||
|
||||
(define (apply-macro proc x r)
|
||||
(expand-ctx (push-mark (genmark) (proc (push-antimark x))) r))
|
||||
|
||||
(define (identifier-macro? x r)
|
||||
(and (id? x)
|
||||
(let ([a (resolve x)])
|
||||
(or (and (label? a)
|
||||
(let ([a (lookup a r)])
|
||||
(and (procedure? a) a)))
|
||||
(and (pair? a)
|
||||
(eq? (car a) '*user-macro*)
|
||||
(cdr a))))))
|
||||
|
||||
(define (macro-call? x r)
|
||||
(if (id? x)
|
||||
(identifier-macro? x r)
|
||||
(let ([x (expose x)])
|
||||
(and (pair? x)
|
||||
(identifier-macro? (car x) r)))))
|
||||
|
||||
(define (core? x)
|
||||
(and (pair? x) (eq? (car x) '*core-macro*)))
|
||||
|
||||
(define (apply-core-form a d ctx r)
|
||||
(unless (core? a) (syntax-error ctx))
|
||||
((cdr a) a d ctx r))
|
||||
|
||||
(define (E* d r ctx)
|
||||
(let ([d (expose-ls d)])
|
||||
(map (lambda (x) (E x r)) d)))
|
||||
|
||||
(define (extend-core name proc)
|
||||
(putprop name *syncase-macro* (cons '*core-macro* proc)))
|
||||
|
||||
(define (extend-user-macro name proc)
|
||||
(putprop name *syncase-macro* (cons '*user-macro* proc)))
|
||||
|
||||
(define (E ctx r)
|
||||
(let ([x (expose ctx)])
|
||||
(cond
|
||||
[(macro-call? x r) =>
|
||||
(lambda (proc)
|
||||
(apply-macro proc ctx r))]
|
||||
[(pair? x)
|
||||
(let ([a (car x)] [d (cdr x)])
|
||||
(cond
|
||||
[(id? a)
|
||||
(let ([a (resolve a)])
|
||||
(cond
|
||||
[(label? a)
|
||||
(cond
|
||||
[(lookup a r) =>
|
||||
(lambda (g)
|
||||
(cond
|
||||
[(symbol? g)
|
||||
(build-app (build-lexical-ref g)
|
||||
(E* d r ctx))]
|
||||
[(and (pair? g) (eq? (car g) 'pat))
|
||||
(syntax-error ctx)]
|
||||
[else (error 'expand "BUG4")]))]
|
||||
[else (syntax-error ctx)])]
|
||||
[(core? a)
|
||||
(apply-core-form a d ctx r)]
|
||||
[(symbol? a)
|
||||
(build-app (build-global-ref a)
|
||||
(E* d r ctx))]
|
||||
[else (syntax-error ctx)]))]
|
||||
[else
|
||||
(build-app
|
||||
(E a r)
|
||||
(E* d r ctx))]))]
|
||||
[(id? x)
|
||||
(let ([a (resolve x)])
|
||||
(cond
|
||||
[(label? a)
|
||||
(cond
|
||||
[(lookup a r) =>
|
||||
(lambda (g)
|
||||
(cond
|
||||
[(symbol? g) (build-lexical-ref g)]
|
||||
[(and (pair? g) (eq? (car g) 'pat))
|
||||
(syntax-error ctx)]
|
||||
[else (error 'expand "BUG5")]))]
|
||||
[else (syntax-error ctx)])]
|
||||
[(core? a) (syntax-error ctx)]
|
||||
[(symbol? a)
|
||||
(build-global-ref a)]
|
||||
[else (syntax-error ctx)]))]
|
||||
[else (build-data (strip x))])))
|
||||
|
||||
(define (core-expand x)
|
||||
(E (make-stx x '() *top-ribcage*) '()))
|
||||
|
||||
(define (process-fml* bind* ctx)
|
||||
(define (assert-no-dups s m* s* m**)
|
||||
(unless (null? s*)
|
||||
(when (and (eq? s (car s*))
|
||||
(eqmarks? m* (car m**)))
|
||||
(syntax-error ctx))
|
||||
(assert-no-dups s m* (cdr s*) (cdr m*))))
|
||||
(let loop ([bind* (expose bind*)])
|
||||
(cond
|
||||
[(null? bind*) (values '() '() '() '() '())]
|
||||
[(pair? bind*)
|
||||
(let ([b (car bind*)])
|
||||
(unless (id? b) (syntax-error ctx))
|
||||
(let-values ([(fml* s* m** g* lab*)
|
||||
(loop (expose (cdr bind*)))])
|
||||
(let ([s (stx-e b)] [m* (stx-marks b)])
|
||||
(assert-no-dups s m* s* m**)
|
||||
(let ([lab (string #\i)] [g (newsym s)])
|
||||
(values (cons g fml*)
|
||||
(cons s s*)
|
||||
(cons m* m**)
|
||||
(cons g g*)
|
||||
(cons lab lab*))))))]
|
||||
[else (syntax-error ctx)])))
|
||||
|
||||
(define (top-level-macro? x r sym)
|
||||
(let ([x (expose x)])
|
||||
(and (pair? x)
|
||||
(id? (car x))
|
||||
(let ([loc (resolve (car x))])
|
||||
(and (or (and (pair? loc)
|
||||
(eq? (car loc) '*core-macro*))
|
||||
(symbol? loc))
|
||||
(eq? (stx->datum (car x)) sym))))))
|
||||
|
||||
(define (define? x r)
|
||||
(top-level-macro? x r 'define))
|
||||
|
||||
(define (begin? x r)
|
||||
(top-level-macro? x r 'begin))
|
||||
|
||||
(define (begin-e* x ctx)
|
||||
(let ([x (expose x)])
|
||||
(let loop ([x (expose (cdr x))])
|
||||
(cond
|
||||
[(null? x) '()]
|
||||
[(pair? x) (cons (car x) (loop (expose (cdr x))))]
|
||||
[else (syntax-error ctx)]))))
|
||||
|
||||
(define (expand-body* body* ctx r)
|
||||
(let ([rib (make-rib '() '() '())])
|
||||
(let loop ([body* (expose (push-rib rib body*))]
|
||||
[r r]
|
||||
[lab* '()] [sym* '()] [marks* '()] [vrhs* '()])
|
||||
(cond
|
||||
[(null? body*) (syntax-error ctx)]
|
||||
[(pair? body*)
|
||||
(let ([a (car body*)] [d (cdr body*)])
|
||||
(cond
|
||||
[(macro-call? a r) =>
|
||||
(lambda (proc)
|
||||
(loop (cons (push-mark (genmark) (proc (push-antimark a))) d)
|
||||
r lab* sym* marks* vrhs*))]
|
||||
[(define? a r)
|
||||
(let-values ([(lhs rhs) (extract-define a ctx)])
|
||||
(loop (expose d)
|
||||
r
|
||||
(cons (string #\p) lab*)
|
||||
(cons (stx-e lhs) sym*)
|
||||
(cons (stx-marks lhs) marks*)
|
||||
(cons rhs vrhs*)))]
|
||||
[(begin? a r)
|
||||
(loop (expose (append (begin-e* a ctx) d))
|
||||
r lab* sym* marks* vrhs*)]
|
||||
[else
|
||||
;;; done
|
||||
(cond
|
||||
[(null? sym*)
|
||||
(let ([body* (E* body* r ctx)])
|
||||
(build-begin body*))]
|
||||
[else
|
||||
(let ([g* (map newsym sym*)])
|
||||
(let* ([r (cons (cons lab* g*) r)]
|
||||
[rhs*
|
||||
(E* (push-subst sym* marks* lab* vrhs*)
|
||||
r ctx)]
|
||||
[body*
|
||||
(E* (push-subst sym* marks* lab* body*)
|
||||
r ctx)])
|
||||
(build-letrec g* rhs* (build-begin body*))))])]))]
|
||||
[else (syntax-error ctx)]))))
|
||||
|
||||
(define (extract-bindings bind* ctx)
|
||||
(let ([bind* (expose bind*)])
|
||||
(cond
|
||||
[(null? bind*) (values '() '())]
|
||||
[(not (pair? bind*)) (syntax-error ctx)]
|
||||
[else
|
||||
(let ([a (car bind*)] [d (cdr bind*)])
|
||||
(let ([a (expose-ls a)])
|
||||
(cond
|
||||
[(fx= (length a) 2)
|
||||
(let-values ([(lhs* rhs*)
|
||||
(extract-bindings d ctx)])
|
||||
(values (cons (car a) lhs*)
|
||||
(cons (cadr a) rhs*)))]
|
||||
[else (syntax-error ctx)])))])))
|
||||
|
||||
(define (core-stx x)
|
||||
(make-stx x '() *top-ribcage*))
|
||||
|
||||
(extend-core 'quote
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose-ls d)])
|
||||
(cond
|
||||
[(and (list? d) (fx= (length d) 1))
|
||||
(build-data (strip (car d)))]
|
||||
[else (syntax-error ctx)]))))
|
||||
|
||||
(extend-core 'lambda
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose d)])
|
||||
(cond
|
||||
[(pair? d)
|
||||
(let ([fml* (car d)] [body* (cdr d)])
|
||||
(let-values ([(fml* s* m** g* lab*)
|
||||
(process-fml* fml* ctx)])
|
||||
(let ([body* (push-subst s* m** lab* body*)])
|
||||
(let ([r (cons (cons lab* g*) r)])
|
||||
(build-lambda fml*
|
||||
(expand-body* body* ctx r))))))]
|
||||
[else (syntax-error ctx)]))))
|
||||
|
||||
(extend-core 'if
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose d)])
|
||||
(unless (pair? d) (syntax-error ctx))
|
||||
(let ([test (car d)] [d (expose (cdr d))])
|
||||
(unless (pair? d) (syntax-error ctx))
|
||||
(let ([conseq (car d)] [d (expose (cdr d))])
|
||||
(let ([altern
|
||||
(cond
|
||||
[(null? d) (build-void)]
|
||||
[(pair? d)
|
||||
(let ([altern (car d)] [d (expose (cdr d))])
|
||||
(cond
|
||||
[(null? d) (E altern r)]
|
||||
[else (syntax-error ctx)]))]
|
||||
[else (syntax-error ctx)])])
|
||||
(build-if (E test r) (E conseq r) altern)))))))
|
||||
|
||||
(extend-core 'begin
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose-ls d)])
|
||||
(when (null? d) (syntax-error ctx))
|
||||
(build-begin (E* d r ctx)))))
|
||||
|
||||
|
||||
(extend-core 'define
|
||||
(lambda (a d ctx r) (syntax-error ctx)))
|
||||
|
||||
(extend-core 'foreign-call
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose-ls d)])
|
||||
(unless (fx>= (length d) 1) (syntax-error ctx))
|
||||
(build-foreign-call
|
||||
(E (car d) r)
|
||||
(E* (cdr d) r ctx)))))
|
||||
|
||||
(extend-core 'let
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose d)])
|
||||
(unless (pair? d) (syntax-error ctx))
|
||||
(let ([bind* (car d)] [body* (cdr d)])
|
||||
(let-values ([(lhs* rhs*)
|
||||
(extract-bindings bind* ctx)])
|
||||
(let ([lambda^ (core-stx 'lambda)])
|
||||
(E `((,lambda^ ,lhs* . ,body*) . ,rhs*) r)))))))
|
||||
|
||||
(extend-core 'let*
|
||||
(lambda (a d ctx r)
|
||||
(let ([d (expose d)])
|
||||
(unless (pair? d) (syntax-error ctx))
|
||||
(let ([bind* (car d)] [body* (cdr d)])
|
||||
(let-values ([(lhs* rhs*)
|
||||
(extract-bindings bind* ctx)])
|
||||
(let ([lambda^ (core-stx 'lambda)])
|
||||
(E (let f ([lhs* lhs*] [rhs* rhs*])
|
||||
(cond
|
||||
[(null? lhs*)
|
||||
`((,lambda^ () . ,body*))]
|
||||
[else
|
||||
`((,lambda^ (,(car lhs*))
|
||||
,(f (cdr lhs*) (cdr rhs*)))
|
||||
,(car rhs*))]))
|
||||
r)))))))
|
||||
|
||||
(set! expand core-expand)
|
||||
)
|
||||
Binary file not shown.
Binary file not shown.
|
|
@ -0,0 +1,373 @@
|
|||
|
||||
;;; 6.2: * added a printer for bwp-objects
|
||||
|
||||
;;; WRITER provides display and write.
|
||||
|
||||
(let ()
|
||||
(define char-table ; first nonprintable chars
|
||||
'#("nul" "soh" "stx" "etx" "eot" "enq" "ack" "bel" "bs" "tab" "newline"
|
||||
"vt" "ff" "return" "so" "si" "dle" "dc1" "dc2" "dc3" "dc4" "nak"
|
||||
"syn" "etb" "can" "em" "sub" "esc" "fs" "gs" "rs" "us" "space"))
|
||||
(define write-character
|
||||
(lambda (x p m)
|
||||
(if m
|
||||
(let ([i ($char->fixnum x)])
|
||||
(write-char #\# p)
|
||||
(cond
|
||||
[(fx< i (vector-length char-table))
|
||||
(write-char #\\ p)
|
||||
(write-char* (vector-ref char-table i) p)]
|
||||
[(fx< i 127)
|
||||
(write-char #\\ p)
|
||||
(write-char x p)]
|
||||
[(fx= i 127)
|
||||
(write-char #\\ p)
|
||||
(write-char* "del" p)]
|
||||
[else
|
||||
(write-char #\+ p)
|
||||
(write-fixnum i p)]))
|
||||
(write-char x p))))
|
||||
(define write-list
|
||||
(lambda (x p m)
|
||||
(cond
|
||||
[(pair? x)
|
||||
(write-char #\space p)
|
||||
(writer (car x) p m)
|
||||
(write-list (cdr x) p m)]
|
||||
[(not (null? x))
|
||||
(write-char #\space p)
|
||||
(write-char #\. p)
|
||||
(write-char #\space p)
|
||||
(writer x p m)])))
|
||||
(define write-vector
|
||||
(lambda (x p m)
|
||||
(write-char #\# p)
|
||||
(write-char #\( p)
|
||||
(let ([n (vector-length x)])
|
||||
(when (fx> n 0)
|
||||
(writer (vector-ref x 0) p m)
|
||||
(letrec ([f
|
||||
(lambda (i)
|
||||
(unless (fx= i n)
|
||||
(write-char #\space p)
|
||||
(writer (vector-ref x i) p m)
|
||||
(f (fxadd1 i))))])
|
||||
(f 1))))
|
||||
(write-char #\) p)))
|
||||
(define write-record
|
||||
(lambda (x p m)
|
||||
(write-char #\# p)
|
||||
(write-char #\[ p)
|
||||
(writer (record-name x) p m)
|
||||
(let ([n (record-length x)])
|
||||
(letrec ([f
|
||||
(lambda (i)
|
||||
(unless (fx= i n)
|
||||
(write-char #\space p)
|
||||
(writer (record-ref x i) p m)
|
||||
(f (fxadd1 i))))])
|
||||
(f 0)))
|
||||
(write-char #\] p)))
|
||||
(define initial?
|
||||
(lambda (c)
|
||||
(or (letter? c) (special-initial? c))))
|
||||
(define letter?
|
||||
(lambda (c)
|
||||
(or (and ($char<= #\a c) ($char<= c #\z))
|
||||
(and ($char<= #\A c) ($char<= c #\Z)))))
|
||||
(define digit?
|
||||
(lambda (c)
|
||||
(and ($char<= #\0 c) ($char<= c #\9))))
|
||||
(define special-initial?
|
||||
(lambda (x)
|
||||
(memq x '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~))))
|
||||
(define subsequent?
|
||||
(lambda (x)
|
||||
(or (initial? x)
|
||||
(digit? x)
|
||||
(special-subsequent? x))))
|
||||
(define special-subsequent?
|
||||
(lambda (x)
|
||||
(memq x '(#\+ #\- #\. #\@))))
|
||||
(define subsequent*?
|
||||
(lambda (str i n)
|
||||
(or ($fx= i n)
|
||||
(and (subsequent? ($string-ref str i))
|
||||
(subsequent*? str ($fxadd1 i) n)))))
|
||||
(define valid-symbol-string?
|
||||
(lambda (str)
|
||||
(or (let ([n ($string-length str)])
|
||||
(and ($fx>= n 1)
|
||||
(initial? ($string-ref str 0))
|
||||
(subsequent*? str 1 n)))
|
||||
(string=? str "+")
|
||||
(string=? str "-")
|
||||
(string=? str "..."))))
|
||||
(define write-symbol-esc-loop
|
||||
(lambda (x i n p)
|
||||
(unless ($fx= i n)
|
||||
(let ([c ($string-ref x i)])
|
||||
(when (memq c '(#\\ #\|))
|
||||
(write-char #\\ p))
|
||||
(write-char c p))
|
||||
(write-symbol-esc-loop x ($fxadd1 i) n p))))
|
||||
(define write-symbol-esc
|
||||
(lambda (x p)
|
||||
(write-char #\| p)
|
||||
(write-symbol-esc-loop x 0 ($string-length x) p)
|
||||
(write-char #\| p)))
|
||||
(define write-symbol
|
||||
(lambda (x p m)
|
||||
(let ([str (symbol->string x)])
|
||||
(if m
|
||||
(if (valid-symbol-string? str)
|
||||
(write-char* str p)
|
||||
(write-symbol-esc str p))
|
||||
(write-char* str p)))))
|
||||
(define write-gensym
|
||||
(lambda (x p m)
|
||||
(cond
|
||||
[(and m (print-gensym))
|
||||
(let ([str (symbol->string x)])
|
||||
(write-char #\# p)
|
||||
(write-char #\{ p)
|
||||
(if (valid-symbol-string? str)
|
||||
(write-char* str p)
|
||||
(write-symbol-esc str p))
|
||||
(write-char #\space p)
|
||||
(write-symbol-esc (gensym->unique-string x) p)
|
||||
(write-char #\} p))]
|
||||
[else (write-symbol x p m)])))
|
||||
(define write-string-escape
|
||||
(lambda (x p)
|
||||
(define loop
|
||||
(lambda (x i n p)
|
||||
(unless (fx= i n)
|
||||
(let ([c (string-ref x i)])
|
||||
(cond
|
||||
[(or ($char= #\" c) ($char= #\\ c))
|
||||
(write-char #\\ p)
|
||||
(write-char c p)]
|
||||
[($char= #\tab c)
|
||||
(write-char #\\ p)
|
||||
(write-char #\t p)]
|
||||
[else
|
||||
(write-char c p)]))
|
||||
(loop x (fxadd1 i) n p))))
|
||||
(write-char #\" p)
|
||||
(loop x 0 (string-length x) p)
|
||||
(write-char #\" p)))
|
||||
(define write-string
|
||||
(lambda (x p m)
|
||||
(if m
|
||||
(write-string-escape x p)
|
||||
(write-char* x p))))
|
||||
(define write-fixnum
|
||||
(lambda (x p)
|
||||
(define loop
|
||||
(lambda (x p)
|
||||
(unless (fxzero? x)
|
||||
(loop (fxquotient x 10) p)
|
||||
(write-char
|
||||
($fixnum->char
|
||||
($fx+ (fxremainder x 10)
|
||||
($char->fixnum #\0)))
|
||||
p))))
|
||||
(cond
|
||||
[(fxzero? x) (write-char #\0 p)]
|
||||
[(fx< x 0)
|
||||
(write-char #\- p)
|
||||
(if (fx= x -536870912)
|
||||
(write-char* "536870912" p)
|
||||
(loop (fx- 0 x) p))]
|
||||
[else (loop x p)])))
|
||||
(define write-char*
|
||||
(lambda (x p)
|
||||
(define loop
|
||||
(lambda (x i n p)
|
||||
(unless (fx= i n)
|
||||
(write-char (string-ref x i) p)
|
||||
(loop x (fxadd1 i) n p))))
|
||||
(loop x 0 (string-length x) p)))
|
||||
(define macro
|
||||
(lambda (x)
|
||||
(define macro-forms
|
||||
'([quote . "'"]
|
||||
[quasiquote . "`"]
|
||||
[unquote . ","]
|
||||
[unquote-splicing . ",@"]
|
||||
[syntax . "#'"]
|
||||
[|#primitive| . "#%"]))
|
||||
(and (pair? x)
|
||||
(let ([d ($cdr x)])
|
||||
(and (pair? d)
|
||||
(null? ($cdr d))))
|
||||
(assq ($car x) macro-forms))))
|
||||
(define writer
|
||||
(lambda (x p m)
|
||||
(cond
|
||||
[(macro x) =>
|
||||
(lambda (y)
|
||||
(write-char* (cdr y) p)
|
||||
(writer (cadr x) p m))]
|
||||
[(pair? x)
|
||||
(write-char #\( p)
|
||||
(writer (car x) p m)
|
||||
(write-list (cdr x) p m)
|
||||
(write-char #\) p)]
|
||||
[(symbol? x)
|
||||
(if (gensym? x)
|
||||
(write-gensym x p m)
|
||||
(write-symbol x p m))]
|
||||
[(fixnum? x)
|
||||
(write-fixnum x p)]
|
||||
[(string? x)
|
||||
(write-string x p m)]
|
||||
[(boolean? x)
|
||||
(write-char* (if x "#t" "#f") p)]
|
||||
[(char? x)
|
||||
(write-character x p m)]
|
||||
[(procedure? x)
|
||||
(write-char* "#<procedure>" p)]
|
||||
[(output-port? x)
|
||||
(write-char* "#<output-port " p)
|
||||
(writer (output-port-name x) p #t)
|
||||
(write-char #\> p)]
|
||||
[(input-port? x)
|
||||
(write-char* "#<input-port " p)
|
||||
(writer (input-port-name x) p #t)
|
||||
(write-char #\> p)]
|
||||
[(vector? x)
|
||||
(write-vector x p m)]
|
||||
[(null? x)
|
||||
(write-char #\( p)
|
||||
(write-char #\) p)]
|
||||
[(eq? x (void))
|
||||
(write-char* "#<void>" p)]
|
||||
[(eof-object? x)
|
||||
(write-char* "#!eof" p)]
|
||||
[(bwp-object? x)
|
||||
(write-char* "#!bwp" p)]
|
||||
[(record? x)
|
||||
(let ([printer (record-printer x)])
|
||||
(if (procedure? printer)
|
||||
(printer x p)
|
||||
(write-record x p m)))]
|
||||
;[(code? x)
|
||||
; (write-char* "#<code>" p)]
|
||||
[(hash-table? x)
|
||||
(write-char* "#<hash-table>" p)]
|
||||
[($unbound-object? x)
|
||||
(write-char* "#<unbound-object>" p)]
|
||||
[($forward-ptr? x)
|
||||
(write-char* "#<forward-ptr>" p)]
|
||||
[else
|
||||
(write-char* "#<unknown>" p)])))
|
||||
|
||||
(define (write x p)
|
||||
(writer x p #t)
|
||||
(flush-output-port p))
|
||||
(define (display x p)
|
||||
(writer x p #f)
|
||||
(flush-output-port p))
|
||||
;;;
|
||||
(define formatter
|
||||
(lambda (who p fmt args)
|
||||
(let f ([i 0] [args args])
|
||||
(unless (fx= i (string-length fmt))
|
||||
(let ([c (string-ref fmt i)])
|
||||
(cond
|
||||
[($char= c #\~)
|
||||
(let ([i (fxadd1 i)])
|
||||
(when (fx= i (string-length fmt))
|
||||
(error who "invalid ~~ at end of format string ~s" fmt))
|
||||
(let ([c (string-ref fmt i)])
|
||||
(cond
|
||||
[($char= c #\~)
|
||||
(write-char #\~ p)
|
||||
(f (fxadd1 i) args)]
|
||||
[($char= c #\a)
|
||||
(when (null? args)
|
||||
(error who "insufficient arguments"))
|
||||
(display (car args) p)
|
||||
(f (fxadd1 i) (cdr args))]
|
||||
[($char= c #\s)
|
||||
(when (null? args)
|
||||
(error who "insufficient arguments"))
|
||||
(write (car args) p)
|
||||
(f (fxadd1 i) (cdr args))]
|
||||
[else
|
||||
(error who "invalid sequence ~~~a" c)])))]
|
||||
[else
|
||||
(write-char c p)
|
||||
(f (fxadd1 i) args)]))))))
|
||||
|
||||
(define fprintf
|
||||
(lambda (port fmt . args)
|
||||
(unless (output-port? port)
|
||||
(error 'fprintf "~s is not an output port" port))
|
||||
(unless (string? fmt)
|
||||
(error 'fprintf "~s is not a string" fmt))
|
||||
(formatter 'fprintf port fmt args)))
|
||||
|
||||
(define printf
|
||||
(lambda (fmt . args)
|
||||
(unless (string? fmt)
|
||||
(error 'printf "~s is not a string" fmt))
|
||||
(formatter 'printf (current-output-port) fmt args)))
|
||||
|
||||
(define format
|
||||
(lambda (fmt . args)
|
||||
(unless (string? fmt)
|
||||
(error 'format "~s is not a string" fmt))
|
||||
(let ([p (open-output-string)])
|
||||
(formatter 'format p fmt args)
|
||||
(get-output-string p))))
|
||||
|
||||
(define print-error
|
||||
(lambda (who fmt . args)
|
||||
(unless (string? fmt)
|
||||
(error 'print-error "~s is not a string" fmt))
|
||||
(let ([p (standard-error-port)])
|
||||
(if who
|
||||
(fprintf p "Error in ~a: " who)
|
||||
(fprintf p "Error: "))
|
||||
(formatter 'print-error p fmt args)
|
||||
(write-char #\. p)
|
||||
(newline p))))
|
||||
|
||||
|
||||
;;;
|
||||
(primitive-set! 'format format)
|
||||
(primitive-set! 'printf printf)
|
||||
(primitive-set! 'fprintf fprintf)
|
||||
(primitive-set! 'write
|
||||
(case-lambda
|
||||
[(x) (write x (current-output-port))]
|
||||
[(x p)
|
||||
(unless (output-port? p)
|
||||
(error 'write "~s is not an output port" p))
|
||||
(write x p)]))
|
||||
(primitive-set! 'display
|
||||
(case-lambda
|
||||
[(x) (display x (current-output-port))]
|
||||
[(x p)
|
||||
(unless (output-port? p)
|
||||
(error 'display "~s is not an output port" p))
|
||||
(display x p)]))
|
||||
(primitive-set! 'print-error print-error)
|
||||
(primitive-set! 'current-error-handler
|
||||
(make-parameter
|
||||
(lambda args
|
||||
(apply print-error args)
|
||||
(display "exiting\n" (console-output-port))
|
||||
(flush-output-port (console-output-port))
|
||||
(exit -100))
|
||||
(lambda (x)
|
||||
(if (procedure? x)
|
||||
x
|
||||
(error 'current-error-handler "~s is not a procedure" x)))))
|
||||
(primitive-set! 'error
|
||||
(lambda args
|
||||
(apply (current-error-handler) args))))
|
||||
|
||||
Binary file not shown.
|
|
@ -0,0 +1,34 @@
|
|||
(define primitive-set! set-top-level-value!)
|
||||
(define chez-expand sc-expand)
|
||||
(define-syntax |#primitive|
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[(_ n) #'n])))
|
||||
|
||||
(printf "loading psyntax.pp ...\n")
|
||||
(load "psyntax-7.1.pp")
|
||||
|
||||
(current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
|
||||
(printf "loading psyntax.ss ...\n")
|
||||
(load "psyntax-7.1.ss")
|
||||
(current-expand
|
||||
(lambda (x . args)
|
||||
(apply chez-expand (sc-expand x) args)))
|
||||
|
||||
(printf "making xpsyntax.pp ...\n")
|
||||
|
||||
(with-output-to-file "xpsyntax.pp"
|
||||
(lambda ()
|
||||
(load "psyntax-7.1.ss"
|
||||
(lambda (x)
|
||||
(parameterize ([print-gensym #f]
|
||||
[print-graph #f]
|
||||
[expand-mode 'bootstrap]
|
||||
[print-vector-length #f])
|
||||
(pretty-print (sc-expand x))
|
||||
(newline)))))
|
||||
'replace)
|
||||
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
File diff suppressed because it is too large
Load Diff
|
|
@ -1,37 +1,40 @@
|
|||
|
||||
#CFLAGS = -Wall -DNDEBUG -O3
|
||||
CFLAGS = -Wall -g
|
||||
LDFLAGS = -g -ldl -luuid -rdynamic
|
||||
all: ikarus
|
||||
|
||||
ikarus: ikarus-collect.o ikarus-runtime.o ikarus-main.o ikarus-fasl.o \
|
||||
ikarus-exec.o ikarus-print.o ikarus-enter.s ikarus-symbol-table.o \
|
||||
ikarus-hash-tables.o
|
||||
gcc -g -Wall -ldl -luuid -rdynamic -o ikarus \
|
||||
ikarus-weak-pairs.o
|
||||
gcc $(LDFLAGS) -o ikarus \
|
||||
ikarus-main.o ikarus-runtime.o \
|
||||
ikarus-fasl.o ikarus-exec.o ikarus-print.o ikarus-enter.s \
|
||||
ikarus-symbol-table.o ikarus-collect.o ikarus-hash-tables.o
|
||||
ikarus-symbol-table.o ikarus-collect.o ikarus-weak-pairs.o
|
||||
|
||||
ikarus-main.o: ikarus-main.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-main.c
|
||||
gcc $(CFLAGS) -c ikarus-main.c
|
||||
|
||||
ikarus-runtime.o: ikarus-runtime.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-runtime.c
|
||||
gcc $(CFLAGS) -c ikarus-runtime.c
|
||||
|
||||
ikarus-fasl.o: ikarus-fasl.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-fasl.c
|
||||
gcc $(CFLAGS) -c ikarus-fasl.c
|
||||
|
||||
ikarus-exec.o: ikarus-exec.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-exec.c
|
||||
gcc $(CFLAGS) -c ikarus-exec.c
|
||||
|
||||
ikarus-print.o: ikarus-print.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-print.c
|
||||
gcc $(CFLAGS) -c ikarus-print.c
|
||||
|
||||
ikarus-collect.o: ikarus-collect.c ikarus.h
|
||||
gcc -Wall -g -c ikarus-collect.c
|
||||
gcc $(CFLAGS) -c ikarus-collect.c
|
||||
|
||||
ikarus-weak-pairs.o: ikarus-weak-pairs.c ikarus.h
|
||||