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

* fixed error in check-dups of modules in internal defines.

This commit is contained in:
Abdulaziz Ghuloum 2007-05-01 02:19:05 -04:00
parent 17664b1a37
commit 705e8f386b
4 changed files with 26 additions and 30 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.

18
src/libaltcogen.ss
View File

@ -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?)

13
src/libcompile.ss
View File

@ -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])

25
src/syntax.ss
View File

@ -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*))]