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

uuid and gensym were not generating pretty unique strings. fixed.

This commit is contained in:
Abdulaziz Ghuloum 2008-01-04 05:47:18 -05:00
parent 976694a3ab
commit 755beeb7d7
3 changed files with 34 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scheme/last-revision
View File

@ -1 +1 @@
1323 1324

37
scheme/test64.ss
View File

@ -21,7 +21,8 @@
(except (ikarus) assembler-output)) (except (ikarus) assembler-output))
(define (compile1 x) (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))]) (let ([p (open-file-output-port "test64.fasl" (file-options no-fail))])
(parameterize ([assembler-output #t]) (parameterize ([assembler-output #t])
(compile-core-expr-to-port x p)) (compile-core-expr-to-port x p))
@ -80,14 +81,29 @@
(define (fixup x) (define (fixup x)
(match x (define (Expr x env)
[,n (guard (self-evaluating? n)) `(quote ,n)] (match x
[(,prim ,[args] ...) [,n (guard (self-evaluating? n)) `(quote ,n)]
(guard (assq prim prims-alist)) [,var (guard (symbol? var))
`((primitive ,(cadr (assq prim prims-alist))) ,args ...)] (cond
[(if ,[e0] ,[e1] ,[e2]) [(assq var env) => cdr]
`(if ,e0 ,e1 ,e2)] [else (error 'fixup "unbound var" var)])]
[,_ (error 'fixup "invalid expression" _)])) [(,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 (define-syntax add-tests-with-string-output
(lambda (x) (lambda (x)
@ -103,7 +119,8 @@
;(include "tests/tests-1.2-req.scm") ;(include "tests/tests-1.2-req.scm")
;(include "tests/tests-1.3-req.scm") ;(include "tests/tests-1.3-req.scm")
;(include "tests/tests-1.4-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) (test-all)
(printf "Passed ~s tests\n" (length all-tests)) (printf "Passed ~s tests\n" (length all-tests))

12
src/ikarus-runtime.c
View File

@ -530,7 +530,7 @@ char* ik_uuid(char* str){
static const char* uuid_chars = static const char* uuid_chars =
"!$%&/0123456789<=>?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; "!$%&/0123456789<=>?ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz";
static int uuid_strlen = 1; static int uuid_strlen = 1;
ikptr ik_uuid(ikptr str){ ikptr ik_uuid(ikptr bv){
static int fd = -1; static int fd = -1;
if(fd == -1){ if(fd == -1){
fd = open("/dev/urandom", O_RDONLY); fd = open("/dev/urandom", O_RDONLY);
@ -539,16 +539,16 @@ ikptr ik_uuid(ikptr str){
} }
uuid_strlen = strlen(uuid_chars); uuid_strlen = strlen(uuid_chars);
} }
long int n = unfix(ref(str, off_bytevector_length)); long int n = unfix(ref(bv, off_bytevector_length));
char* data = (char*)(long)(str+off_bytevector_data); unsigned char* data = (unsigned char*)(long)(bv+off_bytevector_data);
read(fd, data, n); read(fd, data, n);
char* p = data; unsigned char* p = data;
char* q = data + n; unsigned char* q = data + n;
while(p < q){ while(p < q){
*p = uuid_chars[*p % uuid_strlen]; *p = uuid_chars[*p % uuid_strlen];
p++; p++;
} }
return str; return bv;
} }