* libcore now compiles with chaitin
This commit is contained in:
parent
434ebe9525
commit
1a4cdcb7b0
|
@ -39,6 +39,15 @@
|
||||||
[movl (disp -4 %esp) %eax]
|
[movl (disp -4 %esp) %eax]
|
||||||
[ret]))
|
[ret]))
|
||||||
|
|
||||||
|
(asm-test 1
|
||||||
|
'([movl 8 %eax]
|
||||||
|
[movl %eax (disp -4 %esp)]
|
||||||
|
[movl 4 %eax]
|
||||||
|
[subl %eax (disp -4 %esp)]
|
||||||
|
[movl -4 %eax]
|
||||||
|
[movl (disp -4 %esp) %eax]
|
||||||
|
[ret]))
|
||||||
|
|
||||||
(asm-test 1
|
(asm-test 1
|
||||||
'([movl 1 (disp -4 %esp)]
|
'([movl 1 (disp -4 %esp)]
|
||||||
[sall 2 (disp -4 %esp)]
|
[sall 2 (disp -4 %esp)]
|
||||||
|
|
BIN
src/ikarus.boot
BIN
src/ikarus.boot
Binary file not shown.
|
@ -119,6 +119,7 @@
|
||||||
'([pair? p]
|
'([pair? p]
|
||||||
[vector? p]
|
[vector? p]
|
||||||
[null? p]
|
[null? p]
|
||||||
|
[bwp-object? p]
|
||||||
[eof-object? p]
|
[eof-object? p]
|
||||||
[eof-object v]
|
[eof-object v]
|
||||||
[$unbound-object? p]
|
[$unbound-object? p]
|
||||||
|
@ -183,6 +184,7 @@
|
||||||
[$set-symbol-value! e]
|
[$set-symbol-value! e]
|
||||||
[$symbol-string v]
|
[$symbol-string v]
|
||||||
[$symbol-unique-string v]
|
[$symbol-unique-string v]
|
||||||
|
[$set-symbol-unique-string! e]
|
||||||
[$symbol-plist v]
|
[$symbol-plist v]
|
||||||
[$set-symbol-plist! e]
|
[$set-symbol-plist! e]
|
||||||
[$set-symbol-string! e]
|
[$set-symbol-string! e]
|
||||||
|
@ -211,6 +213,7 @@
|
||||||
[primitive-set! e]
|
[primitive-set! e]
|
||||||
[primitive-ref v]
|
[primitive-ref v]
|
||||||
|
|
||||||
|
[pointer-value v]
|
||||||
[$fp-at-base p]
|
[$fp-at-base p]
|
||||||
[$current-frame v]
|
[$current-frame v]
|
||||||
[$seal-frame-and-call tail]
|
[$seal-frame-and-call tail]
|
||||||
|
@ -218,6 +221,7 @@
|
||||||
|
|
||||||
[$make-call-with-values-procedure v]
|
[$make-call-with-values-procedure v]
|
||||||
[$make-values-procedure v]
|
[$make-values-procedure v]
|
||||||
|
[$arg-list v]
|
||||||
|
|
||||||
))
|
))
|
||||||
(define library-prims
|
(define library-prims
|
||||||
|
@ -642,7 +646,7 @@
|
||||||
(cond
|
(cond
|
||||||
[(null? n*) '()]
|
[(null? n*) '()]
|
||||||
[else
|
[else
|
||||||
(cons (prm 'int+ (list lhs (K n)))
|
(cons (prm 'int+ lhs (K n))
|
||||||
(adders lhs (+ n (car n*)) (cdr n*)))]))
|
(adders lhs (+ n (car n*)) (cdr n*)))]))
|
||||||
(define (build-closures lhs* rhs* body)
|
(define (build-closures lhs* rhs* body)
|
||||||
(let ([lhs (car lhs*)] [rhs (car rhs*)]
|
(let ([lhs (car lhs*)] [rhs (car rhs*)]
|
||||||
|
@ -737,69 +741,78 @@
|
||||||
[(primcall op arg*)
|
[(primcall op arg*)
|
||||||
(case op
|
(case op
|
||||||
[(nop) nop]
|
[(nop) nop]
|
||||||
[($cpset!)
|
;;;X[($cpset!)
|
||||||
(let ([x (Value (car arg*))]
|
;;;X (let ([x (Value (car arg*))]
|
||||||
[i (cadr arg*)]
|
;;;X [i (cadr arg*)]
|
||||||
[v (Value (caddr arg*))])
|
;;;X [v (Value (caddr arg*))])
|
||||||
(record-case i
|
;;;X (record-case i
|
||||||
[(constant i)
|
;;;X [(constant i)
|
||||||
(unless (fixnum? i) (err x))
|
;;;X (unless (fixnum? i) (err x))
|
||||||
(prm 'mset x
|
;;;X (prm 'mset x
|
||||||
(K (+ (* i wordsize)
|
;;;X (K (+ (* i wordsize)
|
||||||
(- disp-closure-data closure-tag)))
|
;;;X (- disp-closure-data closure-tag)))
|
||||||
v)]
|
;;;X v)]
|
||||||
[else (err x)]))]
|
;;;X [else (err x)]))]
|
||||||
[(primitive-set!)
|
[(primitive-set!)
|
||||||
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
|
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
|
||||||
(mem-assign v x
|
(mem-assign v x
|
||||||
(- disp-symbol-system-value symbol-tag)))]
|
(- disp-symbol-system-value symbol-tag)))]
|
||||||
[($set-symbol-value!)
|
[($set-symbol-value!)
|
||||||
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
|
(tbind ([x (Value (car arg*))]
|
||||||
|
[v (Value (cadr arg*))])
|
||||||
(mem-assign v x
|
(mem-assign v x
|
||||||
(- disp-symbol-value symbol-tag)))]
|
(- disp-symbol-value symbol-tag)))]
|
||||||
[($set-symbol-string!)
|
[($set-symbol-string!)
|
||||||
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
|
(tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
|
||||||
(mem-assign v x
|
(mem-assign v x
|
||||||
(- disp-symbol-string symbol-tag)))]
|
(- disp-symbol-string symbol-tag)))]
|
||||||
|
[($set-symbol-unique-string!)
|
||||||
|
(tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
|
||||||
|
(mem-assign v x
|
||||||
|
(- disp-symbol-unique-string symbol-tag)))]
|
||||||
[($set-symbol-plist!)
|
[($set-symbol-plist!)
|
||||||
(let ([x (Value (car arg*))] [v (Value (cadr arg*))])
|
(tbind ([x (Value (car arg*))] [v (Value (cadr arg*))])
|
||||||
(mem-assign v x
|
(mem-assign v x
|
||||||
(- disp-symbol-plist symbol-tag)))]
|
(- disp-symbol-plist symbol-tag)))]
|
||||||
[($vector-set! $record-set!)
|
[($vector-set! $record-set!)
|
||||||
(let ([x (Value (car arg*))]
|
(tbind ([x (Value (car arg*))]
|
||||||
[i (cadr arg*)]
|
|
||||||
[v (Value (caddr arg*))])
|
[v (Value (caddr arg*))])
|
||||||
|
(let ([i (cadr arg*)])
|
||||||
(record-case i
|
(record-case i
|
||||||
[(constant i)
|
[(constant i)
|
||||||
(unless (fixnum? i) (err x))
|
(unless (fixnum? i)
|
||||||
|
(error who "invalid arg ~s to ~s" i op))
|
||||||
(mem-assign v x
|
(mem-assign v x
|
||||||
(+ (* i wordsize)
|
(+ (* i wordsize)
|
||||||
(- disp-vector-data vector-tag)))]
|
(- disp-vector-data vector-tag)))]
|
||||||
[else
|
[else
|
||||||
|
(tbind ([i (Value i)])
|
||||||
(mem-assign v
|
(mem-assign v
|
||||||
(prm 'int+ x (Value i))
|
(prm 'int+ x i)
|
||||||
(- disp-vector-data vector-tag))]))]
|
(- disp-vector-data vector-tag)))])))]
|
||||||
[($set-car! $set-cdr!)
|
[($set-car! $set-cdr!)
|
||||||
(let ([off (if (eq? op '$set-car!)
|
(let ([off (if (eq? op '$set-car!)
|
||||||
(- disp-car pair-tag)
|
(- disp-car pair-tag)
|
||||||
(- disp-cdr pair-tag))])
|
(- disp-cdr pair-tag))])
|
||||||
(tbind ([x (Value (car arg*))])
|
(tbind ([x (Value (car arg*))]
|
||||||
|
[v (Value (cadr arg*))])
|
||||||
(seq* ;;; car/cdr addresses are in the same
|
(seq* ;;; car/cdr addresses are in the same
|
||||||
;;; card as the pair address, so no
|
;;; card as the pair address, so no
|
||||||
;;; adjustment is necessary as was the
|
;;; adjustment is necessary as was the
|
||||||
;;; case with vectors and records.
|
;;; case with vectors and records.
|
||||||
(prm 'mset x (K off) (Value (cadr arg*)))
|
(prm 'mset x (K off) v)
|
||||||
(dirty-vector-set x))))]
|
(dirty-vector-set x))))]
|
||||||
[($string-set!)
|
[($string-set!)
|
||||||
(let ([x (Value (car arg*))]
|
(tbind ([x (Value (car arg*))])
|
||||||
[i (cadr arg*)]
|
(let ([i (cadr arg*)]
|
||||||
[c (caddr arg*)])
|
[c (caddr arg*)])
|
||||||
(record-case i
|
(record-case i
|
||||||
[(constant i)
|
[(constant i)
|
||||||
(unless (fixnum? i) (err x))
|
(unless (fixnum? i)
|
||||||
|
(error who "invalid arg ~s to ~s" i op))
|
||||||
(record-case c
|
(record-case c
|
||||||
[(constant c)
|
[(constant c)
|
||||||
(unless (char? i) (err x))
|
(unless (char? c) (err x))
|
||||||
(prm 'bset/c x
|
(prm 'bset/c x
|
||||||
(K (+ i (- disp-string-data string-tag)))
|
(K (+ i (- disp-string-data string-tag)))
|
||||||
(K (char->integer c)))]
|
(K (char->integer c)))]
|
||||||
|
@ -814,7 +827,7 @@
|
||||||
(tbind ([i (Value i)])
|
(tbind ([i (Value i)])
|
||||||
(record-case c
|
(record-case c
|
||||||
[(constant c)
|
[(constant c)
|
||||||
(unless (char? i) (err x))
|
(unless (char? c) (err x))
|
||||||
(prm 'bset/c x
|
(prm 'bset/c x
|
||||||
(prm 'sra i (K fixnum-shift))
|
(prm 'sra i (K fixnum-shift))
|
||||||
(K (char->integer c)))]
|
(K (char->integer c)))]
|
||||||
|
@ -826,7 +839,7 @@
|
||||||
(prm 'int+
|
(prm 'int+
|
||||||
(prm 'sra i (K fixnum-shift))
|
(prm 'sra i (K fixnum-shift))
|
||||||
(K (- disp-string-data string-tag)))
|
(K (- disp-string-data string-tag)))
|
||||||
c))]))]))]
|
c))]))])))]
|
||||||
[else (error who "invalid effect prim ~s" op)])]
|
[else (error who "invalid effect prim ~s" op)])]
|
||||||
[(forcall op arg*)
|
[(forcall op arg*)
|
||||||
(make-forcall op (map Value arg*))]
|
(make-forcall op (map Value arg*))]
|
||||||
|
@ -839,20 +852,20 @@
|
||||||
[else (error who "invalid effect expr ~s" x)]))
|
[else (error who "invalid effect expr ~s" x)]))
|
||||||
;;;
|
;;;
|
||||||
(define (tag-test x mask tag)
|
(define (tag-test x mask tag)
|
||||||
|
(tbind ([x x])
|
||||||
(if mask
|
(if mask
|
||||||
(make-primcall '=
|
(make-primcall '=
|
||||||
(list (make-primcall 'logand
|
(list (make-primcall 'logand
|
||||||
(list x (make-constant mask)))
|
(list x (make-constant mask)))
|
||||||
(make-constant tag)))
|
(make-constant tag)))
|
||||||
(make-primcall '=
|
(make-primcall '=
|
||||||
(list x (make-constant tag)))))
|
(list x (make-constant tag))))))
|
||||||
(define (sec-tag-test x pmask ptag smask stag)
|
(define (sec-tag-test x pmask ptag smask stag)
|
||||||
(let ([t (unique-var 'tmp)])
|
(tbind ([t x])
|
||||||
(make-bind (list t) (list x)
|
|
||||||
(make-conditional
|
(make-conditional
|
||||||
(tag-test t pmask ptag)
|
(tag-test t pmask ptag)
|
||||||
(tag-test (prm 'mref t (K (- ptag))) smask stag)
|
(tag-test (prm 'mref t (K (- ptag))) smask stag)
|
||||||
(make-constant #f)))))
|
(make-constant #f))))
|
||||||
;;;
|
;;;
|
||||||
(define (Pred x)
|
(define (Pred x)
|
||||||
(record-case x
|
(record-case x
|
||||||
|
@ -870,6 +883,7 @@
|
||||||
[(eq?) (make-primcall '= (map Value arg*))]
|
[(eq?) (make-primcall '= (map Value arg*))]
|
||||||
[(null?) (prm '= (Value (car arg*)) (K nil))]
|
[(null?) (prm '= (Value (car arg*)) (K nil))]
|
||||||
[(eof-object?) (prm '= (Value (car arg*)) (K eof))]
|
[(eof-object?) (prm '= (Value (car arg*)) (K eof))]
|
||||||
|
[(bwp-object?) (prm '= (Value (car arg*)) (K bwp-object))]
|
||||||
[(neq?) (make-primcall '!= (map Value arg*))]
|
[(neq?) (make-primcall '!= (map Value arg*))]
|
||||||
[($fxzero?) (prm '= (Value (car arg*)) (K 0))]
|
[($fxzero?) (prm '= (Value (car arg*)) (K 0))]
|
||||||
[($unbound-object?) (prm '= (Value (car arg*)) (K unbound))]
|
[($unbound-object?) (prm '= (Value (car arg*)) (K unbound))]
|
||||||
|
@ -903,12 +917,11 @@
|
||||||
(sec-tag-test (Value (car arg*))
|
(sec-tag-test (Value (car arg*))
|
||||||
vector-mask vector-tag port-mask port-tag)]
|
vector-mask vector-tag port-mask port-tag)]
|
||||||
[($record/rtd?)
|
[($record/rtd?)
|
||||||
(tbind ([t (Value (car arg*))])
|
(tbind ([t (Value (car arg*))]
|
||||||
|
[v (Value (cadr arg*))])
|
||||||
(make-conditional
|
(make-conditional
|
||||||
(tag-test t vector-mask vector-tag)
|
(tag-test t vector-mask vector-tag)
|
||||||
(prm '=
|
(prm '= (prm 'mref t (K (- vector-tag))) v)
|
||||||
(prm 'mref t (K (- vector-tag)))
|
|
||||||
(Value (cadr arg*)))
|
|
||||||
(make-constant #f)))]
|
(make-constant #f)))]
|
||||||
[(immediate?)
|
[(immediate?)
|
||||||
(tbind ([t (Value (car arg*))])
|
(tbind ([t (Value (car arg*))])
|
||||||
|
@ -973,24 +986,31 @@
|
||||||
[(void) (K void-object)]
|
[(void) (K void-object)]
|
||||||
[(eof-object) (K eof)]
|
[(eof-object) (K eof)]
|
||||||
[($car)
|
[($car)
|
||||||
(prm 'mref (Value (car arg*)) (K (- disp-car pair-tag)))]
|
(tbind ([x (Value (car arg*))])
|
||||||
|
(prm 'mref x (K (- disp-car pair-tag))))]
|
||||||
[($cdr)
|
[($cdr)
|
||||||
(prm 'mref (Value (car arg*)) (K (- disp-cdr pair-tag)))]
|
(tbind ([x (Value (car arg*))])
|
||||||
|
(prm 'mref x (K (- disp-cdr pair-tag))))]
|
||||||
[(primitive-ref)
|
[(primitive-ref)
|
||||||
(prm 'mref (Value (car arg*))
|
(tbind ([x (Value (car arg*))])
|
||||||
(K (- disp-symbol-system-value symbol-tag)))]
|
(prm 'mref x
|
||||||
|
(K (- disp-symbol-system-value symbol-tag))))]
|
||||||
[($symbol-string)
|
[($symbol-string)
|
||||||
(prm 'mref (Value (car arg*))
|
(tbind ([x (Value (car arg*))])
|
||||||
(K (- disp-symbol-string symbol-tag)))]
|
(prm 'mref x
|
||||||
|
(K (- disp-symbol-string symbol-tag))))]
|
||||||
[($symbol-plist)
|
[($symbol-plist)
|
||||||
(prm 'mref (Value (car arg*))
|
(tbind ([x (Value (car arg*))])
|
||||||
(K (- disp-symbol-plist symbol-tag)))]
|
(prm 'mref x
|
||||||
|
(K (- disp-symbol-plist symbol-tag))))]
|
||||||
[($symbol-value)
|
[($symbol-value)
|
||||||
(prm 'mref (Value (car arg*))
|
(tbind ([x (Value (car arg*))])
|
||||||
(K (- disp-symbol-value symbol-tag)))]
|
(prm 'mref x
|
||||||
|
(K (- disp-symbol-value symbol-tag))))]
|
||||||
[($symbol-unique-string)
|
[($symbol-unique-string)
|
||||||
(prm 'mref (Value (car arg*))
|
(tbind ([x (Value (car arg*))])
|
||||||
(K (- disp-symbol-unique-string symbol-tag)))]
|
(prm 'mref x
|
||||||
|
(K (- disp-symbol-unique-string symbol-tag))))]
|
||||||
[($make-symbol)
|
[($make-symbol)
|
||||||
(tbind ([str (Value (car arg*))])
|
(tbind ([str (Value (car arg*))])
|
||||||
(tbind ([x (prm 'alloc
|
(tbind ([x (prm 'alloc
|
||||||
|
@ -1016,21 +1036,21 @@
|
||||||
(K (- disp-symbol-system-plist symbol-tag))
|
(K (- disp-symbol-system-plist symbol-tag))
|
||||||
(K nil))
|
(K nil))
|
||||||
x)))]
|
x)))]
|
||||||
[($make-cp)
|
;;;X[($make-cp)
|
||||||
(let ([label (car arg*)] [len (cadr arg*)])
|
;;;X (let ([label (car arg*)] [len (cadr arg*)])
|
||||||
(record-case len
|
;;;X (record-case len
|
||||||
[(constant i)
|
;;;X [(constant i)
|
||||||
(unless (fixnum? i) (err x))
|
;;;X (unless (fixnum? i) (err x))
|
||||||
(tbind ([t (prm 'alloc
|
;;;X (tbind ([t (prm 'alloc
|
||||||
(K (align (+ disp-closure-data
|
;;;X (K (align (+ disp-closure-data
|
||||||
(* i wordsize))))
|
;;;X (* i wordsize))))
|
||||||
(K closure-tag))])
|
;;;X (K closure-tag))])
|
||||||
(seq*
|
;;;X (seq*
|
||||||
(prm 'mset t
|
;;;X (prm 'mset t
|
||||||
(K (- disp-closure-code closure-tag))
|
;;;X (K (- disp-closure-code closure-tag))
|
||||||
(Value label))
|
;;;X (Value label))
|
||||||
t))]
|
;;;X t))]
|
||||||
[else (err x)]))]
|
;;;X [else (err x)]))]
|
||||||
[($record)
|
[($record)
|
||||||
(let ([rtd (car arg*)] [v* (map Value (cdr arg*))])
|
(let ([rtd (car arg*)] [v* (map Value (cdr arg*))])
|
||||||
(tbind ([rtd (Value rtd)])
|
(tbind ([rtd (Value rtd)])
|
||||||
|
@ -1054,8 +1074,9 @@
|
||||||
(prm 'mset t (K i) (car t*))
|
(prm 'mset t (K i) (car t*))
|
||||||
(f (cdr t*) (+ i wordsize)))]))))))))]
|
(f (cdr t*) (+ i wordsize)))]))))))))]
|
||||||
[($vector-length)
|
[($vector-length)
|
||||||
(prm 'mref (Value (car arg*))
|
(tbind ([x (Value (car arg*))])
|
||||||
(K (- disp-vector-length vector-tag)))]
|
(prm 'mref x
|
||||||
|
(K (- disp-vector-length vector-tag))))]
|
||||||
[($make-vector)
|
[($make-vector)
|
||||||
(unless (= (length arg*) 1)
|
(unless (= (length arg*) 1)
|
||||||
(error who "incorrect args to $make-vector"))
|
(error who "incorrect args to $make-vector"))
|
||||||
|
@ -1082,34 +1103,35 @@
|
||||||
len)
|
len)
|
||||||
v))))]))]
|
v))))]))]
|
||||||
[($string-length)
|
[($string-length)
|
||||||
(prm 'mref (Value (car arg*))
|
(tbind ([x (Value (car arg*))])
|
||||||
(K (- disp-string-length string-tag)))]
|
(prm 'mref x
|
||||||
|
(K (- disp-string-length string-tag))))]
|
||||||
[($string-ref)
|
[($string-ref)
|
||||||
(let ([s (car arg*)] [i (cadr arg*)])
|
(tbind ([s (Value (car arg*))])
|
||||||
|
(let ([i (cadr arg*)])
|
||||||
(record-case i
|
(record-case i
|
||||||
[(constant i)
|
[(constant i)
|
||||||
(unless (fixnum? i) (err x))
|
(unless (fixnum? i) (err x))
|
||||||
(prm 'logor
|
(prm 'logor
|
||||||
(prm 'sll
|
(prm 'sll
|
||||||
(prm 'logand
|
(prm 'logand
|
||||||
(prm 'mref (Value s)
|
(prm 'mref s
|
||||||
(K (+ i (- disp-string-data string-tag))))
|
(K (+ i (- disp-string-data string-tag))))
|
||||||
(K 255))
|
(K 255))
|
||||||
(K char-shift))
|
(K char-shift))
|
||||||
(K char-tag))]
|
(K char-tag))]
|
||||||
[else
|
[else
|
||||||
|
(tbind ([i (Value i)])
|
||||||
(prm 'logor
|
(prm 'logor
|
||||||
(prm 'sll
|
(prm 'sll
|
||||||
(prm 'logand
|
(prm 'logand
|
||||||
(prm 'mref (Value s)
|
(prm 'mref s
|
||||||
(prm 'int+
|
(prm 'int+
|
||||||
(prm 'sra
|
(prm 'sra i (K fixnum-shift))
|
||||||
(Value i)
|
|
||||||
(K fixnum-shift))
|
|
||||||
(K (- disp-string-data string-tag))))
|
(K (- disp-string-data string-tag))))
|
||||||
(K 255))
|
(K 255))
|
||||||
(K char-shift))
|
(K char-shift))
|
||||||
(K char-tag))]))]
|
(K char-tag)))])))]
|
||||||
[($make-string)
|
[($make-string)
|
||||||
(unless (= (length arg*) 1) (err x))
|
(unless (= (length arg*) 1) (err x))
|
||||||
(let ([n (car arg*)])
|
(let ([n (car arg*)])
|
||||||
|
@ -1170,8 +1192,9 @@
|
||||||
rtd)
|
rtd)
|
||||||
t))))])))]
|
t))))])))]
|
||||||
[($record-rtd)
|
[($record-rtd)
|
||||||
(prm 'mref (Value (car arg*))
|
(tbind ([x (Value (car arg*))])
|
||||||
(K (- disp-record-rtd vector-tag)))]
|
(prm 'mref x
|
||||||
|
(K (- disp-record-rtd vector-tag))))]
|
||||||
[(cons)
|
[(cons)
|
||||||
(tbind ([a (Value (car arg*))]
|
(tbind ([a (Value (car arg*))]
|
||||||
[d (Value (cadr arg*))])
|
[d (Value (cadr arg*))])
|
||||||
|
@ -1193,20 +1216,20 @@
|
||||||
(record-case a
|
(record-case a
|
||||||
[(constant a)
|
[(constant a)
|
||||||
(unless (fixnum? a) (err x))
|
(unless (fixnum? a) (err x))
|
||||||
(prm 'int* (Value b) (K a))]
|
(tbind ([b (Value b)])
|
||||||
|
(prm 'int* b (K a)))]
|
||||||
[else
|
[else
|
||||||
(record-case b
|
(record-case b
|
||||||
[(constant b)
|
[(constant b)
|
||||||
(unless (fixnum? b) (err x))
|
(unless (fixnum? b) (err x))
|
||||||
(prm 'int* (Value a) (K b))]
|
(tbind ([a (Value a)])
|
||||||
|
(prm 'int* a (K b)))]
|
||||||
[else
|
[else
|
||||||
(prm 'int*
|
(tbind ([a (Value a)] [b (Value b)])
|
||||||
(Value a)
|
(prm 'int* a (prm 'sra b (K fixnum-shift))))])]))]
|
||||||
(prm 'sra (Value b) (K fixnum-shift)))])]))]
|
|
||||||
[($fxquotient)
|
[($fxquotient)
|
||||||
(prm 'sll
|
(tbind ([a (Value (car arg*))] [b (Value (cadr arg*))])
|
||||||
(prm 'remainder (Value (car arg*)) (Value (cadr arg*)))
|
(prm 'sll (prm 'remainder a b) (K fixnum-shift)))]
|
||||||
(K fixnum-shift))]
|
|
||||||
[($fxmodulo)
|
[($fxmodulo)
|
||||||
(tbind ([a (Value (car arg*))]
|
(tbind ([a (Value (car arg*))]
|
||||||
[b (Value (cadr arg*))])
|
[b (Value (cadr arg*))])
|
||||||
|
@ -1220,25 +1243,30 @@
|
||||||
(record-case c
|
(record-case c
|
||||||
[(constant i)
|
[(constant i)
|
||||||
(if (fixnum? i)
|
(if (fixnum? i)
|
||||||
(prm 'sll (Value a) (K i))
|
(tbind ([a (Value a)])
|
||||||
|
(prm 'sll a (K i)))
|
||||||
(error who "invalid arg to fxsll ~s" i))]
|
(error who "invalid arg to fxsll ~s" i))]
|
||||||
[else
|
[else
|
||||||
(prm 'sll (Value a)
|
(tbind ([a (Value a)] [c (Value c)])
|
||||||
(prm 'sra (Value c) (K fixnum-shift)))]))]
|
(prm 'sll a (prm 'sra c (K fixnum-shift))))]))]
|
||||||
[($fxsra)
|
[($fxsra)
|
||||||
(let ([a (car arg*)] [c (cadr arg*)])
|
(let ([a (car arg*)] [c (cadr arg*)])
|
||||||
(record-case c
|
(record-case c
|
||||||
[(constant i)
|
[(constant i)
|
||||||
(if (fixnum? i)
|
(if (fixnum? i)
|
||||||
(prm 'sra (Value a) (K i))
|
(tbind ([a (Value a)])
|
||||||
|
(prm 'sra a (K i)))
|
||||||
(error who "invalid arg to fxsra ~s" i))]
|
(error who "invalid arg to fxsra ~s" i))]
|
||||||
[else
|
[else
|
||||||
|
(tbind ([a (Value a)] [c (Value c)])
|
||||||
(prm 'logand
|
(prm 'logand
|
||||||
(prm 'sra (Value a)
|
(prm 'sra a
|
||||||
(prm 'sra (Value c) (K fixnum-shift)))
|
(prm 'sra c (K fixnum-shift)))
|
||||||
(K (* -1 fixnum-scale)))]))]
|
(K (* -1 fixnum-scale))))]))]
|
||||||
[($fxlogand)
|
[($fxlogand)
|
||||||
(prm 'logand (Value (car arg*)) (Value (cadr arg*)))]
|
(prm 'logand (Value (car arg*)) (Value (cadr arg*)))]
|
||||||
|
[(pointer-value)
|
||||||
|
(prm 'logand (Value (car arg*)) (K (* -1 fixnum-scale)))]
|
||||||
[($fxlogxor)
|
[($fxlogxor)
|
||||||
(prm 'logxor (Value (car arg*)) (Value (cadr arg*)))]
|
(prm 'logxor (Value (car arg*)) (Value (cadr arg*)))]
|
||||||
[($fxlogor)
|
[($fxlogor)
|
||||||
|
@ -1246,16 +1274,18 @@
|
||||||
[($fxlognot)
|
[($fxlognot)
|
||||||
(Value (prm '$fxlogxor (car arg*) (K -1)))]
|
(Value (prm '$fxlogxor (car arg*) (K -1)))]
|
||||||
[($char->fixnum)
|
[($char->fixnum)
|
||||||
(prm 'sra
|
(tbind ([x (Value (car arg*))])
|
||||||
(Value (car arg*))
|
(prm 'sra x
|
||||||
(K (- char-shift fixnum-shift)))]
|
(K (- char-shift fixnum-shift))))]
|
||||||
[($fixnum->char)
|
[($fixnum->char)
|
||||||
|
(tbind ([x (Value (car arg*))])
|
||||||
(prm 'logor
|
(prm 'logor
|
||||||
(prm 'sll (Value (car arg*))
|
(prm 'sll x (K (- char-shift fixnum-shift)))
|
||||||
(K (- char-shift fixnum-shift)))
|
(K char-tag)))]
|
||||||
(K char-tag))]
|
|
||||||
[($current-frame) ;; PCB NEXT-CONTINUATION
|
[($current-frame) ;; PCB NEXT-CONTINUATION
|
||||||
(prm 'mref pcr (K 20))]
|
(prm 'mref pcr (K 20))]
|
||||||
|
[($arg-list) ;; PCB ARGS-LIST
|
||||||
|
(prm 'mref pcr (K 32))]
|
||||||
[($seal-frame-and-call)
|
[($seal-frame-and-call)
|
||||||
(tbind ([proc (Value (car arg*))])
|
(tbind ([proc (Value (car arg*))])
|
||||||
(tbind ([k (prm 'alloc
|
(tbind ([k (prm 'alloc
|
||||||
|
@ -1305,35 +1335,34 @@
|
||||||
(record-case a1
|
(record-case a1
|
||||||
[(constant i)
|
[(constant i)
|
||||||
(unless (fixnum? i) (err x))
|
(unless (fixnum? i) (err x))
|
||||||
(prm 'mref (Value a0)
|
(tbind ([a0 (Value a0)])
|
||||||
|
(prm 'mref a0
|
||||||
(K (+ (- disp-closure-data closure-tag)
|
(K (+ (- disp-closure-data closure-tag)
|
||||||
(* i wordsize))))]
|
(* i wordsize)))))]
|
||||||
[else (err x)]))]
|
[else (err x)]))]
|
||||||
[($vector-ref $record-ref)
|
[($vector-ref $record-ref)
|
||||||
(let ([a0 (car arg*)] [a1 (cadr arg*)])
|
(let ([a0 (car arg*)] [a1 (cadr arg*)])
|
||||||
(record-case a1
|
(record-case a1
|
||||||
[(constant i)
|
[(constant i)
|
||||||
(unless (fixnum? i) (err x))
|
(unless (fixnum? i) (err x))
|
||||||
(make-primcall 'mref
|
(tbind ([a0 (Value a0)])
|
||||||
(list (Value a0)
|
(prm 'mref a0
|
||||||
(K (+ (- disp-vector-data vector-tag)
|
(K (+ (- disp-vector-data vector-tag)
|
||||||
(* i wordsize)))))]
|
(* i wordsize)))))]
|
||||||
[else
|
[else
|
||||||
(make-primcall 'mref
|
(tbind ([a0 (Value a0)] [a1 (Value a1)])
|
||||||
(list (make-primcall 'int+
|
(prm 'mref (prm 'int+ a0 a1)
|
||||||
(list (Value a0)
|
|
||||||
(Value a1)))
|
|
||||||
(K (- disp-vector-data vector-tag))))]))]
|
(K (- disp-vector-data vector-tag))))]))]
|
||||||
[($closure-code)
|
[($closure-code)
|
||||||
|
(tbind ([x (Value (car arg*))])
|
||||||
(prm 'int+
|
(prm 'int+
|
||||||
(prm 'mref
|
(prm 'mref x
|
||||||
(Value (car arg*))
|
|
||||||
(K (- disp-closure-code closure-tag)))
|
(K (- disp-closure-code closure-tag)))
|
||||||
(K (- vector-tag disp-code-data)))]
|
(K (- vector-tag disp-code-data))))]
|
||||||
[($code-freevars)
|
[($code-freevars)
|
||||||
(prm 'mref
|
(tbind ([x (Value (car arg*))])
|
||||||
(Value (car arg*))
|
(prm 'mref x
|
||||||
(K (- disp-code-freevars vector-tag)))]
|
(K (- disp-code-freevars vector-tag))))]
|
||||||
[(top-level-value)
|
[(top-level-value)
|
||||||
(let ([sym
|
(let ([sym
|
||||||
(record-case (car arg*)
|
(record-case (car arg*)
|
||||||
|
@ -1748,6 +1777,7 @@
|
||||||
[(codes code* body)
|
[(codes code* body)
|
||||||
(make-codes (map Clambda code*) (Main body))]))
|
(make-codes (map Clambda code*) (Main body))]))
|
||||||
;;;
|
;;;
|
||||||
|
; (print-code x)
|
||||||
(Program x))
|
(Program x))
|
||||||
|
|
||||||
|
|
||||||
|
@ -2156,7 +2186,7 @@
|
||||||
(let ([i (actual-frame-size vars
|
(let ([i (actual-frame-size vars
|
||||||
(fx+ 2 (max-live live-fv* 0)))])
|
(fx+ 2 (max-live live-fv* 0)))])
|
||||||
(assign-frame-vars! vars i)
|
(assign-frame-vars! vars i)
|
||||||
(NFE (fxsub1 i) (make-mask i live-fv*) body)))]
|
(NFE (fxsub1 i) (make-mask (fxsub1 i) live-fv*) body)))]
|
||||||
[(ntcall) x]
|
[(ntcall) x]
|
||||||
[else (error who "invalid effect ~s" x)]))
|
[else (error who "invalid effect ~s" x)]))
|
||||||
(define (P x)
|
(define (P x)
|
||||||
|
@ -2485,7 +2515,7 @@
|
||||||
'(byte 0)
|
'(byte 0)
|
||||||
LCALL
|
LCALL
|
||||||
`(call %ebx)
|
`(call %ebx)
|
||||||
;;ik_foreign_call adjusts fp back
|
`(addl ,(* (fxsub1 size) wordsize) ,fpr)
|
||||||
ac)]
|
ac)]
|
||||||
[target ;;; known call
|
[target ;;; known call
|
||||||
(list* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
|
(list* `(subl ,(* (fxsub1 size) wordsize) ,fpr)
|
||||||
|
|
285
src/libcore.ss
285
src/libcore.ss
|
@ -11,6 +11,7 @@
|
||||||
(primitive-set! 'call-with-values
|
(primitive-set! 'call-with-values
|
||||||
($make-call-with-values-procedure))
|
($make-call-with-values-procedure))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'values
|
(primitive-set! 'values
|
||||||
($make-values-procedure))
|
($make-values-procedure))
|
||||||
|
|
||||||
|
@ -28,13 +29,19 @@
|
||||||
(primitive-set! 'eof-object?
|
(primitive-set! 'eof-object?
|
||||||
(lambda (x) (eof-object? x)))
|
(lambda (x) (eof-object? x)))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'fxadd1
|
(primitive-set! 'fxadd1
|
||||||
(lambda (n)
|
(lambda (n)
|
||||||
(fxadd1 n)))
|
(if (fixnum? n)
|
||||||
|
($fxadd1 n)
|
||||||
|
(error 'fxadd1 "~s is not a fixnum" n))))
|
||||||
|
|
||||||
(primitive-set! 'fxsub1
|
(primitive-set! 'fxsub1
|
||||||
(lambda (n)
|
(lambda (n)
|
||||||
(fxsub1 n)))
|
(if (fixnum? n)
|
||||||
|
($fxsub1 n)
|
||||||
|
(error 'fxsub1 "~s is not a fixnum" n))))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'integer->char
|
(primitive-set! 'integer->char
|
||||||
(lambda (n)
|
(lambda (n)
|
||||||
|
@ -97,6 +104,7 @@
|
||||||
(fill! ($make-vector n) 0 n fill)]))
|
(fill! ($make-vector n) 0 n fill)]))
|
||||||
(primitive-set! 'make-vector make-vector))
|
(primitive-set! 'make-vector make-vector))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'vector-length
|
(primitive-set! 'vector-length
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(unless (vector? x)
|
(unless (vector? x)
|
||||||
|
@ -132,6 +140,7 @@
|
||||||
(error 'string-length "~s is not a string" x))
|
(error 'string-length "~s is not a string" x))
|
||||||
($string-length x)))
|
($string-length x)))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'string->list
|
(primitive-set! 'string->list
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(unless (string? x)
|
(unless (string? x)
|
||||||
|
@ -192,6 +201,35 @@ description:
|
||||||
(strings=? s s* ($string-length s))
|
(strings=? s s* ($string-length s))
|
||||||
(err s))])))
|
(err s))])))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(primitive-set! 'string-ref
|
||||||
|
(lambda (s i)
|
||||||
|
(unless (string? s)
|
||||||
|
(error 'string-ref "~s is not a string" s))
|
||||||
|
(unless (fixnum? i)
|
||||||
|
(error 'string-ref "~s is not a valid index" i))
|
||||||
|
(unless (and ($fx< i ($string-length s))
|
||||||
|
($fx<= 0 i))
|
||||||
|
(error 'string-ref "index ~s is out of range for ~s" i s))
|
||||||
|
($string-ref s i)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(primitive-set! 'string-set!
|
||||||
|
(lambda (s i c)
|
||||||
|
(unless (string? s)
|
||||||
|
(error 'string-set! "~s is not a string" s))
|
||||||
|
(unless (fixnum? i)
|
||||||
|
(error 'string-set! "~s is not a valid index" i))
|
||||||
|
(unless (and ($fx< i ($string-length s))
|
||||||
|
($fx>= i 0))
|
||||||
|
(error 'string-set! "index ~s is out of range for ~s" i s))
|
||||||
|
(unless (char? c)
|
||||||
|
(error 'string-set! "~s is not a character" c))
|
||||||
|
($string-set! s i c)))
|
||||||
|
|
||||||
|
|
||||||
#|procedure:string-append
|
#|procedure:string-append
|
||||||
synopsis:
|
synopsis:
|
||||||
(string-append str ...)
|
(string-append str ...)
|
||||||
|
@ -234,6 +272,9 @@ reference-implementation:
|
||||||
(let ([s ($make-string n)])
|
(let ([s ($make-string n)])
|
||||||
(fill-strings s s* 0))))))
|
(fill-strings s s* 0))))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#|procedure:substring
|
#|procedure:substring
|
||||||
(substring str i j)
|
(substring str i j)
|
||||||
Returns a substring of str starting from index i (inclusive)
|
Returns a substring of str starting from index i (inclusive)
|
||||||
|
@ -267,17 +308,7 @@ reference-implementation:
|
||||||
(primitive-set! 'not
|
(primitive-set! 'not
|
||||||
(lambda (x) (if x #f #t)))
|
(lambda (x) (if x #f #t)))
|
||||||
|
|
||||||
(primitive-set! 'symbol->string
|
|
||||||
(lambda (x)
|
|
||||||
(unless (symbol? x)
|
|
||||||
(error 'symbol->string "~s is not a symbol" x))
|
|
||||||
(let ([str ($symbol-string x)])
|
|
||||||
(or str
|
|
||||||
(let ([ct (gensym-count)])
|
|
||||||
(let ([str (string-append (gensym-prefix) (fixnum->string ct))])
|
|
||||||
($set-symbol-string! x str)
|
|
||||||
(gensym-count ($fxadd1 ct))
|
|
||||||
str))))))
|
|
||||||
|
|
||||||
(primitive-set! 'gensym?
|
(primitive-set! 'gensym?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
|
@ -285,37 +316,6 @@ reference-implementation:
|
||||||
(let ([s ($symbol-unique-string x)])
|
(let ([s ($symbol-unique-string x)])
|
||||||
(and s #t)))))
|
(and s #t)))))
|
||||||
|
|
||||||
(let ()
|
|
||||||
(define f
|
|
||||||
(lambda (n i j)
|
|
||||||
(cond
|
|
||||||
[($fxzero? n)
|
|
||||||
(values (make-string i) j)]
|
|
||||||
[else
|
|
||||||
(let ([q ($fxquotient n 10)])
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (f q ($fxadd1 i) j))
|
|
||||||
(lambda (str j)
|
|
||||||
(let ([r ($fx- n ($fx* q 10))])
|
|
||||||
(string-set! str j
|
|
||||||
($fixnum->char ($fx+ r ($char->fixnum #\0))))
|
|
||||||
(values str ($fxadd1 j))))))])))
|
|
||||||
(primitive-set! 'fixnum->string
|
|
||||||
(lambda (x)
|
|
||||||
(unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x))
|
|
||||||
(cond
|
|
||||||
[($fxzero? x) "0"]
|
|
||||||
[($fx> x 0)
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (f x 0 0))
|
|
||||||
(lambda (str j) str))]
|
|
||||||
[($fx= x -536870912) "-536870912"]
|
|
||||||
[else
|
|
||||||
(call-with-values
|
|
||||||
(lambda () (f ($fx- 0 x) 1 1))
|
|
||||||
(lambda (str j)
|
|
||||||
($string-set! str 0 #\-)
|
|
||||||
str))]))))
|
|
||||||
|
|
||||||
;;; OLD (primitive-set! 'top-level-value
|
;;; OLD (primitive-set! 'top-level-value
|
||||||
;;; OLD (lambda (x)
|
;;; OLD (lambda (x)
|
||||||
|
@ -366,13 +366,14 @@ reference-implementation:
|
||||||
(primitive-set! x v)
|
(primitive-set! x v)
|
||||||
(set-top-level-value! x v)))
|
(set-top-level-value! x v)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'fx+
|
(primitive-set! 'fx+
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
(fx+ x y)))
|
(unless (fixnum? x)
|
||||||
|
(error 'fx+ "~s is not a fixnum" x))
|
||||||
|
(unless (fixnum? y)
|
||||||
|
(error 'fx+ "~s is not a fixnum" y))
|
||||||
|
($fx+ x y)))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'fx-
|
(primitive-set! 'fx-
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
|
@ -382,6 +383,7 @@ reference-implementation:
|
||||||
(error 'fx- "~s is not a fixnum" y))
|
(error 'fx- "~s is not a fixnum" y))
|
||||||
($fx- x y)))
|
($fx- x y)))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'fx*
|
(primitive-set! 'fx*
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
(unless (fixnum? x)
|
(unless (fixnum? x)
|
||||||
|
@ -390,8 +392,6 @@ reference-implementation:
|
||||||
(error 'fx* "~s is not a fixnum" y))
|
(error 'fx* "~s is not a fixnum" y))
|
||||||
($fx* x y)))
|
($fx* x y)))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'fxquotient
|
(primitive-set! 'fxquotient
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
(unless (fixnum? x)
|
(unless (fixnum? x)
|
||||||
|
@ -402,7 +402,6 @@ reference-implementation:
|
||||||
(error 'fxquotient "zero dividend ~s" y))
|
(error 'fxquotient "zero dividend ~s" y))
|
||||||
($fxquotient x y)))
|
($fxquotient x y)))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'fxremainder
|
(primitive-set! 'fxremainder
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
(unless (fixnum? x)
|
(unless (fixnum? x)
|
||||||
|
@ -414,7 +413,6 @@ reference-implementation:
|
||||||
(let ([q ($fxquotient x y)])
|
(let ([q ($fxquotient x y)])
|
||||||
($fx- x ($fx* q y)))))
|
($fx- x ($fx* q y)))))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'fxmodulo
|
(primitive-set! 'fxmodulo
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
(unless (fixnum? x)
|
(unless (fixnum? x)
|
||||||
|
@ -425,7 +423,6 @@ reference-implementation:
|
||||||
(error 'fxmodulo "zero dividend ~s" y))
|
(error 'fxmodulo "zero dividend ~s" y))
|
||||||
($fxmodulo x y)))
|
($fxmodulo x y)))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'fxlogor
|
(primitive-set! 'fxlogor
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
(unless (fixnum? x)
|
(unless (fixnum? x)
|
||||||
|
@ -450,6 +447,7 @@ reference-implementation:
|
||||||
(error 'fxlogand "~s is not a fixnum" y))
|
(error 'fxlogand "~s is not a fixnum" y))
|
||||||
($fxlogand x y)))
|
($fxlogand x y)))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'fxsra
|
(primitive-set! 'fxsra
|
||||||
(lambda (x y)
|
(lambda (x y)
|
||||||
(unless (fixnum? x)
|
(unless (fixnum? x)
|
||||||
|
@ -697,6 +695,14 @@ reference-implementation:
|
||||||
(err c2)))))
|
(err c2)))))
|
||||||
(err c1))])))
|
(err c1))])))
|
||||||
|
|
||||||
|
(primitive-set! '$memq
|
||||||
|
(lambda (x ls)
|
||||||
|
(let f ([x x] [ls ls])
|
||||||
|
(and (pair? ls)
|
||||||
|
(if (eq? x (car ls))
|
||||||
|
ls
|
||||||
|
(f x (cdr ls)))))))
|
||||||
|
|
||||||
(primitive-set! 'char-whitespace?
|
(primitive-set! 'char-whitespace?
|
||||||
(lambda (c)
|
(lambda (c)
|
||||||
(cond
|
(cond
|
||||||
|
@ -765,16 +771,6 @@ reference-implementation:
|
||||||
(error 'vector-ref "index ~s is out of range for ~s" i v))
|
(error 'vector-ref "index ~s is out of range for ~s" i v))
|
||||||
($vector-ref v i)))
|
($vector-ref v i)))
|
||||||
|
|
||||||
(primitive-set! 'string-ref
|
|
||||||
(lambda (s i)
|
|
||||||
(unless (string? s)
|
|
||||||
(error 'string-ref "~s is not a string" s))
|
|
||||||
(unless (fixnum? i)
|
|
||||||
(error 'string-ref "~s is not a valid index" i))
|
|
||||||
(unless (and ($fx< i ($string-length s))
|
|
||||||
($fx<= 0 i))
|
|
||||||
(error 'string-ref "index ~s is out of range for ~s" i s))
|
|
||||||
($string-ref s i)))
|
|
||||||
|
|
||||||
(primitive-set! 'vector-set!
|
(primitive-set! 'vector-set!
|
||||||
(lambda (v i c)
|
(lambda (v i c)
|
||||||
|
@ -788,18 +784,6 @@ reference-implementation:
|
||||||
($vector-set! v i c)))
|
($vector-set! v i c)))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'string-set!
|
|
||||||
(lambda (s i c)
|
|
||||||
(unless (string? s)
|
|
||||||
(error 'string-set! "~s is not a string" s))
|
|
||||||
(unless (fixnum? i)
|
|
||||||
(error 'string-set! "~s is not a valid index" i))
|
|
||||||
(unless (and ($fx< i ($string-length s))
|
|
||||||
($fx>= i 0))
|
|
||||||
(error 'string-set! "index ~s is out of range for ~s" i s))
|
|
||||||
(unless (char? c)
|
|
||||||
(error 'string-set! "~s is not a character" c))
|
|
||||||
($string-set! s i c)))
|
|
||||||
|
|
||||||
(primitive-set! 'vector
|
(primitive-set! 'vector
|
||||||
;;; FIXME: add case-lambda
|
;;; FIXME: add case-lambda
|
||||||
|
@ -889,15 +873,6 @@ reference-implementation:
|
||||||
(race d d x x))
|
(race d d x x))
|
||||||
(error 'last-pair "~s is not a pair" x)))))
|
(error 'last-pair "~s is not a pair" x)))))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! '$memq
|
|
||||||
(lambda (x ls)
|
|
||||||
(let f ([x x] [ls ls])
|
|
||||||
(and (pair? ls)
|
|
||||||
(if (eq? x (car ls))
|
|
||||||
ls
|
|
||||||
(f x (cdr ls)))))))
|
|
||||||
|
|
||||||
(primitive-set! 'memq
|
(primitive-set! 'memq
|
||||||
(letrec ([race
|
(letrec ([race
|
||||||
(lambda (h t ls x)
|
(lambda (h t ls x)
|
||||||
|
@ -1033,40 +1008,6 @@ reference-implementation:
|
||||||
(f list index)))
|
(f list index)))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'apply
|
|
||||||
(let ()
|
|
||||||
(define (err f ls)
|
|
||||||
(if (procedure? f)
|
|
||||||
(error 'apply "not a list")
|
|
||||||
(error 'apply "~s is not a procedure" f)))
|
|
||||||
(define (fixandgo f a0 a1 ls p d)
|
|
||||||
(cond
|
|
||||||
[(null? ($cdr d))
|
|
||||||
(let ([last ($car d)])
|
|
||||||
($set-cdr! p last)
|
|
||||||
(if (and (procedure? f) (list? last))
|
|
||||||
($$apply f a0 a1 ls)
|
|
||||||
(err f last)))]
|
|
||||||
[else (fixandgo f a0 a1 ls d ($cdr d))]))
|
|
||||||
(define apply
|
|
||||||
(case-lambda
|
|
||||||
[(f ls)
|
|
||||||
(if (and (procedure? f) (list? ls))
|
|
||||||
($$apply f ls)
|
|
||||||
(err f ls))]
|
|
||||||
[(f a0 ls)
|
|
||||||
(if (and (procedure? f) (list? ls))
|
|
||||||
($$apply f a0 ls)
|
|
||||||
(err f ls))]
|
|
||||||
[(f a0 a1 ls)
|
|
||||||
(if (and (procedure? f) (list? ls))
|
|
||||||
($$apply f a0 a1 ls)
|
|
||||||
(err f ls))]
|
|
||||||
[(f a0 a1 . ls)
|
|
||||||
(fixandgo f a0 a1 ls ls ($cdr ls))]))
|
|
||||||
apply))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
@ -1224,7 +1165,6 @@ reference-implementation:
|
||||||
(f ($symbol-plist x) '()))))
|
(f ($symbol-plist x) '()))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(let ()
|
(let ()
|
||||||
(define vector-loop
|
(define vector-loop
|
||||||
(lambda (x y i n)
|
(lambda (x y i n)
|
||||||
|
@ -1259,6 +1199,41 @@ reference-implementation:
|
||||||
(primitive-set! 'equal? equal?))
|
(primitive-set! 'equal? equal?))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(primitive-set! 'apply
|
||||||
|
(let ()
|
||||||
|
(define (err f ls)
|
||||||
|
(if (procedure? f)
|
||||||
|
(error 'apply "not a list")
|
||||||
|
(error 'apply "~s is not a procedure" f)))
|
||||||
|
(define (fixandgo f a0 a1 ls p d)
|
||||||
|
(cond
|
||||||
|
[(null? ($cdr d))
|
||||||
|
(let ([last ($car d)])
|
||||||
|
($set-cdr! p last)
|
||||||
|
(if (and (procedure? f) (list? last))
|
||||||
|
($$apply f a0 a1 ls)
|
||||||
|
(err f last)))]
|
||||||
|
[else (fixandgo f a0 a1 ls d ($cdr d))]))
|
||||||
|
(define apply
|
||||||
|
(case-lambda
|
||||||
|
[(f ls)
|
||||||
|
(if (and (procedure? f) (list? ls))
|
||||||
|
($$apply f ls)
|
||||||
|
(err f ls))]
|
||||||
|
[(f a0 ls)
|
||||||
|
(if (and (procedure? f) (list? ls))
|
||||||
|
($$apply f a0 ls)
|
||||||
|
(err f ls))]
|
||||||
|
[(f a0 a1 ls)
|
||||||
|
(if (and (procedure? f) (list? ls))
|
||||||
|
($$apply f a0 a1 ls)
|
||||||
|
(err f ls))]
|
||||||
|
[(f a0 a1 . ls)
|
||||||
|
(fixandgo f a0 a1 ls ls ($cdr ls))]))
|
||||||
|
apply))
|
||||||
|
|
||||||
(let ()
|
(let ()
|
||||||
(define who 'map)
|
(define who 'map)
|
||||||
(define len
|
(define len
|
||||||
|
@ -1712,7 +1687,7 @@ reference-implementation:
|
||||||
(let ([us ($symbol-unique-string x)])
|
(let ([us ($symbol-unique-string x)])
|
||||||
(cond
|
(cond
|
||||||
[(string? us) us]
|
[(string? us) us]
|
||||||
[(eq? us #t)
|
[(not us)
|
||||||
(error 'gensym->unique-string "~s is not a gensym" x)]
|
(error 'gensym->unique-string "~s is not a gensym" x)]
|
||||||
[else
|
[else
|
||||||
(let f ([x x])
|
(let f ([x x])
|
||||||
|
@ -1722,6 +1697,9 @@ reference-implementation:
|
||||||
[(foreign-call "ikrt_intern_gensym" x) id]
|
[(foreign-call "ikrt_intern_gensym" x) id]
|
||||||
[else (f x)])))]))))
|
[else (f x)])))]))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'gensym-prefix
|
(primitive-set! 'gensym-prefix
|
||||||
(make-parameter
|
(make-parameter
|
||||||
"g"
|
"g"
|
||||||
|
@ -1746,21 +1724,6 @@ reference-implementation:
|
||||||
(error 'print-gensym "~s is not in #t|#f|pretty" x))
|
(error 'print-gensym "~s is not in #t|#f|pretty" x))
|
||||||
x)))
|
x)))
|
||||||
|
|
||||||
;; X (primitive-set! 'make-hash-table
|
|
||||||
;; X (lambda ()
|
|
||||||
;; X (make-hash-table)))
|
|
||||||
;; X
|
|
||||||
;; X (primitive-set! 'hash-table?
|
|
||||||
;; X (lambda (x)
|
|
||||||
;; X (hash-table? x)))
|
|
||||||
;; X
|
|
||||||
;; X (primitive-set! 'get-hash-table
|
|
||||||
;; X (lambda (h k v)
|
|
||||||
;; X (foreign-call "ik_get_hash_table" h k v)))
|
|
||||||
;; X
|
|
||||||
;; X (primitive-set! 'put-hash-table!
|
|
||||||
;; X (lambda (h k v)
|
|
||||||
;; X (foreign-call "ik_put_hash_table" h k v)))
|
|
||||||
|
|
||||||
(primitive-set! 'bwp-object?
|
(primitive-set! 'bwp-object?
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
|
@ -1804,6 +1767,55 @@ reference-implementation:
|
||||||
x
|
x
|
||||||
(error 'command-list "invalid command-line-arguments ~s\n" x)))))
|
(error 'command-list "invalid command-line-arguments ~s\n" x)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(let ()
|
||||||
|
(define f
|
||||||
|
(lambda (n i j)
|
||||||
|
(cond
|
||||||
|
[($fxzero? n)
|
||||||
|
(values (make-string i) j)]
|
||||||
|
[else
|
||||||
|
(let ([q ($fxquotient n 10)])
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (f q ($fxadd1 i) j))
|
||||||
|
(lambda (str j)
|
||||||
|
(let ([r ($fx- n ($fx* q 10))])
|
||||||
|
(string-set! str j
|
||||||
|
($fixnum->char ($fx+ r ($char->fixnum #\0))))
|
||||||
|
(values str ($fxadd1 j))))))])))
|
||||||
|
(primitive-set! 'fixnum->string
|
||||||
|
(lambda (x)
|
||||||
|
(unless (fixnum? x) (error 'fixnum->string "~s is not a fixnum" x))
|
||||||
|
(cond
|
||||||
|
[($fxzero? x) "0"]
|
||||||
|
[($fx> x 0)
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (f x 0 0))
|
||||||
|
(lambda (str j) str))]
|
||||||
|
[($fx= x -536870912) "-536870912"]
|
||||||
|
[else
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (f ($fx- 0 x) 1 1))
|
||||||
|
(lambda (str j)
|
||||||
|
($string-set! str 0 #\-)
|
||||||
|
str))]))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(primitive-set! 'symbol->string
|
||||||
|
(lambda (x)
|
||||||
|
(unless (symbol? x)
|
||||||
|
(error 'symbol->string "~s is not a symbol" x))
|
||||||
|
(let ([str ($symbol-string x)])
|
||||||
|
(or str
|
||||||
|
(let ([ct (gensym-count)])
|
||||||
|
(let ([str (string-append (gensym-prefix) (fixnum->string ct))])
|
||||||
|
($set-symbol-string! x str)
|
||||||
|
(gensym-count ($fxadd1 ct))
|
||||||
|
str))))))
|
||||||
|
|
||||||
|
|
||||||
(primitive-set! 'string->number
|
(primitive-set! 'string->number
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(define (convert-data str len pos? idx ac)
|
(define (convert-data str len pos? idx ac)
|
||||||
|
@ -1849,3 +1861,4 @@ reference-implementation:
|
||||||
(convert-sign x ($string-length x))]
|
(convert-sign x ($string-length x))]
|
||||||
[else (error 'string->number "~s is not a string" x)])))
|
[else (error 'string->number "~s is not a string" x)])))
|
||||||
|
|
||||||
|
#!eof
|
||||||
|
|
|
@ -374,6 +374,8 @@
|
||||||
(cond
|
(cond
|
||||||
[(and (imm8? a0) (reg? a1))
|
[(and (imm8? a0) (reg? a1))
|
||||||
(CODE c (ModRM 1 /d a1 (IMM8 a0 ac)))]
|
(CODE c (ModRM 1 /d a1 (IMM8 a0 ac)))]
|
||||||
|
[(and (imm8? a1) (reg? a0))
|
||||||
|
(CODE c (ModRM 1 /d a0 (IMM8 a1 ac)))]
|
||||||
[(and (reg? a0) (reg? a1))
|
[(and (reg? a0) (reg? a1))
|
||||||
(CODE c (ModRM 1 /d '/4 (SIB 0 a0 a1 (IMM8 0 ac))))]
|
(CODE c (ModRM 1 /d '/4 (SIB 0 a0 a1 (IMM8 0 ac))))]
|
||||||
[else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))]
|
[else (error 'CODE/digit "unhandled ~s ~s" a0 a1)])))]
|
||||||
|
@ -536,6 +538,8 @@
|
||||||
(CODE #x29 (ModRM 3 src dst ac))]
|
(CODE #x29 (ModRM 3 src dst ac))]
|
||||||
[(and (mem? src) (reg? dst))
|
[(and (mem? src) (reg? dst))
|
||||||
(CODErd #x2B dst src ac)]
|
(CODErd #x2B dst src ac)]
|
||||||
|
[(and (reg? src) (mem? dst))
|
||||||
|
((CODE/digit #x29 src) dst ac)]
|
||||||
[else (error who "invalid ~s" instr)])]
|
[else (error who "invalid ~s" instr)])]
|
||||||
[(sall src dst)
|
[(sall src dst)
|
||||||
(cond
|
(cond
|
||||||
|
@ -872,6 +876,7 @@
|
||||||
(lambda (thunk?-label code vec)
|
(lambda (thunk?-label code vec)
|
||||||
(define reloc-idx 0)
|
(define reloc-idx 0)
|
||||||
(lambda (r)
|
(lambda (r)
|
||||||
|
;(printf "r=~s\n" r)
|
||||||
(let ([idx (car r)] [type (cadr r)]
|
(let ([idx (car r)] [type (cadr r)]
|
||||||
[v
|
[v
|
||||||
(let ([v (cddr r)])
|
(let ([v (cddr r)])
|
||||||
|
|
Loading…
Reference in New Issue