shithub: femtolisp

Info  •  Files  •  Log

making os name symbols non-constant, so they aren't evaluated at compile time
more aliases

--- 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)

+|#

--- 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;2e<k=2e>k?;" [macos

+	  __init_globals #fn("7000r0c0c1<17B02c0c2<17802c0c3<6>0c4k52c6k75;0c8k52c9k72e:k;2e<k=2e>k?;" [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])

--- a/femtolisp/flisp.c

+++ b/femtolisp/flisp.c

@@ -814,7 +814,7 @@

 /*

   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 @@

     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);

--- 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))

 	()