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

* make the "current-primitive-locations" a procedure that returns a 

location instead of an alist.
This commit is contained in:
Abdulaziz Ghuloum 2007-05-04 03:53:39 -04:00
parent 54c48777d7
commit 416f49caf5
2 changed files with 11 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.

14
src/libcompile.ss
View File

@ -3220,9 +3220,12 @@
(define (primref-loc op) (define (primref-loc op)
(unless (symbol? op) (error 'primref-loc "not a symbol ~s" op)) (unless (symbol? op) (error 'primref-loc "not a symbol ~s" op))
(cond (cond
[(assq op (current-primitive-locations)) => [((current-primitive-locations) op) =>
(lambda (x) (lambda (x)
(mem (fx- disp-symbol-value symbol-tag) (obj (cdr x))))] (unless (symbol? x)
(error 'primitive-location
"~s is not a valid location for ~s" x op))
(mem (fx- disp-symbol-value symbol-tag) (obj x)))]
[else [else
(mem (fx- disp-symbol-system-value symbol-tag) (mem (fx- disp-symbol-system-value symbol-tag)
(obj op))])) (obj op))]))
@ -5203,7 +5206,12 @@
(primitive-set! 'assembler-output (make-parameter #f)) (primitive-set! 'assembler-output (make-parameter #f))
(primitive-set! 'current-primitive-locations (primitive-set! 'current-primitive-locations
(make-parameter '())) (make-parameter
(lambda (x) #f)
(lambda (x)
(if (procedure? x)
x
(error 'current-primitive-locations "~s is not a procedure" x)))))
(initialize-system) (initialize-system)
(primitive-set! 'eval-core (primitive-set! 'eval-core