* altcompile now passes tests 1.3

This commit is contained in:
Abdulaziz Ghuloum 2007-02-11 04:12:09 -05:00
parent 27d8fd4558
commit f5411877ba
6 changed files with 345 additions and 101 deletions

Binary file not shown.

View File

@ -406,7 +406,12 @@
(record-case x (record-case x
[(constant) (constant-rep x)] [(constant) (constant-rep x)]
[(var) x] [(var) x]
[(primref) (make-constant x)] [(primref name)
(make-primcall 'mref
(list
(make-constant (make-object name))
(make-constant
(- disp-symbol-system-value symbol-tag))))]
[(code-loc) (make-constant x)] [(code-loc) (make-constant x)]
[(closure) (make-constant x)] [(closure) (make-constant x)]
[(bind lhs* rhs* body) [(bind lhs* rhs* body)
@ -490,6 +495,7 @@
(define return-value-register '%eax) (define return-value-register '%eax)
(define cp-register '%edi) (define cp-register '%edi)
(define all-registers '(%eax %edi %ebx %edx)) (define all-registers '(%eax %edi %ebx %edx))
(define argc-register '%eax)
(define (impose-calling-convention/evaluation-order x) (define (impose-calling-convention/evaluation-order x)
(define who 'impose-calling-convention/evaluation-order) (define who 'impose-calling-convention/evaluation-order)
@ -527,6 +533,16 @@
(V (car lhs*) (car rhs*)) (V (car lhs*) (car rhs*))
(do-bind (cdr lhs*) (cdr rhs*) body))])) (do-bind (cdr lhs*) (cdr rhs*) body))]))
;;; ;;;
(define (nontail-locations args)
(let f ([regs parameter-registers] [args args])
(cond
[(null? args) (values '() '() '())]
[(null? regs) (values '() '() args)]
[else
(let-values ([(r* rl* f*) (f (cdr regs) (cdr args))])
(values (cons (car regs) r*)
(cons (car args) rl*)
f*))])))
(define (V d x) (define (V d x)
(record-case x (record-case x
[(constant) (make-set d x)] [(constant) (make-set d x)]
@ -539,12 +555,38 @@
(S* rands (S* rands
(lambda (rands) (lambda (rands)
(make-set d (make-primcall op rands))))] (make-set d (make-primcall op rands))))]
[(funcall rator rands)
(let-values ([(reg-locs reg-args frm-args)
(nontail-locations (cons rator rands))])
(let ([regt* (map (lambda (x) (unique-var 'rt)) reg-args)]
[frmt* (map (lambda (x) (make-nfvar #f #f)) frm-args)])
(make-seq
(make-nframe frmt* #f
(do-bind frmt* frm-args
(do-bind regt* reg-args
(assign* reg-locs regt*
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
(make-primcall
'indirect-call
(cons argc-register (append reg-locs frmt*))))))))
(make-set d return-value-register))))]
[else (error who "invalid value ~s" x)])) [else (error who "invalid value ~s" x)]))
;;; ;;;
(define (assign* lhs* rhs* ac)
(cond
[(null? lhs*) ac]
[else
(make-seq
(make-set (car lhs*) (car rhs*))
(assign* (cdr lhs*) (cdr rhs*) ac))]))
;;;
(define (VT x) (define (VT x)
(make-seq (make-seq
(V return-value-register x) (V return-value-register x)
(make-primcall 'return '()))) (make-primcall 'return (list return-value-register))))
;;; ;;;
(define (Tail x) (define (Tail x)
(record-case x (record-case x
@ -555,6 +597,20 @@
(do-bind lhs* rhs* (Tail e))] (do-bind lhs* rhs* (Tail e))]
[(seq e0 e1) [(seq e0 e1)
(make-seq (E e0) (Tail e1))] (make-seq (E e0) (Tail e1))]
[(funcall rator rands)
(let ([cpt (unique-var 'rator)]
[rt* (map (lambda (x) (unique-var 't)) rands)])
(do-bind rt* rands
(do-bind (list cpt) (list rator)
(let ([args (cons cpt rt*)]
[locs (formals-locations (cons cpt rt*))])
(assign* (reverse locs)
(reverse args)
(make-seq
(make-set argc-register
(make-constant
(argc-convention (length rands))))
(make-primcall 'indirect-jump locs)))))))]
[else (error who "invalid tail ~s" x)])) [else (error who "invalid tail ~s" x)]))
;;; ;;;
(define (formals-locations args) (define (formals-locations args)
@ -562,11 +618,11 @@
(cond (cond
[(null? args) '()] [(null? args) '()]
[(null? regs) [(null? regs)
(let f ([i 0] [args args]) (let f ([i 1] [args args])
(cond (cond
[(null? args) '()] [(null? args) '()]
[else [else
(cons (make-fvar i) (cons (mkfvar i)
(f (fxadd1 i) (cdr args)))]))] (f (fxadd1 i) (cdr args)))]))]
[else [else
(cons (car regs) (f (cdr regs) (cdr args)))]))) (cons (car regs) (f (cdr regs) (cdr args)))])))
@ -626,9 +682,18 @@
[(assq x ls) => [(assq x ls) =>
(lambda (p0) (lambda (p0)
(unless (memq y (cdr p0)) (unless (memq y (cdr p0))
(let ([p1 (assq y ls)]) (set-cdr! p0 (cons y (cdr p0)))
(set-cdr! p1 (cons x (cdr p1))) (cond
(set-cdr! p0 (cons y (cdr p0))))))] [(assq y ls) =>
(lambda (p1)
(set-cdr! p1 (cons x (cdr p1))))]
[else
(set-graph-ls! g
(cons (list y x) ls))])))]
[(assq y ls) =>
(lambda (p1)
(set-cdr! p1 (cons x (cdr p1)))
(set-graph-ls! g (cons (list x y) ls)))]
[else [else
(set-graph-ls! g (set-graph-ls! g
(list* (list x y) (list* (list x y)
@ -678,48 +743,62 @@
[(null? s2) s1] [(null? s2) s1]
[else (set-difference (set-rem (car s2) s1) (cdr s2))])) [else (set-difference (set-rem (car s2) s1) (cdr s2))]))
(module (color-by-chaitin) (module (color-by-chaitin)
(import ListyGraphs) (import ListyGraphs)
;;; ;;;
(define (build-graph x) (define (build-graph x reg?)
(define who 'build-graph) (define who 'build-graph)
(define g (empty-graph)) (define g (empty-graph))
(define (reg? x)
(or (symbol? x)
(var? x)))
(define (add-rands ls s) (define (add-rands ls s)
(cond (cond
[(null? ls) s] [(null? ls) s]
[(reg? (car ls)) [(or (reg? (car ls)) (var? (car ls)) (nfvar? (car ls)))
(add-rands (cdr ls) (set-add (car ls) s))] (add-rands (cdr ls) (set-add (car ls) s))]
[else (add-rands (cdr ls) s)])) [else (add-rands (cdr ls) s)]))
(define (Rhs x s) (define (Rhs x s)
(record-case x (record-case x
[(fvar) s]
[(primcall op rand*) (add-rands rand* s)] [(primcall op rand*) (add-rands rand* s)]
[(constant) s] [else
[else (error who "invalid rhs ~s" x)])) (if (or (var? x) (reg? x) (nfvar? x))
(set-add x s)
s)]))
(define (E x s) (define (E x s)
(record-case x (record-case x
[(set lhs rhs) [(set lhs rhs)
(if (reg? lhs) (cond
(if (reg? rhs) [(or (var? lhs) (reg? lhs))
(let ([s (set-rem rhs (set-rem lhs s))]) (cond
(for-each (lambda (x) (add-edge! g lhs x)) s) [(or (var? rhs) (reg? rhs))
(cons rhs s)) (let ([s (set-rem rhs (set-rem lhs s))])
(let ([s (set-rem lhs s)]) (for-each (lambda (x) (add-edge! g lhs x)) s)
(for-each (lambda (x) (add-edge! g lhs x)) s) (cons rhs s))]
(Rhs rhs s))) [else
(Rhs rhs s))] (let ([s (set-rem lhs s)])
(for-each (lambda (x) (add-edge! g lhs x)) s)
(Rhs rhs s))])]
[(nfvar? lhs)
(let ([s (set-rem lhs s)])
(set-nfvar-conf! lhs s)
(Rhs rhs s))]
[else (Rhs rhs s)])]
[(seq e0 e1) (E e0 (E e1 s))] [(seq e0 e1) (E e0 (E e1 s))]
[(primcall op rands) (add-rands rands s)] [(primcall op rands) (add-rands rands s)]
[(nframe vars live body)
(when (reg? return-value-register)
(for-each
(lambda (x)
(for-each (lambda (r)
(add-edge! g x r))
all-registers))
s))
(set-nframe-live! x s)
(E body s)]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
(define (T x) (define (T x)
(record-case x (record-case x
[(primcall op rands) [(primcall op rands)
(case op (add-rands rands '())]
[(return) (list return-value-register)]
[else (error who "invalid tail op ~s" x)])]
[(seq e0 e1) (E e0 (T e1))] [(seq e0 e1) (E e0 (T e1))]
[else (error who "invalid tail ~s" x)])) [else (error who "invalid tail ~s" x)]))
(let ([s (T x)]) (let ([s (T x)])
@ -737,6 +816,7 @@
(define (find-color/maybe x confs env) (define (find-color/maybe x confs env)
(let ([cr (map (lambda (x) (let ([cr (map (lambda (x)
(cond (cond
[(symbol? x) x]
[(assq x env) => cdr] [(assq x env) => cdr]
[else #f])) [else #f]))
confs)]) confs)])
@ -767,78 +847,199 @@
(let ([r (find-color sp n* env)]) (let ([r (find-color sp n* env)])
(values spills (cons sp sp*) (values spills (cons sp sp*)
(cons (cons sp r) env))))))] (cons (cons sp r) env))))))]
[(pair? sp*)
(let ([sp (car sp*)])
(let ([n* (node-neighbors sp g)])
(delete-node! sp g)
(let-values ([(spills sp* env)
(color-graph (set-rem sp sp*) un* g)])
(let ([r (find-color/maybe sp n* env)])
(if r
(values spills (cons sp sp*)
(cons (cons sp r) env))
(values (cons sp spills) sp* env))))))]
[else (error color-graph "whoaaa")])) [else (error color-graph "whoaaa")]))
;;; ;;;
(define (substitute env x) (define (substitute env x frame-g)
(define who 'substitute) (define who 'substitute)
(define (max-live vars i)
(cond
[(null? vars) i]
[else (max-live (cdr vars)
(record-case (car vars)
[(fvar j) (max i j)]
[else i]))]))
(define (actual-frame-size vars i)
(define (conflicts? i ls)
(and (not (null? ls))
(or (record-case (car ls)
[(fvar j) (eq? i j)]
[else #f])
(conflicts? i (cdr ls)))))
(define (frame-size-ok? i vars)
(or (null? vars)
(and (not (conflicts? i (map Lhs (nfvar-conf (car vars)))))
(frame-size-ok? (fxadd1 i) (cdr vars)))))
(cond
[(frame-size-ok? i vars) i]
[else (actual-frame-size vars (fxadd1 i))]))
(define (assign-frame-vars! vars i)
(unless (null? vars)
(set-nfvar-loc! (car vars) (mkfvar i))
(assign-frame-vars! (cdr vars) (fxadd1 i))))
(define (Var x) (define (Var x)
(cond (cond
[(assq x env) => cdr] [(assq x env) => cdr]
[else (error who "~s is unassigned" x)])) [else x]))
(define (Rhs x) (define (Rhs x)
(record-case x (record-case x
[(var) (Var x)] [(var) (Var x)]
[(fvar i) (Fvar i)]
[(primcall op rand*) [(primcall op rand*)
(make-primcall op (map Rand rand*))] (make-primcall op (map Rand rand*))]
[else x])) [else x]))
(define (Fvar i)
(define (idx->stack-loc i)
(fx* (fx- 0 wordsize) (fxadd1 i)))
(make-primcall 'mem
(list fpr (make-constant (idx->stack-loc i)))))
(define (Rand x) (define (Rand x)
(record-case x (record-case x
[(var) (Var x)] [(var) (Var x)]
[(fvar i) (Fvar i)]
[else x])) [else x]))
(define (Lhs x) (define (Lhs x)
(record-case x (record-case x
[(var) (Var x)] [(var) (Var x)]
[(nfvar confs loc)
(or loc (error who "LHS not set ~s" x))]
[else x])) [else x]))
(define (NFE idx x)
(record-case x
[(seq e0 e1) (make-seq (E e0) (NFE idx e1))]
[(primcall op rands)
(case op
[(indirect-call)
(make-primcall op
(cons (make-constant idx) (map Rand rands)))]
[else (error who "invalid NFE ~s" x)])]
[else (error who "invalid NF effect ~s" x)]))
(define (E x) (define (E x)
(record-case x (record-case x
[(set lhs rhs) [(set lhs rhs)
(let ([lhs (Lhs lhs)] [rhs (Rhs rhs)]) (let ([lhs (Lhs lhs)] [rhs (Rhs rhs)])
(cond (cond
[(eq? lhs rhs) (make-primcall 'nop '())] [(or (eq? lhs rhs)
(and (fvar? lhs) (fvar? rhs)
(fixnum? (fvar-idx lhs))
(fixnum? (fvar-idx rhs))
(fx= (fvar-idx lhs) (fvar-idx rhs))))
(make-primcall 'nop '())]
[else (make-set lhs rhs)]))] [else (make-set lhs rhs)]))]
[(seq e0 e1) (make-seq (E e0) (E e1))] [(seq e0 e1) (make-seq (E e0) (E e1))]
[(primcall op rands) [(primcall op rands)
(case op (make-primcall op (map Rand rands))]
[(mset!) [(nframe vars live body)
(make-set ;;; 1 is for the rp address
(make-primcall 'mem ;(printf "live=~s\n" live)
(list (Rand (car rands)) (let ([i (actual-frame-size vars
(Rand (cadr rands)))) (fx+ 2 (max-live (map Lhs live) 0)))])
(Rand (caddr rands)))] (assign-frame-vars! vars i)
[else (error who "invalid effect prim ~s" op)])] (NFE (fxsub1 i) body))]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
(define (T x) (define (T x)
(record-case x (record-case x
[(primcall op rands) [(primcall op rands) x]
(case op
[(return) x]
[else (error who "invalid tail op ~s" x)])]
[(seq e0 e1) (make-seq (E e0) (T e1))] [(seq e0 e1) (make-seq (E e0) (T e1))]
[else (error who "invalid tail ~s" x)])) [else (error who "invalid tail ~s" x)]))
;(print-graph frame-g)
(T x)) (T x))
;;; ;;;
(define (do-spill sp* x un*) (define (do-spill sp* g)
(error 'do-spill "not yet")) (define (find/set-loc x)
(let ([ls (node-neighbors x g)])
(define (conflicts? i ls)
(and (pair? ls)
(or (record-case (car ls)
[(fvar j)
(and (fixnum? j) (fx= i j))]
[else #f])
(conflicts? i (cdr ls)))))
(let f ([i 1])
(cond
[(conflicts? i ls) (f (fxadd1 i))]
[else
(let ([fv (mkfvar i)])
(for-each (lambda (y) (add-edge! g y fv)) ls)
(delete-node! x g)
(cons x fv))]))))
(map find/set-loc sp*))
;;;
(define (add-unspillables un* x)
(define who 'add-unspillables)
(define (mku)
(let ([u (unique-var 'u)])
(set! un* (cons u un*))
u))
(define (S* ls k)
(cond
[(null? ls) (k '())]
[else
(let ([a (car ls)])
(S* (cdr ls)
(lambda (d)
(cond
[(fvar? a)
(let ([u (mku)])
(make-seq
(make-set u a)
(k (cons u d))))]
[else (k (cons a d))]))))]))
(define (E x)
(record-case x
[(set lhs rhs)
(cond
[(or (constant? rhs) (var? rhs) (symbol? rhs)) x]
[(fvar? lhs)
(cond
[else
(let ([u (mku)])
(make-seq
(E (make-set u rhs))
(make-set lhs u)))])]
[(fvar? rhs) x]
[(primcall? rhs)
(S* (primcall-arg* rhs)
(lambda (s*)
(make-set lhs
(make-primcall (primcall-op rhs) s*))))]
[else (error who "invalid set in ~s" x)])]
[(seq e0 e1) (make-seq (E e0) (E e1))]
[(primcall op rands)
(case op
[(nop) x]
[(indirect-call) x]
[else (error who "invalid op in ~s" x)])]
[else (error who "invalid effect ~s" x)]))
(define (T x)
(record-case x
[(primcall op rands) x]
[(seq e0 e1) (make-seq (E e0) (T e1))]
[else (error who "invalid tail ~s" x)]))
(let ([x (T x)])
(values un* x)))
;;; ;;;
(define (color-program x) (define (color-program x)
(define who 'color-program) (define who 'color-program)
(record-case x (record-case x
[(locals sp* body) [(locals sp* body)
(let loop ([sp* sp*] [un* '()] [body body]) (let ([frame-g (build-graph body fvar?)])
(let ([g (build-graph body)]) (let loop ([sp* sp*] [un* '()] [body body])
(let-values ([(spills sp* env) (color-graph sp* un* g)]) (let ([g (build-graph body symbol?)])
(cond ; (printf "loop:\n")
[(null? spills) (substitute env body)] ; (print-code body)
[else (let-values ([(spills sp* env) (color-graph sp* un* g)])
(let-values ([(un* body) (do-spill spills body un*)]) (cond
(loop sp* un* body))]))))])) [(null? spills) (substitute env body frame-g)]
[else
(let* ([env (do-spill spills frame-g)]
[body (substitute env body frame-g)])
(let-values ([(un* body)
(add-unspillables un* body)])
(loop sp* un* body)))])))))]))
;;; ;;;
(define (color-by-chaitin x) (define (color-by-chaitin x)
;;; ;;;
@ -865,6 +1066,8 @@
(define (flatten-codes x) (define (flatten-codes x)
(define who 'flatten-codes) (define who 'flatten-codes)
;;; ;;;
(define (FVar i)
`(disp ,(* i (- wordsize)) ,fpr))
(define (Rand x) (define (Rand x)
(record-case x (record-case x
[(constant c) [(constant c)
@ -874,10 +1077,13 @@
(unless (null? free*) (unless (null? free*)
(error who "nonempty closure")) (error who "nonempty closure"))
`(obj ,c)] `(obj ,c)]
[(object o)
`(obj ,o)]
[else [else
(if (integer? c) (if (integer? c)
c c
(error who "invalid constant rand ~s" c))])] (error who "invalid constant rand ~s" c))])]
[(fvar i) (FVar i)]
[(primcall op rands) [(primcall op rands)
(case op (case op
[(mem) `(disp . ,(map Rand rands))] [(mem) `(disp . ,(map Rand rands))]
@ -893,7 +1099,7 @@
(cons `(movl ,(Rand x) ,d) ac)] (cons `(movl ,(Rand x) ,d) ac)]
[(primcall op rands) [(primcall op rands)
(case op (case op
[(mem) [(mref)
(cons `(movl (disp ,(Rand (car rands)) (cons `(movl (disp ,(Rand (car rands))
,(Rand (cadr rands))) ,(Rand (cadr rands)))
,d) ,d)
@ -919,6 +1125,14 @@
[(primcall op rands) [(primcall op rands)
(case op (case op
[(nop) ac] [(nop) ac]
[(indirect-call)
(record-case (car rands)
[(constant i)
(list* `(subl ,(* (fxsub1 i) wordsize) ,fpr)
`(call (disp ,(fx- disp-closure-code closure-tag) ,cp-register))
`(addl ,(* (fxsub1 i) wordsize) ,fpr)
ac)]
[else (error who "invalid ~s" x)])]
[else (error who "invalid effect ~s" x)])] [else (error who "invalid effect ~s" x)])]
[else (error who "invalid effect ~s" x)])) [else (error who "invalid effect ~s" x)]))
;;; ;;;
@ -928,6 +1142,9 @@
[(primcall op rands) [(primcall op rands)
(case op (case op
[(return) (cons '(ret) ac)] [(return) (cons '(ret) ac)]
[(indirect-jump)
(cons `(jmp (disp ,(fx- disp-closure-code closure-tag) ,cp-register))
ac)]
[else (error who "invalid tail ~s" x)])] [else (error who "invalid tail ~s" x)])]
[else (error who "invalid tail ~s" x)])) [else (error who "invalid tail ~s" x)]))
;;; ;;;
@ -969,10 +1186,17 @@
[x (eliminate-fix x)] [x (eliminate-fix x)]
[x (specify-representation x)] [x (specify-representation x)]
[x (impose-calling-convention/evaluation-order x)] [x (impose-calling-convention/evaluation-order x)]
;[foo (print-code x)] ; [foo (print-code x)]
[x (color-by-chaitin x)] [x (color-by-chaitin x)]
[foo (print-code x)] ;[foo (print-code x)]
[ls (flatten-codes x)]) [ls (flatten-codes x)])
(parameterize ([gensym-prefix "L"]
[print-gensym #f])
(for-each
(lambda (ls)
(newline)
(for-each (lambda (x) (printf " ~s\n" x)) ls))
ls))
ls)) ls))
#|module alt-cogen|#) #|module alt-cogen|#)

View File

@ -258,6 +258,21 @@
(define-record set (lhs rhs)) (define-record set (lhs rhs))
(define-record object (val)) (define-record object (val))
(define-record locals (vars body)) (define-record locals (vars body))
(define-record nframe (vars live body))
(define-record nfvar (conf loc))
(define mkfvar
(let ([cache '()])
(lambda (i)
(cond
[(fixnum? i)
(cond
[(assv i cache) => cdr]
[else
(let ([fv (make-fvar i)])
(set! cache (cons (cons i fv) cache))
fv)])]
[else (error 'mkfvar "~s is not a fixnum" i)]))))
(define (unique-var x) (define (unique-var x)
(make-var (gensym x) #f #f)) (make-var (gensym x) #f #f))
@ -460,6 +475,7 @@
[(set lhs rhs) `(set ,(E lhs) ,(E rhs))] [(set lhs rhs) `(set ,(E lhs) ,(E rhs))]
[(fvar idx) (string->symbol (format "fv.~a" idx))] [(fvar idx) (string->symbol (format "fv.~a" idx))]
[(locals vars body) `(locals ,(map E vars) ,(E body))] [(locals vars body) `(locals ,(map E vars) ,(E body))]
[(nframe vars live body) `(nframe ,(map E vars) ,(E body))]
[else x])) [else x]))
(E x)) (E x))
@ -5225,6 +5241,7 @@
(parameterize ([expand-mode 'eval]) (parameterize ([expand-mode 'eval])
(alt-compile-expr x)))]) (alt-compile-expr x)))])
(let ([proc ($code->closure code)]) (let ([proc ($code->closure code)])
(printf "running ...\n")
(proc))))) (proc)))))

View File

@ -329,6 +329,7 @@
[(and (int? i1) (obj? i2)) [(and (int? i1) (obj? i2))
(let ([d i1] [v (cadr i2)]) (let ([d i1] [v (cadr i2)])
(cons (reloc-word+ v d) ac))] (cons (reloc-word+ v d) ac))]
[(and (int? i2) (obj? i1)) (IMM32*2 i2 i1 ac)]
[else (error 'assemble "IMM32*2 ~s ~s" i1 i2)]))) [else (error 'assemble "IMM32*2 ~s ~s" i1 i2)])))

View File

@ -240,11 +240,11 @@
["libassembler.ss" "libassembler.fasl" p0] ["libassembler.ss" "libassembler.fasl" p0]
["libintelasm.ss" "libintelasm.fasl" p0] ["libintelasm.ss" "libintelasm.fasl" p0]
["libfasl.ss" "libfasl.fasl" p0] ["libfasl.ss" "libfasl.fasl" p0]
["libtrace.ss" "libtrace.fasl" p0]
["libcompile.ss" "libcompile.fasl" p1] ["libcompile.ss" "libcompile.fasl" p1]
["psyntax-7.1.ss" "psyntax.fasl" p0] ["psyntax-7.1.ss" "psyntax.fasl" p0]
["libpp.ss" "libpp.fasl" p0] ["libpp.ss" "libpp.fasl" p0]
["libcafe.ss" "libcafe.fasl" p0] ["libcafe.ss" "libcafe.fasl" p0]
["libtrace.ss" "libtrace.fasl" p0]
["libposix.ss" "libposix.fasl" p0] ["libposix.ss" "libposix.fasl" p0]
["libtimers.ss" "libtimers.fasl" p0] ["libtimers.ss" "libtimers.fasl" p0]
["libtoplevel.ss" "libtoplevel.fasl" p0] ["libtoplevel.ss" "libtoplevel.fasl" p0]

View File

@ -2,32 +2,34 @@
(add-tests-with-string-output "fxadd1" (add-tests-with-string-output "fxadd1"
[($fxadd1 0) => "1\n"] [(fxadd1 0) => "1\n"]
[($fxadd1 -1) => "0\n"] [(fxadd1 -1) => "0\n"]
[($fxadd1 1) => "2\n"] [(fxadd1 1) => "2\n"]
[($fxadd1 -100) => "-99\n"] [(fxadd1 -100) => "-99\n"]
[($fxadd1 1000) => "1001\n"] [(fxadd1 1000) => "1001\n"]
[($fxadd1 536870910) => "536870911\n"] [(fxadd1 536870910) => "536870911\n"]
[($fxadd1 -536870912) => "-536870911\n"] [(fxadd1 -536870912) => "-536870911\n"]
[($fxadd1 ($fxadd1 0)) => "2\n"] [(fxadd1 (fxsub1 0)) => "0\n"]
[($fxadd1 ($fxadd1 ($fxadd1 ($fxadd1 ($fxadd1 ($fxadd1 12)))))) => "18\n"] [(fxsub1 (fxadd1 0)) => "0\n"]
[(fxadd1 (fxadd1 0)) => "2\n"]
[(fxadd1 (fxadd1 (fxadd1 (fxadd1 (fxadd1 (fxadd1 12)))))) => "18\n"]
) )
(add-tests-with-string-output "fixnum->char and char->fixnum" (add-tests-with-string-output "integer->char and char->integer"
[($fixnum->char 65) => "#\\A\n"] [(integer->char 65) => "#\\A\n"]
[($fixnum->char 97) => "#\\a\n"] [(integer->char 97) => "#\\a\n"]
[($fixnum->char 122) => "#\\z\n"] [(integer->char 122) => "#\\z\n"]
[($fixnum->char 90) => "#\\Z\n"] [(integer->char 90) => "#\\Z\n"]
[($fixnum->char 48) => "#\\0\n"] [(integer->char 48) => "#\\0\n"]
[($fixnum->char 57) => "#\\9\n"] [(integer->char 57) => "#\\9\n"]
[($char->fixnum #\A) => "65\n"] [(char->integer #\A) => "65\n"]
[($char->fixnum #\a) => "97\n"] [(char->integer #\a) => "97\n"]
[($char->fixnum #\z) => "122\n"] [(char->integer #\z) => "122\n"]
[($char->fixnum #\Z) => "90\n"] [(char->integer #\Z) => "90\n"]
[($char->fixnum #\0) => "48\n"] [(char->integer #\0) => "48\n"]
[($char->fixnum #\9) => "57\n"] [(char->integer #\9) => "57\n"]
[($char->fixnum ($fixnum->char 12)) => "12\n"] [(char->integer (integer->char 12)) => "12\n"]
[($fixnum->char ($char->fixnum #\x)) => "#\\x\n"] [(integer->char (char->integer #\x)) => "#\\x\n"]
) )
(add-tests-with-string-output "fixnum?" (add-tests-with-string-output "fixnum?"
@ -45,15 +47,15 @@
[(fixnum? (fixnum? 12)) => "#f\n"] [(fixnum? (fixnum? 12)) => "#f\n"]
[(fixnum? (fixnum? #f)) => "#f\n"] [(fixnum? (fixnum? #f)) => "#f\n"]
[(fixnum? (fixnum? #\A)) => "#f\n"] [(fixnum? (fixnum? #\A)) => "#f\n"]
[(fixnum? ($char->fixnum #\r)) => "#t\n"] [(fixnum? (char->integer #\r)) => "#t\n"]
[(fixnum? ($fixnum->char 12)) => "#f\n"] [(fixnum? (integer->char 12)) => "#f\n"]
) )
(add-tests-with-string-output "fxzero?" (add-tests-with-string-output "fxzero?"
[($fxzero? 0) => "#t\n"] [(fxzero? 0) => "#t\n"]
[($fxzero? 1) => "#f\n"] [(fxzero? 1) => "#f\n"]
[($fxzero? -1) => "#f\n"] [(fxzero? -1) => "#f\n"]
) )
(add-tests-with-string-output "null?" (add-tests-with-string-output "null?"
@ -106,12 +108,12 @@
) )
(add-tests-with-string-output "fxlognot" (add-tests-with-string-output "fxlognot"
[($fxlognot 0) => "-1\n"] [(fxlognot 0) => "-1\n"]
[($fxlognot -1) => "0\n"] [(fxlognot -1) => "0\n"]
[($fxlognot 1) => "-2\n"] [(fxlognot 1) => "-2\n"]
[($fxlognot -2) => "1\n"] [(fxlognot -2) => "1\n"]
[($fxlognot 536870911) => "-536870912\n"] [(fxlognot 536870911) => "-536870912\n"]
[($fxlognot -536870912) => "536870911\n"] [(fxlognot -536870912) => "536870911\n"]
[($fxlognot ($fxlognot 237463)) => "237463\n"] [(fxlognot (fxlognot 237463)) => "237463\n"]
) )