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