adding gensym?, fixing keyword?

checking in psyntax library, and more scheme aliases to make it work

femtolisp/aliases.scm

@@ -1,8 +1,18 @@
 ; definitions of standard scheme procedures in terms of
 ; femtolisp procedures
+; sufficient to run the R5RS version of psyntax
 
 (define top-level-bound? bound?)
 (define (eval-core x) (eval x))
+(define (symbol-value s) (top-level-value s))
+(define (set-symbol-value! s v) (set-top-level-value! s v))
+(define (void) (if #f #f))
+(define (eval x)
+  ((compile-thunk (expand
+		   (if (and (pair? x)
+			    (equal? (car x) "noexpand"))
+		       (cadr x)
+		       x)))))
 
 (define vector-ref aref)
 (define vector-set! aset!)
@@ -86,6 +96,7 @@
     (io.seek b 0)
     b))
 (define (open-output-string) (buffer))
+(define open-string-output-port open-output-string)
 (define (get-output-string b)
   (let ((p (io.pos b)))
     (io.seek b 0)
@@ -165,11 +176,13 @@
   (or (null? l)
       (and (apply proc (car l) (map car ls))
            (apply for-all proc (cdr l) (map cdr ls)))))
+(define andmap for-all)
 
 (define (exists proc l . ls)
   (and (not (null? l))
        (or (apply proc (car l) (map car ls))
 	   (apply exists proc (cdr l) (map cdr ls)))))
+(define ormap exists)
 
 (define cons* list*)
 
@@ -182,3 +195,28 @@
 (define (partition pred lst)
   (let ((s (separate pred lst)))
     (values (car s) (cdr s))))
+
+(define (dynamic-wind before thunk after)
+  (before)
+  (unwind-protect (thunk)
+		  (after)))
+
+(let ((*properties* (table)))
+  (set! putprop
+	(lambda (sym key val)
+	  (let ((sp (get *properties* sym #f)))
+	    (if (not sp)
+		(let ((t (table)))
+		  (put! *properties* sym t)
+		  (set! sp t)))
+	    (put! sp key val))))
+
+  (set! getprop
+	(lambda (sym key)
+	  (let ((sp (get *properties* sym #f)))
+	    (and sp (get sp key #f)))))
+
+  (set! remprop
+	(lambda (sym key)
+	  (let ((sp (get *properties* sym #f)))
+	    (and sp (has? sp key) (del! sp key))))))

femtolisp/builtins.c

@@ -134,8 +134,8 @@ static value_t fl_symbol(value_t *args, u_int32_t nargs)
 static value_t fl_keywordp(value_t *args, u_int32_t nargs)
 {
     argcount("keyword?", nargs, 1);
-    symbol_t *sym = tosymbol(args[0], "keyword?");
-    return iskeyword(sym) ? FL_T : FL_F;
+    return (issymbol(args[0]) &&
+            iskeyword((symbol_t*)ptr(args[0]))) ? FL_T : FL_F;
 }
 
 static value_t fl_top_level_value(value_t *args, u_int32_t nargs)

femtolisp/flisp.c

@@ -309,6 +309,12 @@ value_t fl_gensym(value_t *args, uint32_t nargs)
     return tagptr(gs, TAG_SYM);
 }
 
+static value_t fl_gensymp(value_t *args, u_int32_t nargs)
+{
+    argcount("gensym?", nargs, 1);
+    return isgensym(args[0]) ? FL_T : FL_F;
+}
+
 char *symbol_name(value_t v)
 {
     if (ismanaged(v)) {
@@ -2063,6 +2069,7 @@ static builtinspec_t core_builtin_info[] = {
     { "function:name", fl_function_name },
     { "stacktrace", fl_stacktrace },
     { "gensym", fl_gensym },
+    { "gensym?", fl_gensymp },
     { "hash", fl_hash },
     { "copy-list", fl_copylist },
     { "append", fl_append },

femtolisp/unittest.lsp

@@ -171,6 +171,13 @@
 (assert (equal? (aref iarr 0) 32))
 (assert (equal? (aref iarr #int8(3)) 7))
 
+; gensyms
+(assert (gensym? (gensym)))
+(assert (not (gensym? 'a)))
+(assert (not (eq? (gensym) (gensym))))
+(assert (not (equal? (string (gensym)) (string (gensym)))))
+(let ((gs (gensym))) (assert (eq? gs gs)))
+
 ; ok, a couple end-to-end tests as well
 (define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
 (assert (equal? (fib 20) 6765))