diff --git a/src/ikarus.boot b/src/ikarus.boot index 5f6c894..9372fae 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/makefile.ss b/src/makefile.ss index 65302e9..93a25c3 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -246,7 +246,7 @@ ["libintelasm.ss" "libintelasm.fasl" p0 onepass] ["libfasl.ss" "libfasl.fasl" p0 onepass] ["libtrace.ss" "libtrace.fasl" p0 onepass] - ["libcompile.ss" "libcompile.fasl" p1 onepass] + ["libcompile.ss" "libcompile.fasl" p1 onepass] ["psyntax-7.1.ss" "psyntax.fasl" p0 onepass] ["libpp.ss" "libpp.fasl" p0 onepass] ["libcafe.ss" "libcafe.fasl" p0 onepass] diff --git a/src/psyntax-7.1.ss b/src/psyntax-7.1.ss index ee2c685..cb00b7c 100644 --- a/src/psyntax-7.1.ss +++ b/src/psyntax-7.1.ss @@ -669,61 +669,58 @@ (if name (gensym name) (gensym)))) ) - - -;;; output constructors -(begin +(begin ;;; GOOD ONES (define-syntax build-application (syntax-rules () - ((_ ae fun-exp arg-exps) - `(,fun-exp . ,arg-exps)))) - + ((_ ae fun-exp arg-exps) `(,fun-exp . ,arg-exps)))) (define-syntax build-conditional (syntax-rules () - ((_ ae test-exp then-exp else-exp) - `(if ,test-exp ,then-exp ,else-exp)))) - + ((_ ae test-exp then-exp else-exp) `(if ,test-exp ,then-exp ,else-exp)))) (define-syntax build-lexical-reference (syntax-rules () - ((_ ae var) var) - ((_ type ae var) - var))) - + ((_ ae var) var) ((_ type ae var) var))) (define-syntax build-lexical-assignment (syntax-rules () - ((_ ae var exp) - `(set! ,var ,exp)))) - -;;; AZIZ -;;; (define-syntax build-global-reference -;;; (syntax-rules () -;;; ((_ ae var) -;;; var))) + ((_ ae var exp) `(set! ,var ,exp)))) (define-syntax build-global-reference (syntax-rules () - [(_ ae var) - `(top-level-value ',var)])) - -;;; AZIZ -;;; (define-syntax build-global-assignment -;;; (syntax-rules () -;;; ((_ ae var exp) -;;; `(set! ,var ,exp)))) + [(_ ae var) `(top-level-value ',var)])) (define-syntax build-global-assignment (syntax-rules () - [(_ ae var exp) - `(set-top-level-value! ',var ,exp)])) - -;;; AZIZ -;;; (define-syntax build-global-definition -;;; (syntax-rules () -;;; ((_ ae var exp) -;;; `(define ,var ,exp)))) + [(_ ae var exp) `(set-top-level-value! ',var ,exp)])) (define-syntax build-global-definition (syntax-rules () - [(_ ae var exp) - (build-global-assignment ae var exp)])) + [(_ ae var exp) (build-global-assignment ae var exp)])) +(define-syntax build-lambda + (syntax-rules () + [(_ ae vars exp) `(case-lambda [,vars ,exp])])) +(define build-case-lambda + (lambda (ae vars* exp*) + `(case-lambda . ,(map list vars* exp*)))) +(define-syntax build-primref + (syntax-rules () + [(_ ae name) (build-primref ae 1 name)] + [(_ ae level name) `(|#primitive| ,name)])) +(define-syntax build-foreign-call + (syntax-rules () + [(_ ae name arg*) `(foreign-call ,name . ,arg*)])) +(define-syntax build-data + (syntax-rules () + ((_ ae exp) `',exp))) +(define build-sequence + (lambda (ae exps) + (let loop ((exps exps)) + (if (null? (cdr exps)) + (car exps) + (if (equal? (car exps) '(#%void)) + (loop (cdr exps)) + `(begin ,@exps)))))) +(define build-letrec + (lambda (ae vars val-exps body-exp) + (if (null? vars) body-exp `(letrec ,(map list vars val-exps) ,body-exp))))) +(begin ;;; PSYNTAX ONES +;;; output constructors (define-syntax build-cte-install ; should build a call that has the same effect as calling put-cte-hook @@ -743,20 +740,6 @@ (syntax-rules () ((_ exp) exp))) -;;; AZIZ -;;; (define-syntax build-lambda -;;; (syntax-rules () -;;; ((_ ae vars exp) -;;; `(lambda ,vars ,exp)))) -(define-syntax build-lambda - (syntax-rules () - [(_ ae vars exp) - `(case-lambda [,vars ,exp])])) - -(define build-case-lambda - (lambda (ae vars* exp*) - `(case-lambda . ,(map list vars* exp*)))) - ;;; AZIZ ;;; (define built-lambda? ;;; (lambda (x) @@ -765,42 +748,6 @@ (lambda (x) (and (pair? x) (eq? (car x) 'case-lambda)))) -;;; AZIZ -;;; (define-syntax build-primref -;;; (syntax-rules () -;;; ((_ ae name) name) -;;; ((_ ae level name) name))) -(define-syntax build-primref - (syntax-rules () - [(_ ae name) (build-primref ae 1 name)] - [(_ ae level name) - `(|#primitive| ,name)])) - - -;;; AZIZ -(define-syntax build-foreign-call - (syntax-rules () - [(_ ae name arg*) `(foreign-call ,name . ,arg*)])) - -(define-syntax build-data - (syntax-rules () - ((_ ae exp) `',exp))) - -(define build-sequence - (lambda (ae exps) - (let loop ((exps exps)) - (if (null? (cdr exps)) - (car exps) - ; weed out leading void calls, assuming ordinary list representation - (if (equal? (car exps) '(#%void)) - (loop (cdr exps)) - `(begin ,@exps)))))) - -(define build-letrec - (lambda (ae vars val-exps body-exp) - (if (null? vars) - body-exp - `(letrec ,(map list vars val-exps) ,body-exp)))) (define build-body (lambda (ae vars val-exps body-exp) diff --git a/src/syntax.ss b/src/syntax.ss index 28d15b3..357336c 100644 --- a/src/syntax.ss +++ b/src/syntax.ss @@ -1,13 +1,66 @@ (define who 'chi-top-library) - (define-syntax build-let - (lambda (x) - (syntax-case x () - [(_ ae lhs* rhs* body) - #'(build-application ae - (build-lambda ae lhs* body) - rhs*)]))) + (define noexpand "noexpand") + (define-syntax no-source + (lambda (x) #f)) + (begin ;;; GOOD ONES + (define-syntax build-application + (syntax-rules () + ((_ ae fun-exp arg-exps) + `(,fun-exp . ,arg-exps)))) + (define-syntax build-conditional + (syntax-rules () + ((_ ae test-exp then-exp else-exp) + `(if ,test-exp ,then-exp ,else-exp)))) + (define-syntax build-lexical-reference + (syntax-rules () + ((_ ae var) var) + ((_ type ae var) var))) + (define-syntax build-lexical-assignment + (syntax-rules () + ((_ ae var exp) `(set! ,var ,exp)))) + (define-syntax build-global-reference + (syntax-rules () + [(_ ae var) `(top-level-value ',var)])) + (define-syntax build-global-assignment + (syntax-rules () + [(_ ae var exp) `(set-top-level-value! ',var ,exp)])) + (define-syntax build-global-definition + (syntax-rules () + [(_ ae var exp) (build-global-assignment ae var exp)])) + (define-syntax build-lambda + (syntax-rules () + [(_ ae vars exp) `(case-lambda [,vars ,exp])])) + (define build-case-lambda + (lambda (ae vars* exp*) + `(case-lambda . ,(map list vars* exp*)))) + (define build-let + (lambda (ae lhs* rhs* body) + `((case-lambda [,lhs* ,body]) . ,rhs*))) + (define-syntax build-primref + (syntax-rules () + [(_ ae name) (build-primref ae 1 name)] + [(_ ae level name) `(|#primitive| ,name)])) + (define-syntax build-foreign-call + (syntax-rules () + [(_ ae name arg*) `(foreign-call ,name . ,arg*)])) + (define-syntax build-data + (syntax-rules () + ((_ ae exp) `',exp))) + (define build-sequence + (lambda (ae exps) + (let loop ((exps exps)) + (if (null? (cdr exps)) + (car exps) + (if (equal? (car exps) '(#%void)) + (loop (cdr exps)) + `(begin ,@exps)))))) + (define build-void + (lambda () '(#%void))) + (define build-letrec + (lambda (ae vars val-exps body-exp) + (if (null? vars) body-exp `(letrec ,(map list vars val-exps) ,body-exp))))) (define-syntax assert (lambda (x) (syntax-case x () @@ -291,7 +344,7 @@ (unless label (stx-error e "unbound identifier")) (case type - [(lexical core-prim) + [(lexical core-prim macro) (values type (binding-value b) id)] [else (values 'other #f #f)])))] [(syntax-pair? e) @@ -860,6 +913,7 @@ [input-port-name input-port-name-label (core-prim . input-port-name)] [output-port-name output-port-name-label (core-prim . output-port-name)] [open-input-file open-input-file-label (core-prim . open-input-file)] + [with-input-from-file with-input-from-file-label (core-prim . with-input-from-file)] [open-output-file open-output-file-label (core-prim . open-output-file)] [open-output-string open-output-string-label (core-prim . open-output-string)] [get-output-string get-output-string-label (core-prim . get-output-string)] @@ -955,6 +1009,7 @@ [$record/rtd? $record/rtd?-label (core-prim . $record/rtd?)] ;;; syntax-case [identifier? identifier?-label (core-prim . x:identifier?)] + [syntax-error syntax-error-label (core-prim . syntax-error)] [generate-temporaries generate-temporaries-label (core-prim . x:generate-temporaries)] [free-identifier=? free-identifier=?-label (core-prim . x:free-identifier=?)] ;;; codes @@ -1162,14 +1217,14 @@ (chi-expr test r mr) (build-sequence no-source (chi-expr* (cons e e*) r mr)) - (chi-void))]))) + (build-void))]))) (define unless-transformer (lambda (e r mr) (syntax-match e () [(_ test e e* ...) (build-conditional no-source (chi-expr test r mr) - (chi-void) + (build-void) (build-sequence no-source (chi-expr* (cons e e*) r mr)))]))) (define if-transformer @@ -1184,7 +1239,7 @@ (build-conditional no-source (chi-expr e0 r mr) (chi-expr e1 r mr) - (chi-void))]))) + (build-void))]))) (define case-transformer (lambda (e r mr) (define build-one @@ -1203,7 +1258,7 @@ (lambda (t cls) (syntax-match cls () [((d* ...) e e* ...) - (build-one t cls (chi-void))] + (build-one t cls (build-void))] [(else-kwd x x* ...) (if (and (id? else-kwd) (free-id=? else-kwd (scheme-stx 'else))) @@ -1214,7 +1269,7 @@ (syntax-match e () [(_ expr) (build-sequence no-source - (list (chi-expr expr r mr) (chi-void)))] + (list (chi-expr expr r mr) (build-void)))] [(_ expr cls cls* ...) (let ([t (gen-lexical 't)]) (build-let no-source @@ -1769,6 +1824,16 @@ (build-application no-source (build-primref no-source 'apply) (list (build-lambda no-source new-vars body) y))))))) + (define invalid-ids-error + (lambda (id* e class) + (let find ((id* id*) (ok* '())) + (if (null? id*) + (stx-error e) ; shouldn't happen + (if (id? (car id*)) + (if (bound-id-member? (car id*) ok*) + (syntax-error (car id*) "duplicate " class) + (find (cdr id*) (cons (car id*) ok*))) + (syntax-error (car id*) "invalid " class)))))) (define gen-clause (lambda (x keys clauses r mr pat fender expr) (let-values (((p pvars) (convert-pattern pat keys))) @@ -1935,7 +2000,7 @@ ((assq outer-var (car maps)) => (lambda (b) (values (cdr b) maps))) (else - (let ((inner-var (gen-var 'tmp))) + (let ((inner-var (gen-lexical 'tmp))) (values inner-var (cons @@ -2023,7 +2088,6 @@ [(let) let-transformer] [(letrec) letrec-transformer] [(let*) let*-transformer] - [(cond) cond-transformer] [(case) case-transformer] [(if) if-transformer] [(when) when-transformer] @@ -2424,7 +2488,7 @@ lex* (chi-rhs* rhs* r mr) (if (null? init*) - (chi-void) + (build-void) (build-sequence no-source (chi-expr* init* r mr)))))))))) (define library-expander