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

* applying unbound ids no longer segfaults

This commit is contained in:
Abdulaziz Ghuloum 2007-08-29 00:38:24 -04:00
parent 84d188451c
commit a20884c16b
4 changed files with 22 additions and 3 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.

22
src/ikarus.symbols.ss
View File

@ -4,7 +4,8 @@
gensym-count print-gensym string->symbol symbol->string
getprop putprop remprop property-list
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
(ikarus system $symbols)
(ikarus system $pairs)
@ -14,7 +15,7 @@
string->symbol symbol->string
getprop putprop remprop property-list
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
(case-lambda
@ -72,7 +73,22 @@
(lambda (x v)
(unless (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
(lambda (x)

1
src/makefile.ss
View File

@ -483,6 +483,7 @@
[symbol-value i symbols]
[top-level-value i symbols]
[set-symbol-value! i symbols]
[reset-symbol-proc! i symbols]
[make-guardian i]
[make-input-port i]
[make-output-port i]

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

@ -414,6 +414,7 @@
[else #f])) =>
(lambda (sym)
(record-symbol-call! sym)
(reset-symbol-proc! sym)
(prm 'mref (T (K sym))
(K (- disp-symbol-record-proc symbol-ptag))))]
[else (nonproc x)])]
@ -423,6 +424,7 @@
(define encountered-symbol-calls '())
(define (record-symbol-call! x)
(unless (memq x encountered-symbol-calls)
(set! encountered-symbol-calls
(cons x encountered-symbol-calls))))