diff --git a/src/ikarus.boot b/src/ikarus.boot index 88d6473..6605fd0 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.compiler.ss b/src/ikarus.compiler.ss index 7a911ea..88fe041 100644 --- a/src/ikarus.compiler.ss +++ b/src/ikarus.compiler.ss @@ -1934,7 +1934,7 @@ (error 'compile "cannot find location of primitive ~s" op)])) (define (primref-loc op) - (mem (fx- disp-symbol-record-value record-tag) + (mem (fx- disp-symbol-record-proc record-tag) (obj (primref->symbol op)))) diff --git a/src/ikarus.syntax.ss b/src/ikarus.syntax.ss index c5072b4..bf0fc75 100644 --- a/src/ikarus.syntax.ss +++ b/src/ikarus.syntax.ss @@ -2193,8 +2193,8 @@ (let ([invoke-body (if (and (null? init*) (null? lex*)) (build-void) (build-sequence no-source - (append - (map build-export lex*) + (cons + (build-exports lex*) (chi-expr* init* r mr))))]) (unseal-rib! rib) (let ([export-subst (make-export-subst exp-int* exp-ext* rib)]) @@ -2296,7 +2296,33 @@ (lambda (x) ;;; exports use the same gensym `(begin - (#%$set-symbol-value! ',x ,x)))) + (#%$set-symbol-value! ',x ,x) + (#%$set-symbol-proc! ',x + (if (#%procedure? ,x) ,x + (case-lambda + [,(gensym) + (#%error 'apply '"~s is not a procedure" + (#%$symbol-value ',x))])))))) + (define build-exports + (lambda (ls) + (define f (gensym)) + (define name (gensym)) + (define val (gensym)) + `((case-lambda + [(,f) + (begin '#f + ,@(map (lambda (x) `(,f ',x ,x)) ls))]) + (case-lambda + [(,name ,val) + (begin + (#%$set-symbol-value! ,name ,val) + (#%$set-symbol-proc! ,name + (if (#%procedure? ,val) ,val + (case-lambda + [,(gensym) + (#%error 'apply '"~s is not a procedure" + (#%$symbol-value ,name))]))))])))) + (define (make-export-subst int* ext* rib) (map (lambda (int ext) diff --git a/src/libaltcogen.ss b/src/libaltcogen.ss index eba99b5..7b48b57 100644 --- a/src/libaltcogen.ss +++ b/src/libaltcogen.ss @@ -357,7 +357,7 @@ (make-object (primref->symbol 'do-overflow))) - (make-constant (- disp-symbol-record-value symbol-ptag)))) + (make-constant (- disp-symbol-record-proc symbol-ptag)))) (list size))))) ;;; impose value (define (V d x) diff --git a/src/pass-specify-rep.ss b/src/pass-specify-rep.ss index 981c54a..c550aef 100644 --- a/src/pass-specify-rep.ss +++ b/src/pass-specify-rep.ss @@ -415,7 +415,7 @@ (lambda (sym) (record-symbol-call! sym) (prm 'mref (T (K sym)) - (K (- disp-symbol-record-value symbol-ptag))))] + (K (- disp-symbol-record-proc symbol-ptag))))] [else (nonproc x)])] [(primref op) (V x)] [else (nonproc x)])) @@ -458,57 +458,12 @@ free*)] [else (error 'specify-rep "invalid clambda ~s" x)])) ;;; - (define (error-codes) - (define (code-list symbol) - (define L1 (gensym)) - (define L2 (gensym)) - `(0 - [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) ,cp-register] - [andl ,closure-mask ,cp-register] - [cmpl ,closure-tag ,cp-register] - [jne (label ,L1)] - [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) ,cp-register] - [movl ,cp-register (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol))] - [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)] - [label ,L1] - [movl (disp ,(- disp-symbol-record-value symbol-ptag) (obj ,symbol)) %eax] - [cmpl ,unbound %eax] - [je (label ,L2)] - [movl (obj apply) (disp -4 %esp)] - [movl (obj "~s is not a procedure") (disp -8 %esp)] - [movl %eax (disp -12 %esp)] - [movl (obj ,(primref->symbol 'error)) ,cp-register] - [movl (disp ,(- disp-symbol-record-value symbol-ptag) - ,cp-register) ,cp-register] - [movl ,(argc-convention 3) %eax] - [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)] - [label ,L2] - [movl (obj ,symbol) (disp -4 %esp)] - [movl (obj ,(primref->symbol 'top-level-value)) ,cp-register] - [movl (disp ,(- disp-symbol-record-value symbol-ptag) - ,cp-register) ,cp-register] - [movl ,(argc-convention 1) %eax] - [jmp (disp ,(- disp-closure-code closure-tag) ,cp-register)])) - (let ([ls encountered-symbol-calls]) - (let ([c* (map code-list ls)]) - (let ([c* (assemble-sources (lambda (x) #f) c*)]) - (let ([p* (map (lambda (x) ($code->closure x)) c*)]) - (let f ([ls ls] [p* p*]) - (cond - [(null? ls) (prm 'nop)] - [else - (make-seq - (with-tmp ([p (V (K (car p*)))] [s (V (K (car ls)))]) - (E (prm '$init-symbol-function! s p))) - (f (cdr ls) (cdr p*)))]))))))) (define (Program x) (record-case x [(codes code* body) (let ([code* (map Clambda code*)] [body (V body)]) - (make-codes code* - ;(make-seq (error-codes) body) - body))] + (make-codes code* body))] [else (error 'specify-rep "invalid program ~s" x)])) (define (specify-representation x)