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

* more cleanup

This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 06:56:20 -04:00
parent 741c261b7e
commit c4d0277fb3
2 changed files with 210 additions and 225 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

79
src/ikarus.syntax.ss
View File

@ -19,11 +19,10 @@
(syntax-error sys:syntax-error) (syntax-error sys:syntax-error)
;(syntax->datum sys:syntax->datum) ;(syntax->datum sys:syntax->datum)
(generate-temporaries sys:generate-temporaries))) (generate-temporaries sys:generate-temporaries)))
(define who 'expander) (define who 'expander)
(define-syntax no-source (define-syntax no-source
(lambda (x) #f)) (lambda (x) #f))
(begin ;;; GOOD ONES (begin ;;; builders
(define-syntax build-application (define-syntax build-application
(syntax-rules () (syntax-rules ()
((_ ae fun-exp arg-exps) ((_ ae fun-exp arg-exps)
@ -140,7 +139,6 @@
(make-vector (vector-length sym*) 0)))))) (make-vector (vector-length sym*) 0))))))
(define (unseal-rib! rib) (define (unseal-rib! rib)
(when (rib-sealed/freq rib) (when (rib-sealed/freq rib)
;(printf "[ribsize ~s]\n" (vector-length (rib-sealed/freq rib)))
(set-rib-sealed/freq! rib #f) (set-rib-sealed/freq! rib #f)
(set-rib-sym*! rib (vector->list (rib-sym* rib))) (set-rib-sym*! rib (vector->list (rib-sym* rib)))
(set-rib-mark**! rib (vector->list (rib-mark** rib))) (set-rib-mark**! rib (vector->list (rib-mark** rib)))
@ -1244,7 +1242,7 @@
((not (distinct-bound-ids? (map car pvars))) ((not (distinct-bound-ids? (map car pvars)))
(invalid-ids-error (map car pvars) pat "pattern variable")) (invalid-ids-error (map car pvars) pat "pattern variable"))
((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars)) ((not (andmap (lambda (x) (not (ellipsis? (car x)))) pvars))
(stx-error pat "3misplaced ellipsis in syntax-case pattern")) (stx-error pat "misplaced ellipsis in syntax-case pattern"))
(else (else
(let ((y (gen-lexical 'tmp))) (let ((y (gen-lexical 'tmp)))
(let ([test (let ([test
@ -1290,13 +1288,9 @@
[lex (gen-lexical pat)]) [lex (gen-lexical pat)])
(let ([body (let ([body
(chi-expr (chi-expr
(add-subst (add-subst (make-full-rib (list pat) (list lab)) expr)
(make-full-rib (list pat) (list lab)) (extend-env lab (make-binding 'syntax (cons lex 0)) r)
expr) mr)])
(extend-env lab
(make-binding 'syntax (cons lex 0))
r)
mr)])
(build-application no-source (build-application no-source
(build-lambda no-source (list lex) body) (build-lambda no-source (list lex) body)
(list (build-lexical-reference no-source x)))))) (list (build-lexical-reference no-source x))))))
@ -1379,21 +1373,21 @@
(let-values (((outer-var outer-maps) (let-values (((outer-var outer-maps)
(gen-ref src var (- level 1) (cdr maps)))) (gen-ref src var (- level 1) (cdr maps))))
(cond (cond
((assq outer-var (car maps)) => [(assq outer-var (car maps)) =>
(lambda (b) (values (cdr b) maps))) (lambda (b) (values (cdr b) maps))]
(else [else
(let ((inner-var (gen-lexical 'tmp))) (let ((inner-var (gen-lexical 'tmp)))
(values (values
inner-var inner-var
(cons (cons
(cons (cons outer-var inner-var) (car maps)) (cons (cons outer-var inner-var) (car maps))
outer-maps)))))))))) outer-maps)))]))))))
(define gen-append (define gen-append
(lambda (x y) (lambda (x y)
(if (equal? y '(quote ())) x (list 'append x y)))) (if (equal? y '(quote ())) x `(append ,x ,y))))
(define gen-mappend (define gen-mappend
(lambda (e map-env) (lambda (e map-env)
(list 'apply '(primitive append) (gen-map e map-env)))) `(apply (primitive append) ,(gen-map e map-env))))
(define gen-map (define gen-map
(lambda (e map-env) (lambda (e map-env)
(let ((formals (map cdr map-env)) (let ((formals (map cdr map-env))
@ -1401,43 +1395,42 @@
(cond (cond
; identity map equivalence: ; identity map equivalence:
; (map (lambda (x) x) y) == y ; (map (lambda (x) x) y) == y
((eq? (car e) 'ref) [(eq? (car e) 'ref)
(car actuals)) (car actuals)]
; eta map equivalence: ; eta map equivalence:
; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) ; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
((andmap [(andmap
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e)) (cdr e))
(list* 'map (list 'primitive (car e)) (let ([args (map (let ((r (map cons formals actuals)))
(map (let ((r (map cons formals actuals))) (lambda (x) (cdr (assq (cadr x) r))))
(lambda (x) (cdr (assq (cadr x) r)))) (cdr e))])
(cdr e)))) `(map (primitive ,(car e)) . ,args))]
(else (list* 'map (list 'lambda formals e) actuals)))))) [else (list* 'map (list 'lambda formals e) actuals)]))))
(define gen-cons (define gen-cons
(lambda (e x y xnew ynew) (lambda (e x y xnew ynew)
(case (car ynew) (case (car ynew)
((quote) [(quote)
(if (eq? (car xnew) 'quote) (if (eq? (car xnew) 'quote)
(let ((xnew (cadr xnew)) (ynew (cadr ynew))) (let ((xnew (cadr xnew)) (ynew (cadr ynew)))
(if (and (eq? xnew x) (eq? ynew y)) (if (and (eq? xnew x) (eq? ynew y))
(list 'quote e) `(quote ,e)
(list 'quote (cons xnew ynew)))) `(quote ,(cons xnew ynew))))
(if (eq? (cadr ynew) '()) (if (eq? (cadr ynew) '())
(list 'list xnew) `(list ,xnew)
(list 'cons xnew ynew)))) `(cons ,xnew ,ynew)))]
((list) (list* 'list xnew (cdr ynew))) [(list) `(list ,xnew . ,(cdr ynew))]
(else (list 'cons xnew ynew))))) [else `(cons ,xnew ,ynew)])))
(define gen-vector (define gen-vector
(lambda (e ls lsnew) (lambda (e ls lsnew)
(cond (cond
((eq? (car lsnew) 'quote) [(eq? (car lsnew) 'quote)
(if (eq? (cadr lsnew) ls) (if (eq? (cadr lsnew) ls)
(list 'quote e) `(quote ,e)
(list 'quote (list->vector (cadr lsnew))))) `(quote #(,@(cadr lsnew))))]
;`(quote #(,@(cadr lsnew))))) [(eq? (car lsnew) 'list)
((eq? (car lsnew) 'list) `(vector . ,(cdr lsnew))]
(cons 'vector (cdr lsnew))) [else `(list->vector ,lsnew)])))
(else (list 'list->vector lsnew)))))
(define regen (define regen
(lambda (x) (lambda (x)
(case (car x) (case (car x)
@ -1659,7 +1652,6 @@
[(find-bound=? (car ls) (cdr ls) (cdr ls)) => [(find-bound=? (car ls) (cdr ls) (cdr ls)) =>
(lambda (x) (f (cdr ls) (cons (list (car ls) x) dups)))] (lambda (x) (f (cdr ls) (cons (list (car ls) x) dups)))]
[else (f (cdr ls) dups)]))) [else (f (cdr ls) dups)])))
(define chi-internal (define chi-internal
(lambda (e* r mr) (lambda (e* r mr)
(let ([rib (make-empty-rib)]) (let ([rib (make-empty-rib)])
@ -1667,8 +1659,6 @@
(chi-body* (map (lambda (x) (add-subst rib x)) (chi-body* (map (lambda (x) (add-subst rib x))
(syntax->list e*)) (syntax->list e*))
rib r mr '() '() '() '())]) rib r mr '() '() '() '())])
;(unless (valid-bound-ids? lhs*)
; (stx-error (find-dups lhs*) "multiple definitions in internal"))
(when (null? e*) (when (null? e*)
(stx-error e* "no expression in body")) (stx-error e* "no expression in body"))
(let ([rhs* (chi-rhs* rhs* r mr)] (let ([rhs* (chi-rhs* rhs* r mr)]
@ -1676,14 +1666,12 @@
(build-letrec no-source (build-letrec no-source
(reverse lex*) (reverse rhs*) (reverse lex*) (reverse rhs*)
(build-sequence no-source init*))))))) (build-sequence no-source init*)))))))
(define chi-library-internal (define chi-library-internal
(lambda (e* rib) (lambda (e* rib)
(let-values ([(e* r mr lex* rhs* mod** _kwd*) (let-values ([(e* r mr lex* rhs* mod** _kwd*)
(chi-body* e* rib '() '() '() '() '() '())]) (chi-body* e* rib '() '() '() '() '() '())])
(values (append (apply append (reverse mod**)) e*) (values (append (apply append (reverse mod**)) e*)
r mr (reverse lex*) (reverse rhs*))))) r mr (reverse lex*) (reverse rhs*)))))
(define chi-internal-module (define chi-internal-module
(lambda (e r mr lex* rhs* mod** kwd*) (lambda (e r mr lex* rhs* mod** kwd*)
(define parse-module (define parse-module
@ -1723,7 +1711,6 @@
(cons (cons lab (cons '$module iface)) r) (cons (cons lab (cons '$module iface)) r)
(cons (cons lab (cons '$module iface)) mr) (cons (cons lab (cons '$module iface)) mr)
mod** kwd*))))))))) mod** kwd*)))))))))
(define chi-body* (define chi-body*
(lambda (e* rib r mr lex* rhs* mod** kwd*) (lambda (e* rib r mr lex* rhs* mod** kwd*)
(cond (cond
@ -1779,7 +1766,6 @@
rib r mr lex* rhs* mod** kwd*)] rib r mr lex* rhs* mod** kwd*)]
[else [else
(values e* r mr lex* rhs* mod** kwd*)]))))]))) (values e* r mr lex* rhs* mod** kwd*)]))))])))
(define (expand-transformer expr r) (define (expand-transformer expr r)
(let ([rtc (make-collector)]) (let ([rtc (make-collector)])
(let ([expanded-rhs (let ([expanded-rhs
@ -1793,7 +1779,6 @@
(mark-visit x))) (mark-visit x)))
(rtc)) (rtc))
expanded-rhs))) expanded-rhs)))
(define (parse-exports exp*) (define (parse-exports exp*)
(let f ([exp* exp*] [int* '()] [ext* '()]) (let f ([exp* exp*] [int* '()] [ext* '()])
(cond (cond