diff --git a/src/ikarus.boot b/src/ikarus.boot index e8ff9ef..cb1b55c 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index e31aaf5..fa16120 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -1245,24 +1245,6 @@ (module (assign-frame-sizes) ;;; assign-frame-sizes module (define indent (make-parameter 0)) - #;(define-syntax define - (lambda (x) - (import scheme) - (syntax-case x () - [(_ (name . args) b b* ...) - #'(module (name) - (define name (lambda args b b* ...)) - (when (procedure? name) - (let ([t name]) - (set! name - (lambda argv - (parameterize ([indent (+ (indent) 1)]) - (printf "[~s]enter ~s\n" (indent) 'name) - (call-with-values (lambda () (apply t argv)) - (lambda vals - (printf "[~s] exit ~s\n" (indent) 'name) - (apply values vals)))))))))] - [(_ name body) #'(define name body)]))) (import IntegerSet) (define (has-nontail-call? x) (define who 'has-nontail-call?) diff --git a/src/libcompile.ss b/src/libcompile.ss index 02704ca..1bbb567 100644 --- a/src/libcompile.ss +++ b/src/libcompile.ss @@ -551,9 +551,10 @@ [(funcall) #t] [(conditional) #f] [(bind lhs* rhs* body) (valid-mv-producer? body)] - [#t #f] ;; FIXME BUG - [else (error 'valid-mv-producer? "unhandles ~s" - (unparse x))])) + [else #f] ;; FIXME BUG + ; [else (error 'valid-mv-producer? "unhandles ~s" + ; (unparse x))] + )) (record-case rator [(clambda g cls*) (try-inline cls* rand* @@ -5189,8 +5190,10 @@ (car code*))))) -(include "libaltcogen.ss") - +;(include "libaltcogen.ss") +(define alt-cogen + (lambda args + (error 'alt-cogen "disabled for now"))) (define (alt-compile-expr expr) (let* ([p (parameterize ([assembler-output #f]) diff --git a/src/syntax.ss b/src/syntax.ss index 99c3d32..d8f6f70 100644 --- a/src/syntax.ss +++ b/src/syntax.ss @@ -2039,13 +2039,20 @@ [(null? lhs*) #f] [(bound-id=? x (car lhs*)) (car rhs*)] [else (find-bound=? x (cdr lhs*) (cdr rhs*))]))) + (define (find-dups ls) + (let f ([ls ls] [dups '()]) + (cond + [(null? ls) dups] + [(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) (define return (lambda (init* module-init** r mr lhs* lex* rhs*) (let ([mod-init* (apply append (reverse module-init**))]) (unless (valid-bound-ids? lhs*) - (error 'chi-internal "multiple definitions")) + (stx-error (find-dups lhs*) "multiple definitions in internal")) (let ([rhs* (chi-rhs* rhs* r mr)] [init* (chi-expr* (append mod-init* init*) r mr)]) (build-letrec no-source @@ -2064,7 +2071,7 @@ (case type [(define) (let-values ([(id rhs) (parse-define e)]) - (when (bound-id-member? id kwd*) + (when (bound-id-member? id kwd*) (stx-error id "undefined identifier")) (let ([lex (gen-lexical id)] [lab (gen-label id)]) @@ -2089,7 +2096,7 @@ module-init** (cons (cons lab b) r) (cons (cons lab b) mr) - lhs* lex* rhs* kwd*)))))] + lhs* lex* rhs* kwd*)))))] [(begin) (syntax-match e () [(_ x* ...) @@ -2107,7 +2114,7 @@ (f (cdr e*) (cons m-init* module-init**) r mr - (append m-lhs* lhs*) + (append m-exp-id* lhs*) (append m-lex* lex*) (append m-rhs* rhs*) kwd*))] @@ -2126,9 +2133,12 @@ (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*))]) + [e* (map (lambda (x) (add-subst rib x)) + (syntax->list e*))]) (define return (lambda (init* r mr lhs* lex* rhs* kwd*) + (unless (valid-bound-ids? lhs*) + (stx-error (find-dups lhs*) "multiple definitions in module")) (let ([exp-lab* (map (lambda (x) (or (id->label (add-subst rib x)) @@ -2181,7 +2191,8 @@ (let ([module-init* (apply append (reverse module-init**))]) (values (append module-init* init*) r mr (reverse lhs*) (reverse lex*) (reverse rhs*))))) - (let f ([e* e*] [module-init** '()] [r r] [mr r] [lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*]) + (let f ([e* e*] [module-init** '()] [r r] [mr r] + [lhs* '()] [lex* '()] [rhs* '()] [kwd* kwd*]) (cond [(null? e*) (return e* module-init** r mr lhs* lex* rhs*)] [else @@ -2227,7 +2238,7 @@ (f (cdr e*) (cons m-init* module-init**) r mr - (append m-lhs* lhs*) + (append m-exp-id* lhs*) (append m-lex* lex*) (append m-rhs* rhs*) kwd*))]