From 3dc2275a076dee5dcaa5b924a1a116131ed70cdc Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Thu, 22 Oct 2009 03:32:12 +0000 Subject: [PATCH] making os name symbols non-constant, so they aren't evaluated at compile time more aliases --- femtolisp/aliases.scm | 20 ++++++++++++++++++++ femtolisp/flisp.boot | 8 ++++---- femtolisp/flisp.c | 10 +++++----- femtolisp/system.lsp | 4 ++-- 4 files changed, 31 insertions(+), 11 deletions(-) diff --git a/femtolisp/aliases.scm b/femtolisp/aliases.scm index a25fca2..78700e8 100644 --- a/femtolisp/aliases.scm +++ b/femtolisp/aliases.scm @@ -19,6 +19,12 @@ (let (($gensym gensym)) (lambda ((x #f)) ($gensym)))) +(define-macro (begin0 first . rest) + (let ((g (gensym))) + `(let ((,g ,first)) + ,@rest + ,g))) + (define vector-ref aref) (define vector-set! aset!) (define vector-length length) @@ -94,11 +100,13 @@ (define (input-port? x) (iostream? x)) (define (output-port? x) (iostream? x)) +(define (port? x) (iostream? x)) (define close-input-port io.close) (define close-output-port io.close) (define (read-char (s *input-stream*)) (io.getc s)) (define (peek-char (s *input-stream*)) (io.peekc s)) (define (write-char c (s *output-stream*)) (io.putc s c)) +; TODO: unread-char (define (port-eof? p) (io.eof? p)) (define (open-input-string str) (let ((b (buffer))) @@ -237,3 +245,15 @@ (lambda (sym key) (let ((sp (get *properties* sym #f))) (and sp (has? sp key) (del! sp key)))))) + +; --- gambit +#| +(define (with-exception-catcher hand thk) + (trycatch (thk) + (lambda (e) (hand e)))) + +(define make-table table) +(define table-ref get) +(define table-set! put!) +(define read-line io.readline) +|# diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index f0fcb7c..04dd1fc 100644 --- a/femtolisp/flisp.boot +++ b/femtolisp/flisp.boot @@ -29,14 +29,14 @@ *output-stream* copy-list]) catch #fn("7000r2c0qe13041;" [#fn("@000r1c0\x7fc1|L1c2c3c4|L2c5c6|L2c7c8L2L3c5c9|L2~L3L4c:|L2c;|L2L4L3L3;" [trycatch lambda if and pair? eq car quote thrown-value cadr caddr raise]) gensym])) - *whitespace* "\t\n\v\f\r \u0085\u00a0\u1680\u180e\u2000\u2001\u2002\u2003\u2004\u2005\u2006\u2007\u2008\u2009\u200a\u2028\u2029\u202f\u205f\u3000" - 1+ #fn("7000r1|aw;" [] 1+) 1- - #fn("7000r1|ax;" [] 1-) 1arg-lambda? #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda + *whitespace* "\t\n\v\f\r \u0085  ᠎           \u2028\u2029  　" 1+ + #fn("7000r1|aw;" [] 1+) 1- #fn("7000r1|ax;" [] 1-) 1arg-lambda? + #fn("8000r1|F16T02|Mc0<16J02|NF16B02|\x84F16:02e1|\x84a42;" [lambda length=] 1arg-lambda?) <= #fn("7000r2|}X17602|}W;" [] <=) > #fn("7000r2}|X;" [] >) >= #fn("7000r2}|X17602|}W;" [] >=) Instructions #table(not 16 vargc 67 load1 49 = 39 setc.l 64 sub2 72 brne.l 83 largc 74 brnn 85 loadc.l 58 loadi8 50 < 40 nop 0 set-cdr! 32 loada 55 bound? 21 / 37 neg 73 brn.l 88 lvargc 75 brt 7 trycatch 68 null? 17 load0 48 jmp.l 8 loadv 51 seta 61 keyargs 91 * 36 function? 26 builtin? 23 aref 43 optargs 89 vector? 24 loadt 45 brf 6 symbol? 19 cdr 30 for 69 loadc00 78 pop 2 pair? 22 cadr 84 closure 65 loadf 46 compare 41 loadv.l 52 setg.l 60 brn 87 eqv? 13 aset! 44 eq? 12 atom? 15 boolean? 18 brt.l 10 tapply 70 dummy_nil 94 loada0 76 brbound 90 list 28 dup 1 apply 33 loadc 57 loadc01 79 dummy_t 92 setg 59 loada1 77 tcall.l 81 jmp 5 fixnum? 25 cons 27 loadg.l 54 tcall 4 call 3 - 35 brf.l 9 + 34 dummy_f 93 add2 71 seta.l 62 loadnil 47 brnn.l 86 setc 63 set-car! 31 vector 42 loadg 53 loada.l 56 argc 66 div0 38 ret 11 number? 20 equal? 14 car 29 call.l 80 brne 82) - __init_globals #fn("7000r0c0c1<17B02c0c2<17802c0c3<6>0c4k52c6k75;0c8k52c9k72e:k;2ek?;" [macos + __init_globals #fn("7000r0c0c1<17B02c0c2<17802c0c3<6>0c4k52c6k75;0c8k52c9k72e:k;2ek?;" [linux win32 win64 windows "\\" *directory-separator* "\r\n" *linefeed* "/" "\n" *stdout* *output-stream* *stdin* *input-stream* *stderr* *error-stream*] __init_globals) __script #fn("7000r1c0qc1t;" [#fn("7000r0e0~41;" [load]) diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index a6e3268..0295431 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -814,7 +814,7 @@ static value_t do_trycatch() /* argument layout on stack is |--required args--|--opt args--|--kw args--|--rest args... - */ +*/ static uint32_t process_keys(value_t kwtable, uint32_t nreq, uint32_t nkw, uint32_t nopt, uint32_t bp, uint32_t nargs, int va) @@ -2215,13 +2215,13 @@ static void lisp_init(void) setc(symbol("top-level-bound?"), builtin(OP_BOUNDP)); #ifdef LINUX - setc(symbol("*os-name*"), symbol("linux")); + set(symbol("*os-name*"), symbol("linux")); #elif defined(WIN32) || defined(WIN64) - setc(symbol("*os-name*"), symbol("win32")); + set(symbol("*os-name*"), symbol("win32")); #elif defined(MACOSX) - setc(symbol("*os-name*"), symbol("macos")); + set(symbol("*os-name*"), symbol("macos")); #else - setc(symbol("*os-name*"), symbol("unknown")); + set(symbol("*os-name*"), symbol("unknown")); #endif the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR); diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index ce8332a..51062ad 100644 --- a/femtolisp/system.lsp +++ b/femtolisp/system.lsp @@ -22,8 +22,8 @@ (prog1 acc (while (pair? lst) (begin (set! acc - (cdr (set-cdr! acc (cons (f (car lst)) ())))) - (set! lst (cdr lst))))))) + (cdr (set-cdr! acc (cons (f (car lst)) ())))) + (set! lst (cdr lst))))))) (define (mapn f lsts) (if (null? (car lsts)) ()