uuid and gensym were not generating pretty unique strings. fixed.
This commit is contained in:
parent
976694a3ab
commit
755beeb7d7
|
@ -1 +1 @@
|
|||
1323
|
||||
1324
|
||||
|
|
|
@ -21,7 +21,8 @@
|
|||
(except (ikarus) assembler-output))
|
||||
|
||||
(define (compile1 x)
|
||||
(printf "Compiling ~s\n" x)
|
||||
(printf "Compiling:\n")
|
||||
(pretty-print x)
|
||||
(let ([p (open-file-output-port "test64.fasl" (file-options no-fail))])
|
||||
(parameterize ([assembler-output #t])
|
||||
(compile-core-expr-to-port x p))
|
||||
|
@ -80,14 +81,29 @@
|
|||
|
||||
|
||||
(define (fixup x)
|
||||
(match x
|
||||
[,n (guard (self-evaluating? n)) `(quote ,n)]
|
||||
[(,prim ,[args] ...)
|
||||
(guard (assq prim prims-alist))
|
||||
`((primitive ,(cadr (assq prim prims-alist))) ,args ...)]
|
||||
[(if ,[e0] ,[e1] ,[e2])
|
||||
`(if ,e0 ,e1 ,e2)]
|
||||
[,_ (error 'fixup "invalid expression" _)]))
|
||||
(define (Expr x env)
|
||||
(match x
|
||||
[,n (guard (self-evaluating? n)) `(quote ,n)]
|
||||
[,var (guard (symbol? var))
|
||||
(cond
|
||||
[(assq var env) => cdr]
|
||||
[else (error 'fixup "unbound var" var)])]
|
||||
[(,rator ,[rand*] ...)
|
||||
(guard (assq rator env))
|
||||
`(,(Expr rator env) ,rand* ...)]
|
||||
[(,prim ,[args] ...)
|
||||
(guard (assq prim prims-alist))
|
||||
`((primitive ,(cadr (assq prim prims-alist))) ,args ...)]
|
||||
[(if ,[e0] ,[e1] ,[e2])
|
||||
`(if ,e0 ,e1 ,e2)]
|
||||
[(let ([,lhs* ,[rhs*]] ...) ,body)
|
||||
(let ([nlhs* (map gensym lhs*)])
|
||||
(let ([env (append (map cons lhs* nlhs*) env)])
|
||||
`((case-lambda
|
||||
[,nlhs* ,(Expr body env)])
|
||||
,rhs* ...)))]
|
||||
[,_ (error 'fixup "invalid expression" _)]))
|
||||
(Expr x '()))
|
||||
|
||||
(define-syntax add-tests-with-string-output
|
||||
(lambda (x)
|
||||
|
@ -103,7 +119,8 @@
|
|||
;(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.5-req.scm")
|
||||
(include "tests/tests-1.6-req.scm")
|
||||
|
||||
(test-all)
|
||||
(printf "Passed ~s tests\n" (length all-tests))
|
||||
|
|
|
@ -530,7 +530,7 @@ char* ik_uuid(char* str){
|
|||
static const char* uuid_chars =
|
||||
"!$%&/0123456789<=>?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
|
||||
static int uuid_strlen = 1;
|
||||
ikptr ik_uuid(ikptr str){
|
||||
ikptr ik_uuid(ikptr bv){
|
||||
static int fd = -1;
|
||||
if(fd == -1){
|
||||
fd = open("/dev/urandom", O_RDONLY);
|
||||
|
@ -539,16 +539,16 @@ ikptr ik_uuid(ikptr str){
|
|||
}
|
||||
uuid_strlen = strlen(uuid_chars);
|
||||
}
|
||||
long int n = unfix(ref(str, off_bytevector_length));
|
||||
char* data = (char*)(long)(str+off_bytevector_data);
|
||||
long int n = unfix(ref(bv, off_bytevector_length));
|
||||
unsigned char* data = (unsigned char*)(long)(bv+off_bytevector_data);
|
||||
read(fd, data, n);
|
||||
char* p = data;
|
||||
char* q = data + n;
|
||||
unsigned char* p = data;
|
||||
unsigned char* q = data + n;
|
||||
while(p < q){
|
||||
*p = uuid_chars[*p % uuid_strlen];
|
||||
p++;
|
||||
}
|
||||
return str;
|
||||
return bv;
|
||||
}
|
||||
|
||||
|
||||
|
|
Loading…
Reference in New Issue