Library functioning using new quasiquote.

New macro quasiquote is much slower than previous primitive
implementation, but more elegant.  Syntactic analysis should
mitigate some of this problem.  Currently shares limitation
of primitive implementation in that quasiquotations can't be
reliably nested.

diff --git a/src/scheme-library.scm b/src/scheme-library.scm
index ec5c08e..8740e15 100644 (file)
--- a/src/scheme-library.scm
+++ b/src/scheme-library.scm
@@ -2,15 +2,78 @@
 ;; Standard Library Procedures and Macros ;; 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+;; MISC ESSENTIAL PROCEDURES
+
+(define list
+  (lambda args args))
+
+(define map
+  (lambda (proc l)
+    (if (null? l)
+        '()
+        (cons (proc (car l)) (map proc (cdr l))))))
+
+(define join-lists
+  (lambda (l1 l2)
+    (if (null? l1)
+      l2
+      (cons (car l1) (join-lists (cdr l1) l2)))))
+
+; Append an arbitrary number of lists together
+(define append
+  (lambda lists
+  (if (null? lists)
+    ()
+    (if (null? (cdr lists))
+      (car lists)
+      (join-lists (car lists) (apply append (cdr lists)))))))
+
+
 ;; DERIVED FORMS
 
-;; define (procedural syntax)
+;; define
 
 (define-macro (define args . body)
               (if (pair? args)
-                `(define ,(car args) (lambda ,(cdr args) ,@body))
+                (list 'define (car args) (join-lists (list 'lambda (cdr args)) body))
                 'no-match))
 
+;; not
+
+(define-macro (not x)
+              (list 'if x #f #t))
+
+;; let
+
+(define-macro (let args . body)
+              (join-lists
+                (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body))
+                (map (lambda (x) (car (cdr x))) args)))
+
+;; quasiquote/unquote (one nesting level only)
+
+((lambda ()
+   (define (qqhelper l)
+     (if (null? l)
+       l
+       (let ((head (car l))
+             (tail (cdr l)))
+
+         (if (pair? head)
+             (if (eq? (car head) 'unquote)
+                 (list 'cons (car (cdr head)) (qqhelper tail))
+                 (if (eq? (car head) 'unquote-splicing)
+                     (list 'join-lists (car (cdr head)) (qqhelper tail))
+                     (list 'cons (list 'quasiquote head) (qqhelper tail))))
+             (if (symbol? head)
+                 (list 'cons (list 'quote head) (qqhelper tail))
+                 (list 'cons head (qqhelper tail)))))))
+
+   (define-macro (quasiquote arg)
+                 (if (not (pair? arg))
+                   (list 'quote arg)
+                   (qqhelper arg)))))
+
 ;; begin
 
 (define-macro (begin . sequence)
@@ -32,20 +95,6 @@
 (define-macro (cdddr l) `(cdr (cdr (cdr ,l))))
 (define-macro (cadddr l) `(car (cdr (cdr (cdr ,l)))))
 
-
-;; Methods used in remaining macro definitions:
-
-(define (map proc l)
-  (if (null? l)
-    '()
-    (cons (proc (car l)) (map proc (cdr l)))))
-
-;; let
-
-(define-macro (let args . body)
-              `((lambda ,(map (lambda (x) (car x)) args)
-                 ,@body) ,@(map (lambda (x) (cadr x)) args)))
-
 ;; let*
 
 (define-macro (let* args . body)
@@ -105,31 +154,24 @@
    (define-macro (and . expressions)
                  (if (null? expressions)
                    #t
-                   (expand-and-expressions expressions)))
-   ))
+                   (expand-and-expressions expressions)))))
 
 ;; or
 
 ((lambda ()
    (define (expand-or-expressions expressions)
-     (if (null? expressions)
-       #f
-       (let ((first (car expressions))
-             (rest (cdr expressions))
-             (val (gensym)))
-         `(let ((,val ,first))
-            (if ,val
-              ,val
-              ,(expand-or-expressions rest))))))
+     (let ((first (car expressions))
+           (rest (cdr expressions)))
+       (if (null? rest)
+           first
+           `(if ,first
+                #t
+                ,(expand-or-expressions rest)))))
 
    (define-macro (or . expressions)
-                 (expand-or-expressions expressions))
-   ))
-
-;; not
-
-(define-macro (not x)
-              `(if ,x #f #t))
+     (if (null? expressions)
+         #f
+         (expand-or-expressions expressions)))))
 
 ;; FUNCTIONAL PROGRAMMING
 
@@ -322,9 +364,6 @@
 
 ;; LISTS
 
-; List creation
-(define (list . args) args)
-
 ; Return number of items in list
 (define (length l)
   (define (iter a count)
@@ -333,20 +372,6 @@
       (iter (cdr a) (fix:+ count 1))))
   (iter l 0))
 
-; Join two lists together
-(define (join l1 l2)
-  (if (null? l1)
-    l2
-    (cons (car l1) (join (cdr l1) l2))))
-
-; Append an arbitrary number of lists together
-(define (append . lists)
-  (if (null? lists)
-    ()
-    (if (null? (cdr lists))
-      (car lists)
-      (join (car lists) (apply append (cdr lists))))))
-
 ; Reverse the contents of a list
 (define (reverse l)
   (if (null? l)
@@ -382,7 +407,6 @@
     (fix:+ n (sum-recurse (fix:- n 1)))))
 
 
-
 ;; MISC
 
 (define (license)

diff --git a/src/scheme.4th b/src/scheme.4th
index 72d2c9d..abd214e 100644 (file)
--- a/src/scheme.4th
+++ b/src/scheme.4th
@@ -1987,8 +1987,7 @@ variable gc-stack-depth
 
     include scheme-primitives.4th
 
-    s" testing-library.scm" load 2drop
-    \ s" scheme-library.scm" load 2drop
+    s" scheme-library.scm" load 2drop
     
 \ }}}
 
@@ -2021,7 +2020,7 @@ variable gc-stack-depth
     enable-gc
 
     \ Display welcome message
-    \ welcome-symbol nil cons global-env obj@ eval 2drop
+    welcome-symbol nil cons global-env obj@ eval 2drop
 
     begin
         ['] repl-body catch

diff --git a/src/testing-library.scm b/src/testing-library.scm
deleted file mode 100644 (file)
index fa4fb08..0000000
--- a/src/testing-library.scm
+++ /dev/null
@@ -1,50 +0,0 @@
-(define list (lambda args args))
-
-(define join-lists
-  (lambda (l1 l2)
-    (if (null? l1)
-      l2
-      (cons (car l1) (join-lists (cdr l1) l2)))))
-
-(define-macro (cadr x) (list 'car (list 'cdr x)))
-
-(define-macro (define args . body)
-              (if (pair? args)
-                (list 'define (car args) (join-lists (list 'lambda (cdr args)) body))
-                'no-match))
-
-(define (map proc l)
-  (if (null? l)
-    '()
-    (cons (proc (car l)) (map proc (cdr l)))))
-
-
-(define-macro (not x)
-              (list 'if x #f #t))
-
-(define-macro (let args . body)
-              (join-lists
-                (list (join-lists (list 'lambda (map (lambda (x) (car x)) args)) body))
-                (map (lambda (x) (cadr x)) args)))
-
-((lambda ()
-   (define (qqhelper l)
-     (if (null? l)
-       l
-       (let ((head (car l))
-             (tail (cdr l)))
-
-         (if (pair? head)
-             (if (eq? (car head) 'unquote)
-                 (list 'cons (cadr head) (qqhelper tail))
-                 (if (eq? (car head) 'unquote-splicing)
-                     (list 'join-lists (cadr head) (qqhelper tail))
-                     (list 'cons (list 'quasiquote head) (qqhelper tail))))
-             (if (symbol? head)
-                 (list 'cons (list 'quote head) (qqhelper tail))
-                 (list 'cons head (qqhelper tail)))))))
-
-   (define-macro (quasiquote arg)
-                 (if (not (pair? arg))
-                   (list 'quote arg)
-                   (qqhelper arg)))))