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

* libpp librarified 

* chi-library now knows about modules (kind of)
This commit is contained in:
Abdulaziz Ghuloum 2007-04-29 20:41:55 -04:00
parent 948797da22
commit 0cd876d5a2
3 changed files with 175 additions and 26 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.

6
src/libpp.ss
View File

@ -1,5 +1,8 @@
(let () (library (ikarus pretty-print)
(export)
(import (scheme))
(define (pretty-width) 80) (define (pretty-width) 80)
(define (pretty-indent) 1) (define (pretty-indent) 1)
(define-record cbox (length boxes)) (define-record cbox (length boxes))
@ -119,6 +122,7 @@
(define (skip-fmt x) (define (skip-fmt x)
(let-values ([(tab subfmt dots fmt) (parse-fmt x)]) (let-values ([(tab subfmt dots fmt) (parse-fmt x)])
fmt))) fmt)))
;(import M)
(define (boxify/fmt fmt x) (define (boxify/fmt fmt x)
(cond (cond
[(and (pair? fmt) (pair? x) (list? x)) [(and (pair? fmt) (pair? x) (list? x))

195
src/syntax.ss
View File

@ -285,7 +285,7 @@
[type (binding-type b)]) [type (binding-type b)])
(case type (case type
[(define define-syntax core-macro begin macro [(define define-syntax core-macro begin macro
set!) module set!)
(values type (binding-value b) id)] (values type (binding-value b) id)]
[else [else
(values 'call #f #f)])) (values 'call #f #f)]))
@ -507,6 +507,7 @@
(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)]
[module module-label (module)]
[begin begin-label (begin)] [begin begin-label (begin)]
[set! set!-label (set!)] [set! set!-label (set!)]
[define-record define-record-label (macro . define-record)] [define-record define-record-label (macro . define-record)]
@ -522,9 +523,12 @@
[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)]
[and and-label (core-macro . and)]
[or or-label (core-macro . or)]
[parameterize parameterize-label (core-macro . parameterize)] [parameterize parameterize-label (core-macro . parameterize)]
;;; prims ;;; prims
[void void-label (core-prim . void)] [void void-label (core-prim . void)]
[not not-label (core-prim . not)]
[boolean? boolean-label (core-prim . boolean?)] [boolean? boolean-label (core-prim . boolean?)]
[null? null?-label (core-prim . null?)] [null? null?-label (core-prim . null?)]
[procedure? procedure?-label (core-prim . procedure?)] [procedure? procedure?-label (core-prim . procedure?)]
@ -535,21 +539,39 @@
[equal? equal?-label (core-prim . equal?)] [equal? equal?-label (core-prim . equal?)]
;;; pairs/lists ;;; pairs/lists
[cons cons-label (core-prim . cons)] [cons cons-label (core-prim . cons)]
[pair? pair?-label (core-prim . pair?)]
[car car-label (core-prim . car)] [car car-label (core-prim . car)]
[cdr cdr-label (core-prim . cdr)] [cdr cdr-label (core-prim . cdr)]
[caar caar-label (core-prim . caar)]
[cdar cdar-label (core-prim . cdar)]
[cadr cadr-label (core-prim . cadr)]
[cddr cddr-label (core-prim . cddr)]
[list list-label (core-prim . list)] [list list-label (core-prim . list)]
[list? list?-label (core-prim . list?)]
[append append-label (core-prim . append)] [append append-label (core-prim . append)]
[length length-label (core-prim . length)]
[assq assq-label (core-prim . assq)]
[assv assv-label (core-prim . assv)]
[assoc assoc-label (core-prim . assoc)]
;;; chars ;;; chars
[char=? char=?-label (core-prim . char=?)] [char=? char=?-label (core-prim . char=?)]
[integer->char integer->char-label (core-prim . integer->char)]
[char->integer char->integer-label (core-prim . char->integer)]
;;; strings ;;; strings
[string? string?-label (core-prim . string?)] [string? string?-label (core-prim . string?)]
[string-ref string-ref-label (core-prim . string-ref)] [string-ref string-ref-label (core-prim . string-ref)]
[string-set! string-set!-label (core-prim . string-set!)]
[string-length string-length-label (core-prim . string-length)] [string-length string-length-label (core-prim . string-length)]
[string=? string=?-label (core-prim . string=?)] [string=? string=?-label (core-prim . string=?)]
[substring substring-label (core-prim . substring)] [substring substring-label (core-prim . substring)]
;;; vectors ;;; vectors
[vector vector-label (core-prim . vector)] [vector vector-label (core-prim . vector)]
[vector-ref vector-ref-label (core-prim . vector-ref)]
[vector-set! vector-set!-label (core-prim . vector-set!)]
[vector? vector?-label (core-prim . vector?)]
[vector-length vector-length-label (core-prim . vector-length)]
[list->vector list->vector-label (core-prim . list->vector)] [list->vector list->vector-label (core-prim . list->vector)]
[vector->list vector->list-label (core-prim . vector->list)]
;;; iterators ;;; iterators
[for-each for-each-label (core-prim . for-each)] [for-each for-each-label (core-prim . for-each)]
[map map-label (core-prim . map)] [map map-label (core-prim . map)]
@ -564,6 +586,7 @@
[fx= fx=-label (core-prim . fx=)] [fx= fx=-label (core-prim . fx=)]
[fx- fx--label (core-prim . fx-)] [fx- fx--label (core-prim . fx-)]
[fx+ fx+-label (core-prim . fx+)] [fx+ fx+-label (core-prim . fx+)]
[fxzero? fxzero?-label (core-prim . fxzero?)]
[fxadd1 fxadd1-label (core-prim . fxadd1)] [fxadd1 fxadd1-label (core-prim . fxadd1)]
[fxsub1 fxsub1-label (core-prim . fxsub1)] [fxsub1 fxsub1-label (core-prim . fxsub1)]
[fxquotient fxquotient-label (core-prim . fxquotient)] [fxquotient fxquotient-label (core-prim . fxquotient)]
@ -574,22 +597,27 @@
[+ plus-label (core-prim . +)] [+ plus-label (core-prim . +)]
[quotient quotient-label (core-prim . quotient)] [quotient quotient-label (core-prim . quotient)]
;;; symbols/gensyms ;;; symbols/gensyms
[symbol? symbol?-label (core-prim . symbol?)]
[gensym gensym-label (core-prim . gensym)] [gensym gensym-label (core-prim . gensym)]
[getprop getprop-label (core-prim . getprop)] [getprop getprop-label (core-prim . getprop)]
[putprop putprop-label (core-prim . putprop)] [putprop putprop-label (core-prim . putprop)]
[symbol->string symbol->string-label (core-prim . symbol->string)] [symbol->string symbol->string-label (core-prim . symbol->string)]
[$set-symbol-value! $set-symbol-value!-label (core-prim . $set-symbol-value!)] [$set-symbol-value! $set-symbol-value!-label (core-prim . $set-symbol-value!)]
;;; IO/ports ;;; IO/ports
[console-input-port console-input-port-label (core-prim . console-input-port)] [output-port? output-port?-label (core-prim . output-port?)]
[console-input-port console-input-port-label (core-prim . console-input-port)]
[console-output-port console-output-port-label (core-prim . console-output-port)] [console-output-port console-output-port-label (core-prim . console-output-port)]
[flush-output-port flush-output-port-label (core-prim . flush-output-port)] [current-input-port current-input-port-label (core-prim . current-input-port)]
[reset-input-port! reset-input-port!-label (core-prim . reset-input-port!)] [current-output-port current-output-port-label (core-prim . current-output-port)]
[flush-output-port flush-output-port-label (core-prim . flush-output-port)]
[reset-input-port! reset-input-port!-label (core-prim . reset-input-port!)]
;;; IO/high-level ;;; IO/high-level
[display display-label (core-prim . display)] [display display-label (core-prim . display)]
[write write-label (core-prim . write)] [write write-label (core-prim . write)]
[read read-label (core-prim . read)] [read read-label (core-prim . read)]
[newline newline-label (core-prim . newline)] [newline newline-label (core-prim . newline)]
[printf printf-label (core-prim . printf)] [printf printf-label (core-prim . printf)]
[format format-label (core-prim . format)]
[pretty-print pretty-print-label (core-prim . pretty-print)] [pretty-print pretty-print-label (core-prim . pretty-print)]
;;; evaluation / control ;;; evaluation / control
[apply apply-label (core-prim . apply)] [apply apply-label (core-prim . apply)]
@ -976,6 +1004,36 @@
(build-lambda no-source '() (build-lambda no-source '()
(chi-internal (cons b b*) r mr)) (chi-internal (cons b b*) r mr))
(build-lexical-reference no-source swap))))))]))) (build-lexical-reference no-source swap))))))])))
(define and-transformer
(lambda (e r mr)
(syntax-match e
[(_) (build-data no-source #t)]
[(_ e e* ...)
(let f ([e e] [e* e*])
(cond
[(null? e*) (chi-expr e r mr)]
[else
(build-conditional no-source
(chi-expr e r mr)
(f (car e*) (cdr e*))
(build-data no-source #f))]))])))
(define or-transformer
(lambda (e r mr)
(syntax-match e
[(_) (build-data no-source #f)]
[(_ e e* ...)
(let f ([e e] [e* e*])
(cond
[(null? e*) (chi-expr e r mr)]
[else
(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-lexical-reference no-source t)
(f (car e*) (cdr e*)))))]))])))
(define foreign-call-transformer (define foreign-call-transformer
(lambda (e r mr) (lambda (e r mr)
(syntax-match e (syntax-match e
@ -997,6 +1055,8 @@
[(if) if-transformer] [(if) if-transformer]
[(when) when-transformer] [(when) when-transformer]
[(unless) unless-transformer] [(unless) unless-transformer]
[(and) and-transformer]
[(or) or-transformer]
[(parameterize) parameterize-transformer] [(parameterize) parameterize-transformer]
[(foreign-call) foreign-call-transformer] [(foreign-call) foreign-call-transformer]
[else (error 'macro-transformer "cannot find ~s" name)]))) [else (error 'macro-transformer "cannot find ~s" name)])))
@ -1016,9 +1076,22 @@
(lambda (p e) (lambda (p e)
(let ([s ((macro-transformer p) (add-mark anti-mark e))]) (let ([s ((macro-transformer p) (add-mark anti-mark e))])
(add-mark (gen-mark) s)))) (add-mark (gen-mark) s))))
(define chi-expr* (define chi-expr*
(lambda (e* r mr) (lambda (e* r mr)
(map (lambda (e) (chi-expr e r mr)) e*))) ;;; expand left to right
(cond
[(null? e*) '()]
[else
(let ([e (chi-expr (car e*) r mr)])
(cons e (chi-expr* (cdr e*) r mr)))])))
(define chi-application
(lambda (e r mr)
(syntax-match e
[(rator rands ...)
(let ([rator (chi-expr rator r mr)])
(build-application no-source
rator
(chi-expr* rands r mr)))])))
(define chi-expr (define chi-expr
(lambda (e r mr) (lambda (e r mr)
(let-values ([(type value kwd) (syntax-type e r)]) (let-values ([(type value kwd) (syntax-type e r)])
@ -1029,17 +1102,11 @@
[(core-prim) [(core-prim)
(let ([name value]) (let ([name value])
(build-primref no-source name))] (build-primref no-source name))]
[(call) [(call) (chi-application e r mr)]
(syntax-match e
[(rator rands ...)
(build-application no-source
(chi-expr rator r mr)
(chi-expr* rands r mr))])]
[(lexical) [(lexical)
(let ([lex value]) (let ([lex value])
(build-lexical-reference no-source lex))] (build-lexical-reference no-source lex))]
[(macro) [(macro) (chi-expr (chi-macro value e) r mr)]
(chi-expr (chi-macro value e) r mr)]
[(constant) [(constant)
(let ([datum value]) (let ([datum value])
(build-data no-source datum))] (build-data no-source datum))]
@ -1123,21 +1190,28 @@
(chi-expr expr r mr))] (chi-expr expr r mr))]
[else (error 'chi-rhs "invalid rhs ~s" rhs)])) [else (error 'chi-rhs "invalid rhs ~s" rhs)]))
rhs*))) rhs*)))
(define find-bound=?
(lambda (x lhs* rhs*)
(cond
[(null? lhs*) #f]
[(bound-id=? x (car lhs*)) (car rhs*)]
[else (find-bound=? x (cdr lhs*) (cdr rhs*))])))
(define chi-internal (define chi-internal
(lambda (e* r mr) (lambda (e* r mr)
(define return (define return
(lambda (init* r mr lhs* lex* rhs*) (lambda (init* module-init** r mr lhs* lex* rhs*)
(unless (valid-bound-ids? lhs*) (let ([mod-init* (apply append (reverse module-init**))])
(error 'chi-internal "multiple definitions")) (unless (valid-bound-ids? lhs*)
(let ([rhs* (chi-rhs* rhs* r mr)] (error 'chi-internal "multiple definitions"))
[init* (chi-expr* init* r mr)]) (let ([rhs* (chi-rhs* rhs* r mr)]
(build-letrec no-source [init* (chi-expr* (append mod-init* init*) r mr)])
(reverse lex*) (reverse rhs*) (build-letrec no-source
(build-sequence no-source init*))))) (reverse lex*) (reverse rhs*)
(build-sequence no-source init*))))))
(let* ([rib (make-empty-rib)] (let* ([rib (make-empty-rib)]
[e* (map (lambda (x) (add-subst rib x)) [e* (map (lambda (x) (add-subst rib x))
(syntax->list e*))]) (syntax->list e*))])
(let f ([e* e*] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* '()]) (let f ([e* e*] [module-init** '()] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* '()])
(cond (cond
[(null? e*) (error 'chi-internal "empty body")] [(null? e*) (error 'chi-internal "empty body")]
[else [else
@ -1153,14 +1227,85 @@
[lab (gen-label id)]) [lab (gen-label id)])
(extend-rib! rib id lab) (extend-rib! rib id lab)
(f (cdr e*) (f (cdr e*)
module-init**
(cons (cons lab (cons 'lexical lex)) r) (cons (cons lab (cons 'lexical lex)) r)
mr mr
(cons id lhs*) (cons id lhs*)
(cons lex lex*) (cons lex lex*)
(cons rhs rhs*) (cons rhs rhs*)
kwd*)))] kwd*)))]
[(module)
(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*)])
(for-each
(lambda (id lab) (extend-rib! rib id lab))
m-exp-id* m-exp-lab*)
(f (cdr e*)
(cons m-init* module-init**)
r mr
(append m-lhs* lhs*)
(append m-lex* lex*)
(append m-rhs* rhs*)
kwd*))]
[else [else
(return e* r mr lhs* lex* rhs*)]))))]))))) (return e* module-init** r mr lhs* lex* rhs*)]))))])))))
(define chi-internal-module
(lambda (e r mr kwd*)
(define parse-module
(lambda (e)
(syntax-match e
[(_ (export* ...) b* ...)
(unless (andmap id? export*) (stx-error e))
(values #f export* b*)]
[(_ name (export* ...) b* ...)
(unless (and (id? name) (andmap id? export*)) (stx-error e))
(values name export* b*)])))
(let-values ([(name exp-id* e*) (parse-module e)])
(let* ([rib (make-empty-rib)]
[e* (map (lambda (x) (add-subst rib x)) (syntax->list e*))])
(define return
(lambda (init* r mr lhs* lex* rhs* kwd*)
(let ([exp-lab*
(map (lambda (x)
(or (id->label (add-subst rib x))
(stx-error x "cannot find export")))
exp-id*)])
(if (not name) ;;; explicit export
(values lhs* lex* rhs* init* exp-id* exp-lab* r mr kwd*)
(let ([lab (gen-label 'module)]
[iface (cons exp-id* exp-lab*)])
(values lhs* lex* rhs* init*
(list name) ;;; FIXME: module cannot
(list lab) ;;; export itself yet
(cons (cons lab (cons '$module iface)) r)
(cons (cons lab (cons '$module iface)) mr)
kwd*))))))
(let f ([e* e*] [r r] [mr mr] [lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*])
(cond
[(null? e*) (return '() r mr lhs* lex* rhs* kwd*)]
[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)]
[lab (gen-label id)])
(extend-rib! rib id lab)
(f (cdr e*)
(cons (cons lab (cons 'lexical lex)) r)
mr
(cons id lhs*)
(cons lex lex*)
(cons rhs rhs*)
kwd*)))]
[else
(error 'chi-internal-module
"cannot handle ~s"
type)]))))]))))))
(define chi-library-internal (define chi-library-internal
(lambda (e* r rib) (lambda (e* r rib)
(define return (define return