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

* Applying non-procedure library variables no longer segfaults.

This commit is contained in:
Abdulaziz Ghuloum 2007-08-29 00:21:29 -04:00
parent 1ca0e11fb3
commit 84d188451c
5 changed files with 33 additions and 52 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.

2
src/ikarus.compiler.ss
View File

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

32
src/ikarus.syntax.ss
View File

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

2
src/libaltcogen.ss
View File

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

49
src/pass-specify-rep.ss
View File

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