some renaming (intern is now symbol) and moving stuff around

adding scheme aliases

femtolisp/aliases.scm

@@ -0,0 +1,47 @@
+; definitions of standard scheme procedures in terms of
+; femtolisp procedures
+
+(define vector-ref aref)
+(define vector-set! aset!)
+(define vector-length length)
+(define make-vector vector.alloc)
+
+(define array-ref! aref)
+(define (array-set! a obj i0 . idxs)
+  (if (null? idxs)
+      (aset! a i0 obj)
+      (error "array-set!: multiple dimensions not yet implemented")))
+
+(define (array-dimensions a)
+  (list (length a)))
+
+(define (complex? x) #f)
+(define (real? x) (number? x))
+(define (rational? x) (integer? x))
+(define (exact? x) (integer? x))
+(define (inexact? x) (not (exact? x)))
+(define quotient div0)
+
+(define (char->integer c) (fixnum c))
+(define (integer->char i) (wchar i))
+(define char-upcase char.upcase)
+(define char-downcase char.downcase)
+(define char=? =)
+(define char<? <)
+(define char>? >)
+(define char<=? <=)
+(define char>=? >=)
+
+(define string=? =)
+(define string<? <)
+(define string>? >)
+(define string<=? <=)
+(define string>=? >=)
+(define string-copy copy)
+(define string-append string)
+(define string-length string.count)
+(define string->symbol symbol)
+(define (symbol->string s) (string s))
+
+(define (string-ref s i)
+  (string.char s (string.inc s 0 i)))

femtolisp/ast/asttools.lsp

@@ -2,7 +2,7 @@
 ; utilities for AST processing
 
 (define (symconcat s1 s2)
-  (intern (string s1 s2)))
+  (symbol (string s1 s2)))
 
 (define (list-adjoin item lst)
   (if (member item lst)

femtolisp/ast/rpasses.lsp

@@ -21,7 +21,7 @@
 
 (let ((ctr 0))
   (set! r-gensym (lambda ()
-		   (prog1 (intern (string "%r:" ctr))
+		   (prog1 (symbol (string "%r:" ctr))
 			  (set! ctr (+ ctr 1))))))
 
 (define (dollarsign-transform e)

femtolisp/builtins.c

@@ -130,11 +130,11 @@ static value_t fl_exit(value_t *args, u_int32_t nargs)
     return NIL;
 }
 
-static value_t fl_intern(value_t *args, u_int32_t nargs)
+static value_t fl_symbol(value_t *args, u_int32_t nargs)
 {
-    argcount("intern", nargs, 1);
+    argcount("symbol", nargs, 1);
     if (!isstring(args[0]))
-        type_error("intern", "string", args[0]);
+        type_error("symbol", "string", args[0]);
     return symbol(cvalue_data(args[0]));
 }
 
@@ -416,7 +416,7 @@ static builtinspec_t builtin_info[] = {
     { "set-top-level-value!", fl_set_top_level_value },
     { "raise", fl_raise },
     { "exit", fl_exit },
-    { "intern", fl_intern },
+    { "symbol", fl_symbol },
 
     { "fixnum", fl_fixnum },
     { "truncate", fl_truncate },

femtolisp/cps.lsp

@@ -17,7 +17,7 @@
       (k (apply f args))))
 (define *funcall/cc-names*
   (list->vector
-   (map (lambda (i) (intern (string 'funcall/cc- i)))
+   (map (lambda (i) (symbol (string 'funcall/cc- i)))
         (iota 6))))
 (define-macro (def-funcall/cc-n args)
   (let ((name (aref *funcall/cc-names* (length args))))

femtolisp/flisp.c

@@ -1,35 +1,29 @@
 /*
   femtoLisp
 
-  a minimal interpreter for a minimal lisp dialect
+  a compact interpreter for a minimal lisp/scheme dialect
 
-  this lisp dialect uses lexical scope and self-evaluating lambda.
+  characteristics:
-  it supports 30-bit integers, symbols, conses, and full macros.
+  * lexical scope, lisp-1
-  it is case-sensitive.
+  * unrestricted macros
-  it features a simple compacting copying garbage collector.
+  * data types: 30-bit integer, symbol, pair, vector, char, string, table
-  it uses a Scheme-style evaluation rule where any expression may appear in
+      iostream, procedure, low-level data types
-    head position as long as it evaluates to a function.
+  * case-sensitive
-  it uses Scheme-style varargs (dotted formal argument lists)
+  * simple compacting copying garbage collector
-  lambdas can have only 1 body expression; use (begin ...) for multiple
+  * Scheme-style varargs (dotted formal argument lists)
-    expressions. this is due to the closure representation
+  * "human-readable" bytecode with self-hosted compiler
-    (lambda args body . env)
 
-  This is a fully fleshed-out lisp built up from femtoLisp. It has all the
+  extra features:
-  remaining features needed to be taken seriously:
   * circular structure can be printed and read
-  * #. read macro for eval-when-read and correctly printing builtins
+  * #. read macro for eval-when-read and readably printing builtins
   * read macros for backquote
   * symbol character-escaping printer
-  * vectors
   * exceptions
   * gensyms (can be usefully read back in, too)
-  * #| multiline comments |#
+  * #| multiline comments |#, lots of other lexical syntax
   * generic compare function, cyclic equal
   * cvalues system providing C data types and a C FFI
   * constructor notation for nicely printing arbitrary values
-  * strings
-  * hash tables
-  * I/O streams
 
   by Jeff Bezanson (C) 2009
   Distributed under the BSD License
@@ -738,61 +732,6 @@ static value_t apply_liststar(value_t L, int star)
     return POP();
 }
 
-value_t fl_copylist(value_t *args, u_int32_t nargs)
-{
-    argcount("copy-list", nargs, 1);
-    return FL_COPYLIST(args[0]);
-}
-
-value_t fl_append(value_t *args, u_int32_t nargs)
-{
-    if (nargs == 0)
-        return NIL;
-    value_t first=NIL, lst, lastcons=NIL;
-    fl_gc_handle(&first);
-    fl_gc_handle(&lastcons);
-    uint32_t i=0;
-    while (1) {
-        if (i >= MAX_ARGS) {
-            lst = car_(args[MAX_ARGS]);
-            args[MAX_ARGS] = cdr_(args[MAX_ARGS]);
-            if (!iscons(args[MAX_ARGS])) break;
-        }
-        else {
-            lst = args[i++];
-            if (i >= nargs) break;
-        }
-        if (iscons(lst)) {
-            lst = FL_COPYLIST(lst);
-            if (first == NIL)
-                first = lst;
-            else
-                cdr_(lastcons) = lst;
-            lastcons = tagptr((((cons_t*)curheap)-1), TAG_CONS);
-        }
-        else if (lst != NIL) {
-            type_error("append", "cons", lst);
-        }
-    }
-    if (first == NIL)
-        first = lst;
-    else
-        cdr_(lastcons) = lst;
-    fl_free_gc_handles(2);
-    return first;
-}
-
-value_t fl_liststar(value_t *args, u_int32_t nargs)
-{
-    if (nargs == 1) return args[0];
-    else if (nargs == 0) argcount("list*", nargs, 1);
-    if (nargs > MAX_ARGS) {
-        args[MAX_ARGS] = apply_liststar(args[MAX_ARGS], 1);
-        return list(args, nargs);
-    }
-    return _list(args, nargs, 1);
-}
-
 static value_t do_trycatch()
 {
     uint32_t saveSP = SP;
@@ -1717,12 +1656,7 @@ static uint32_t compute_maxstack(uint8_t *code, size_t len)
     return maxsp+6;
 }
 
-// initialization -------------------------------------------------------------
+// builtins -------------------------------------------------------------------
-
-extern void builtins_init();
-extern void comparehash_init();
-
-static char *EXEDIR = NULL;
 
 void assign_global_builtins(builtinspec_t *b)
 {
@@ -1784,6 +1718,61 @@ static value_t fl_function_env(value_t *args, uint32_t nargs)
     return fn_env(v);
 }
 
+value_t fl_copylist(value_t *args, u_int32_t nargs)
+{
+    argcount("copy-list", nargs, 1);
+    return FL_COPYLIST(args[0]);
+}
+
+value_t fl_append(value_t *args, u_int32_t nargs)
+{
+    if (nargs == 0)
+        return NIL;
+    value_t first=NIL, lst, lastcons=NIL;
+    fl_gc_handle(&first);
+    fl_gc_handle(&lastcons);
+    uint32_t i=0;
+    while (1) {
+        if (i >= MAX_ARGS) {
+            lst = car_(args[MAX_ARGS]);
+            args[MAX_ARGS] = cdr_(args[MAX_ARGS]);
+            if (!iscons(args[MAX_ARGS])) break;
+        }
+        else {
+            lst = args[i++];
+            if (i >= nargs) break;
+        }
+        if (iscons(lst)) {
+            lst = FL_COPYLIST(lst);
+            if (first == NIL)
+                first = lst;
+            else
+                cdr_(lastcons) = lst;
+            lastcons = tagptr((((cons_t*)curheap)-1), TAG_CONS);
+        }
+        else if (lst != NIL) {
+            type_error("append", "cons", lst);
+        }
+    }
+    if (first == NIL)
+        first = lst;
+    else
+        cdr_(lastcons) = lst;
+    fl_free_gc_handles(2);
+    return first;
+}
+
+value_t fl_liststar(value_t *args, u_int32_t nargs)
+{
+    if (nargs == 1) return args[0];
+    else if (nargs == 0) argcount("list*", nargs, 1);
+    if (nargs > MAX_ARGS) {
+        args[MAX_ARGS] = apply_liststar(args[MAX_ARGS], 1);
+        return list(args, nargs);
+    }
+    return _list(args, nargs, 1);
+}
+
 static builtinspec_t core_builtin_info[] = {
     { "function", fl_function },
     { "function:code", fl_function_code },
@@ -1797,6 +1786,13 @@ static builtinspec_t core_builtin_info[] = {
     { NULL, NULL }
 };
 
+// initialization -------------------------------------------------------------
+
+extern void builtins_init();
+extern void comparehash_init();
+
+static char *EXEDIR = NULL;
+
 static void lisp_init(void)
 {
     int i;
@@ -1870,6 +1866,9 @@ static void lisp_init(void)
     setc(symbol("*os-name*"), symbol("unknown"));
 #endif
 
+    the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR);
+    vector_setsize(the_empty_vector, 0);
+
     cvalues_init();
 
     char buf[1024];
@@ -1883,9 +1882,6 @@ static void lisp_init(void)
     memory_exception_value = list2(MemoryError,
                                    cvalue_static_cstring("out of memory"));
 
-    the_empty_vector = tagptr(alloc_words(1), TAG_VECTOR);
-    vector_setsize(the_empty_vector, 0);
-
     assign_global_builtins(core_builtin_info);
 
     builtins_init();