* 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

Binary file not shown.

View File

@ -1934,7 +1934,7 @@
(error 'compile "cannot find location of primitive ~s" op)])) (error 'compile "cannot find location of primitive ~s" op)]))
(define (primref-loc 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)))) (obj (primref->symbol op))))

View File

@ -2193,8 +2193,8 @@
(let ([invoke-body (if (and (null? init*) (null? lex*)) (let ([invoke-body (if (and (null? init*) (null? lex*))
(build-void) (build-void)
(build-sequence no-source (build-sequence no-source
(append (cons
(map build-export lex*) (build-exports lex*)
(chi-expr* init* r mr))))]) (chi-expr* init* r mr))))])
(unseal-rib! rib) (unseal-rib! rib)
(let ([export-subst (make-export-subst exp-int* exp-ext* rib)]) (let ([export-subst (make-export-subst exp-int* exp-ext* rib)])
@ -2296,7 +2296,33 @@
(lambda (x) (lambda (x)
;;; exports use the same gensym ;;; exports use the same gensym
`(begin `(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) (define (make-export-subst int* ext* rib)
(map (map
(lambda (int ext) (lambda (int ext)

View File

@ -357,7 +357,7 @@
(make-object (make-object
(primref->symbol (primref->symbol
'do-overflow))) 'do-overflow)))
(make-constant (- disp-symbol-record-value symbol-ptag)))) (make-constant (- disp-symbol-record-proc symbol-ptag))))
(list size))))) (list size)))))
;;; impose value ;;; impose value
(define (V d x) (define (V d x)

View File

@ -415,7 +415,7 @@
(lambda (sym) (lambda (sym)
(record-symbol-call! sym) (record-symbol-call! sym)
(prm 'mref (T (K sym)) (prm 'mref (T (K sym))
(K (- disp-symbol-record-value symbol-ptag))))] (K (- disp-symbol-record-proc symbol-ptag))))]
[else (nonproc x)])] [else (nonproc x)])]
[(primref op) (V x)] [(primref op) (V x)]
[else (nonproc x)])) [else (nonproc x)]))
@ -458,57 +458,12 @@
free*)] free*)]
[else (error 'specify-rep "invalid clambda ~s" x)])) [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) (define (Program x)
(record-case x (record-case x
[(codes code* body) [(codes code* body)
(let ([code* (map Clambda code*)] (let ([code* (map Clambda code*)]
[body (V body)]) [body (V body)])
(make-codes code* (make-codes code* body))]
;(make-seq (error-codes) body)
body))]
[else (error 'specify-rep "invalid program ~s" x)])) [else (error 'specify-rep "invalid program ~s" x)]))
(define (specify-representation x) (define (specify-representation x)