* applying unbound ids no longer segfaults
This commit is contained in:
parent
84d188451c
commit
a20884c16b
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -4,7 +4,8 @@
|
||||||
gensym-count print-gensym string->symbol symbol->string
|
gensym-count print-gensym string->symbol symbol->string
|
||||||
getprop putprop remprop property-list
|
getprop putprop remprop property-list
|
||||||
top-level-value top-level-bound? set-top-level-value!
|
top-level-value top-level-bound? set-top-level-value!
|
||||||
symbol-value symbol-bound? set-symbol-value!)
|
symbol-value symbol-bound? set-symbol-value!
|
||||||
|
reset-symbol-proc!)
|
||||||
(import
|
(import
|
||||||
(ikarus system $symbols)
|
(ikarus system $symbols)
|
||||||
(ikarus system $pairs)
|
(ikarus system $pairs)
|
||||||
|
@ -14,7 +15,7 @@
|
||||||
string->symbol symbol->string
|
string->symbol symbol->string
|
||||||
getprop putprop remprop property-list
|
getprop putprop remprop property-list
|
||||||
top-level-value top-level-bound? set-top-level-value!
|
top-level-value top-level-bound? set-top-level-value!
|
||||||
symbol-value symbol-bound? set-symbol-value!))
|
symbol-value symbol-bound? set-symbol-value! reset-symbol-proc!))
|
||||||
|
|
||||||
(define gensym
|
(define gensym
|
||||||
(case-lambda
|
(case-lambda
|
||||||
|
@ -72,7 +73,22 @@
|
||||||
(lambda (x v)
|
(lambda (x v)
|
||||||
(unless (symbol? x)
|
(unless (symbol? x)
|
||||||
(error 'set-symbol-value! "~s is not a symbol" x))
|
(error 'set-symbol-value! "~s is not a symbol" x))
|
||||||
($set-symbol-value! x v)))
|
($set-symbol-value! x v)
|
||||||
|
($set-symbol-proc! x
|
||||||
|
(if (procedure? v) v
|
||||||
|
(lambda args
|
||||||
|
(error 'apply "~s is not a procedure"
|
||||||
|
($symbol-value x)))))))
|
||||||
|
|
||||||
|
(define reset-symbol-proc!
|
||||||
|
(lambda (x)
|
||||||
|
(let ([v ($symbol-value x)])
|
||||||
|
($set-symbol-proc! x
|
||||||
|
(if (procedure? v)
|
||||||
|
v
|
||||||
|
(lambda args
|
||||||
|
(error 'apply "~s is not a procedure"
|
||||||
|
($symbol-value x))))))))
|
||||||
|
|
||||||
(define string->symbol
|
(define string->symbol
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
|
|
|
@ -483,6 +483,7 @@
|
||||||
[symbol-value i symbols]
|
[symbol-value i symbols]
|
||||||
[top-level-value i symbols]
|
[top-level-value i symbols]
|
||||||
[set-symbol-value! i symbols]
|
[set-symbol-value! i symbols]
|
||||||
|
[reset-symbol-proc! i symbols]
|
||||||
[make-guardian i]
|
[make-guardian i]
|
||||||
[make-input-port i]
|
[make-input-port i]
|
||||||
[make-output-port i]
|
[make-output-port i]
|
||||||
|
|
|
@ -414,6 +414,7 @@
|
||||||
[else #f])) =>
|
[else #f])) =>
|
||||||
(lambda (sym)
|
(lambda (sym)
|
||||||
(record-symbol-call! sym)
|
(record-symbol-call! sym)
|
||||||
|
(reset-symbol-proc! sym)
|
||||||
(prm 'mref (T (K sym))
|
(prm 'mref (T (K sym))
|
||||||
(K (- disp-symbol-record-proc symbol-ptag))))]
|
(K (- disp-symbol-record-proc symbol-ptag))))]
|
||||||
[else (nonproc x)])]
|
[else (nonproc x)])]
|
||||||
|
@ -423,6 +424,7 @@
|
||||||
|
|
||||||
(define encountered-symbol-calls '())
|
(define encountered-symbol-calls '())
|
||||||
(define (record-symbol-call! x)
|
(define (record-symbol-call! x)
|
||||||
|
|
||||||
(unless (memq x encountered-symbol-calls)
|
(unless (memq x encountered-symbol-calls)
|
||||||
(set! encountered-symbol-calls
|
(set! encountered-symbol-calls
|
||||||
(cons x encountered-symbol-calls))))
|
(cons x encountered-symbol-calls))))
|
||||||
|
|
Loading…
Reference in New Issue