ref: 2f78b407ea3d48be3e7202fc7af2529824366d34
parent: 3844191d707395bc0611a32e8cbb109f56b5c6e2
author: JeffBezanson <[email protected]>
date: Mon Jun 29 23:21:41 EDT 2009
some renaming (intern is now symbol) and moving stuff around adding scheme aliases
--- /dev/null
+++ b/femtolisp/aliases.scm
@@ -1,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)))
--- a/femtolisp/ast/asttools.lsp
+++ b/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)
--- a/femtolisp/ast/rpasses.lsp
+++ b/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)
--- a/femtolisp/builtins.c
+++ b/femtolisp/builtins.c
@@ -130,11 +130,11 @@
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 @@
{ "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 },--- a/femtolisp/cps.lsp
+++ b/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))))
--- a/femtolisp/flisp.c
+++ b/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.
- it supports 30-bit integers, symbols, conses, and full macros.
- it is case-sensitive.
- it features a simple compacting copying garbage collector.
- it uses a Scheme-style evaluation rule where any expression may appear in
- head position as long as it evaluates to a function.
- it uses Scheme-style varargs (dotted formal argument lists)
- lambdas can have only 1 body expression; use (begin ...) for multiple
- expressions. this is due to the closure representation
- (lambda args body . env)
+ characteristics:
+ * lexical scope, lisp-1
+ * unrestricted macros
+ * data types: 30-bit integer, symbol, pair, vector, char, string, table
+ iostream, procedure, low-level data types
+ * case-sensitive
+ * simple compacting copying garbage collector
+ * Scheme-style varargs (dotted formal argument lists)
+ * "human-readable" bytecode with self-hosted compiler
- This is a fully fleshed-out lisp built up from femtoLisp. It has all the
- remaining features needed to be taken seriously:
+ extra features:
* 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 @@
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,13 +1656,8 @@
return maxsp+6;
}
-// initialization -------------------------------------------------------------
+// builtins -------------------------------------------------------------------
-extern void builtins_init();
-extern void comparehash_init();
-
-static char *EXEDIR = NULL;
-
void assign_global_builtins(builtinspec_t *b)
{ while (b->name != NULL) {@@ -1784,6 +1718,61 @@
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 @@
{ 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 @@
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];
@@ -1882,9 +1881,6 @@
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);