fixed bug in ($make-vector 0)
This commit is contained in:
parent
42e3d53d00
commit
6bdb38ca16
|
@ -2864,7 +2864,6 @@
|
|||
(parameterize ([exceptions-conc ac])
|
||||
(T body ac))))
|
||||
(map Clambda code*))]))
|
||||
;;;
|
||||
;;; (print-code x)
|
||||
(Program x))
|
||||
|
||||
|
|
|
@ -1 +1 @@
|
|||
1435
|
||||
1438
|
||||
|
|
|
@ -45,10 +45,11 @@
|
|||
(prm 'mref x (K (- disp tag)))))
|
||||
|
||||
(define (dirty-vector-set address)
|
||||
(define shift-bits 2)
|
||||
(prm 'mset
|
||||
(prm 'int+
|
||||
(prm 'mref pcr (K pcb-dirty-vector))
|
||||
(prm 'sll (prm 'srl address (K pageshift)) (K wordshift)))
|
||||
(prm 'sll (prm 'srl address (K pageshift)) (K shift-bits)))
|
||||
(K 0)
|
||||
(K dirty-word)))
|
||||
|
||||
|
@ -391,7 +392,7 @@
|
|||
(K vector-tag))])
|
||||
(prm 'mset v
|
||||
(K (- disp-vector-length vector-tag))
|
||||
(K (make-constant (* i fx-scale))))
|
||||
(K (* i fx-scale)))
|
||||
v)]
|
||||
[else
|
||||
(with-tmp ([alen (align-code (T len) disp-vector-data)])
|
||||
|
|
|
@ -70,6 +70,7 @@
|
|||
[fx- $fx-]
|
||||
[fx* $fx*]
|
||||
[fxadd1 $fxadd1]
|
||||
[fxsub1 $fxsub1]
|
||||
[fxlogor $fxlogor]
|
||||
[fxlogand $fxlogand]
|
||||
[fxlognot $fxlognot]
|
||||
|
@ -82,6 +83,22 @@
|
|||
[cons cons]
|
||||
[car $car]
|
||||
[cdr $cdr]
|
||||
[set-car! $set-car!]
|
||||
[set-cdr! $set-cdr!]
|
||||
[eq? eq?]
|
||||
[make-vector $make-vector]
|
||||
[vector? vector?]
|
||||
[vector-length $vector-length]
|
||||
[vector-set! $vector-set!]
|
||||
[vector-ref $vector-ref]
|
||||
[string? string?]
|
||||
[make-string $make-string]
|
||||
[string-set! $string-set!]
|
||||
[string-ref $string-ref]
|
||||
[string-length $string-length]
|
||||
[char= $char=]
|
||||
[fixnum->char $fixnum->char]
|
||||
[char->fixnum $char->fixnum]
|
||||
))
|
||||
|
||||
|
||||
|
@ -102,12 +119,17 @@
|
|||
`((primitive ,(cadr (assq prim prims-alist))) ,args ...)]
|
||||
[(if ,[e0] ,[e1] ,[e2])
|
||||
`(if ,e0 ,e1 ,e2)]
|
||||
[(let ([,lhs* ,[rhs*]] ...) ,body)
|
||||
[(let ([,lhs* ,[rhs*]] ...) ,body ,body* ...)
|
||||
(let ([nlhs* (map gensym lhs*)])
|
||||
(let ([env (append (map cons lhs* nlhs*) env)])
|
||||
`((case-lambda
|
||||
[,nlhs* ,(Expr body env)])
|
||||
[,nlhs*
|
||||
(begin ,(Expr body env)
|
||||
,(map (lambda (x) (Expr x env)) body*)
|
||||
...)])
|
||||
,rhs* ...)))]
|
||||
[(begin ,[e] ,[e*] ...)
|
||||
`(begin ,e ,e* ...)]
|
||||
[,_ (error 'fixup "invalid expression" _)]))
|
||||
(Expr x '()))
|
||||
|
||||
|
@ -119,14 +141,15 @@
|
|||
(append all-tests
|
||||
'([test string] ...)))])))
|
||||
|
||||
(include "tests/tests-1.1-req.scm")
|
||||
(include "tests/tests-1.2-req.scm")
|
||||
(include "tests/tests-1.3-req.scm")
|
||||
(include "tests/tests-1.4-req.scm")
|
||||
(include "tests/tests-1.5-req.scm")
|
||||
(include "tests/tests-1.6-req.scm")
|
||||
(include "tests/tests-1.7-req.scm")
|
||||
(include "tests/tests-1.8-req.scm")
|
||||
; (include "tests/tests-1.1-req.scm")
|
||||
; (include "tests/tests-1.2-req.scm")
|
||||
; (include "tests/tests-1.3-req.scm")
|
||||
; (include "tests/tests-1.4-req.scm")
|
||||
; (include "tests/tests-1.5-req.scm")
|
||||
; (include "tests/tests-1.6-req.scm")
|
||||
; (include "tests/tests-1.7-req.scm")
|
||||
; (include "tests/tests-1.8-req.scm")
|
||||
(include "tests/tests-1.9-req.scm")
|
||||
|
||||
|
||||
(current-primitive-locations
|
||||
|
|
|
@ -129,13 +129,11 @@ print(FILE* fh, ikptr x){
|
|||
else if(tagof(x) == string_tag){
|
||||
ikptr fxlen = ref(x, off_string_length);
|
||||
int len = unfix(fxlen);
|
||||
fprintf(stderr, "bug: printer busted!\n");
|
||||
exit(-1);
|
||||
char* data = 0; //string_data(x);
|
||||
long int * data = (long int*)(x + off_string_data);
|
||||
fprintf(fh, "\"");
|
||||
int i;
|
||||
for(i=0; i<len; i++){
|
||||
char c = data[i];
|
||||
char c = (data[i]) >> char_shift;
|
||||
if((c == '\\') || (c == '"')){
|
||||
fprintf(fh, "\\");
|
||||
}
|
||||
|
|
Loading…
Reference in New Issue