altos/lisp: Add quasiquote

This adds read support for quasiquote syntax, and then adds a
quasiquote implementation in lisp

Signed-off-by: Keith Packard <keithp@keithp.com>

diff --git a/src/lisp/ao_lisp_builtin.txt b/src/lisp/ao_lisp_builtin.txt
index 236cadb49c965c448372c2369dade72e7496d583..6925ac17b8d31bfaa3810bd6585a7e0b5ab7144f 100644 (file)
--- a/src/lisp/ao_lisp_builtin.txt
+++ b/src/lisp/ao_lisp_builtin.txt
@@ -10,6 +10,9 @@ f_lambda      cons
 f_lambda       last
 f_lambda       length
 nlambda                quote
 f_lambda       last
 f_lambda       length
 nlambda                quote

+atom           quasiquote
+atom           unquote
+atom           unquote_splicing        unquote-splicing

 f_lambda       set
 macro          setq            set!
 nlambda                cond
 f_lambda       set
 macro          setq            set!
 nlambda                cond

diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp
index f8a709799ff5b05b580246bc176910b4345545d2..f1c2ed00d567bb1bc6c6bbdf79a41c3c7af55b45 100644 (file)
--- a/src/lisp/ao_lisp_const.lisp
+++ b/src/lisp/ao_lisp_const.lisp
@@ -14,107 +14,320 @@
 ; Lisp code placed in ROM
 
                                        ; return a list containing all of the arguments
 ; Lisp code placed in ROM
 
                                        ; return a list containing all of the arguments

-

 (set (quote list) (lexpr (l) l))
 
 (set (quote list) (lexpr (l) l))
 

-                                       ;
-                                       ; Define a variable without returning the value
-                                       ; Useful when defining functions to avoid
-                                       ; having lots of output generated
-                                       ;
+(set (quote set!)
+     (macro (name value rest)
+           (list
+            set
+            (list
+             quote
+             name)
+            value)
+           )
+     )

 
 

-(set (quote define) (macro (name val rest)
-                       (list
-                        'begin
-                        (list
-                         'set
-                         (list 'quote name)
-                         val)
-                        (list 'quote name)
-                        )
-                       )
+(set! append
+     (lexpr (args)
+           ((lambda (append-list append-lists)
+              (set! append-list
+                   (lambda (a b)
+                     (cond ((null? a) b)
+                           (else (cons (car a) (append-list (cdr a) b)))
+                           )
+                     )
+                   )
+              (set! append-lists
+                   (lambda (lists)
+                     (cond ((null? lists) lists)
+                           ((null? (cdr lists)) (car lists))
+                           (else (append-list (car lists) (append-lists (cdr lists))))
+                           )
+                     )
+                   )
+              (append-lists args)
+              ) () ())
+           )
+     )
+
+(append '(a b c) '(d e f) '(g h i))
+
+                                       ; boolean operators
+
+(set! or
+     (macro (l)
+           ((lambda (_or)
+              (set! _or
+                   (lambda (l)
+                     (cond ((null? l) #f)
+                           ((null? (cdr l))
+                            (car l))
+                           (else
+                            (list
+                             cond
+                             (list
+                              (car l))
+                             (list
+                              'else
+                              (_or (cdr l))
+                              )
+                             )
+                            )
+                           )
+                     )
+                   )
+              (_or l)) ())))
+
+                                       ; execute to resolve macros
+
+(or #f #t)
+
+
+(set! and
+     (macro (l)
+           ((lambda (_and)
+              (set! _and
+                   (lambda (l)
+                     (cond ((null? l) #t)
+                           ((null? (cdr l))
+                            (car l))
+                           (else
+                            (list
+                             cond
+                             (list
+                              (car l)
+                              (_and (cdr l))
+                              )
+                             )
+                            )
+                           )
+                     )
+                   )
+              (_and l)) ())
+           )

      )
 
      )
 

+
+                                       ; execute to resolve macros
+
+(and #t #f)
+
+(set! quasiquote
+  (macro (x rest)
+        ((lambda (constant? combine-skeletons expand-quasiquote)
+           (set! constant?
+                                       ; A constant value is either a pair starting with quote,
+                                       ; or anything which is neither a pair nor a symbol
+
+                (lambda (exp)
+                  (cond ((pair? exp)
+                         (eq? (car exp) 'quote)
+                         )
+                        (else
+                         (not (symbol? exp))
+                         )
+                        )
+                  )
+                )
+           (set! combine-skeletons
+                (lambda (left right exp)
+                  (cond
+                   ((and (constant? left) (constant? right)) 
+                    (cond ((and (eqv? (eval left) (car exp))
+                                (eqv? (eval right) (cdr exp)))
+                           (list 'quote exp)
+                           )
+                          (else
+                           (list 'quote (cons (eval left) (eval right)))
+                           )
+                          )
+                    )
+                   ((null? right)
+                    (list 'list left)
+                    )
+                   ((and (pair? right) (eq? (car right) 'list))
+                    (cons 'list (cons left (cdr right)))
+                    )
+                   (else
+                    (list 'cons left right)
+                    )
+                   )
+                  )
+                )
+
+           (set! expand-quasiquote
+                (lambda (exp nesting)
+                  (cond
+
+                                       ; non cons -- constants
+                                       ; themselves, others are
+                                       ; quoted
+
+                   ((not (pair? exp)) 
+                    (cond ((constant? exp)
+                           exp
+                           )
+                          (else
+                           (list 'quote exp)
+                           )
+                          )
+                    )
+
+                                       ; check for an unquote exp and
+                                       ; add the param unquoted
+
+                   ((and (eq? (car exp) 'unquote) (= (length exp) 2))
+                    (cond ((= nesting 0)
+                           (car (cdr exp))
+                           )
+                          (else
+                           (combine-skeletons ''unquote 
+                                              (expand-quasiquote (cdr exp) (- nesting 1))
+                                              exp))
+                          )
+                    )
+
+                                       ; nested quasi-quote --
+                                       ; construct the right
+                                       ; expression
+
+                   ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
+                    (combine-skeletons ''quasiquote 
+                                       (expand-quasiquote (cdr exp) (+ nesting 1))
+                                       exp))
+
+                                       ; check for an
+                                       ; unquote-splicing member,
+                                       ; compute the expansion of the
+                                       ; value and append the rest of
+                                       ; the quasiquote result to it
+
+                   ((and (pair? (car exp))
+                         (eq? (car (car exp)) 'unquote-splicing)
+                         (= (length (car exp)) 2))
+                    (cond ((= nesting 0)
+                           (list 'append (car (cdr (car exp)))
+                                 (expand-quasiquote (cdr exp) nesting))
+                           )
+                          (else
+                           (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
+                                              (expand-quasiquote (cdr exp) nesting)
+                                              exp))
+                          )
+                    )
+
+                                       ; for other lists, just glue
+                                       ; the expansion of the first
+                                       ; element to the expansion of
+                                       ; the rest of the list
+
+                   (else (combine-skeletons (expand-quasiquote (car exp) nesting)
+                                            (expand-quasiquote (cdr exp) nesting)
+                                            exp)
+                         )
+                   )
+                  )
+                )
+           (expand-quasiquote x 0)
+           ) () () ())
+        )
+  )

                                        ;
                                        ;

-                                       ; A slightly more convenient form
-                                       ; for defining lambdas.
+                                       ; Define a variable without returning the value
+                                       ; Useful when defining functions to avoid
+                                       ; having lots of output generated.

                                        ;
                                        ;

-                                       ; (defun <name> (<params>) s-exprs)
+                                       ; Also accepts the alternate
+                                       ; form for defining lambdas of
+                                       ; (define (name x y z) sexprs ...) 

                                        ;
 
                                        ;
 

-(define defun (macro (name args exprs)
-                 (list
-                  define
-                  name
-                  (cons 'lambda (cons args exprs))
+(set! define
+      (macro (first rest)
+
+                                       ; check for alternate lambda definition form
+
+            (cond ((list? first)
+                   (set! rest
+                         (append
+                          (list
+                           'lambda
+                           (cdr first))
+                          rest))
+                   (set! first (car first))
+                   )
+                  (else
+                   (set! rest (car rest))
+                   )

                   )
                   )

-                 )
-     )
+            `(begin
+              (set! ,first ,rest)
+              (quote ,first))
+            )
+      )

 
                                        ; basic list accessors
 
 
 
                                        ; basic list accessors
 
 

-(defun caar (l) (car (car l)))
+(define (caar l) (car (car l)))

 
 

-(defun cadr (l) (car (cdr l)))
+(define (cadr l) (car (cdr l)))

 
 

-(defun caddr (l) (car (cdr (cdr l))))
+(define (cdar l) (cdr (car l)))

 
 

-(define list-tail (lambda (x k)
-                   (if (zero? k)
-                       x
-                     (list-tail (cdr x (- k 1)))
-                     )
-                   )
-  )
+(define (caddr l) (car (cdr (cdr l))))

 
 

-(define list-ref (lambda (x k)
-                  (car (list-tail x k))
-                  )
+(define (list-tail x k)
+  (if (zero? k)
+      x
+    (list-tail (cdr x (- k 1)))
+    )

   )
 
   )
 

-                                       ; simple math operators
+(define (list-ref x k)
+  (car (list-tail x k))
+  )

 
 

-(defun 1+ (x) (+ x 1))
-(defun 1- (x) (- x 1))
+                                       ; (if <condition> <if-true>)
+                                       ; (if <condition> <if-true> <if-false)

 
 

-(define zero? (macro (value rest)
-                    (list
-                     eq?
-                     value
-                     0)
-                    )
+(define if
+  (macro (test args)
+        (cond ((null? (cdr args))
+               `(cond (,test ,(car args)))
+               )
+              (else
+               `(cond (,test ,(car args))
+                      (else ,(cadr args)))
+               )
+              )
+        )

   )
 
   )
 

+(if (> 3 2) 'yes)
+(if (> 3 2) 'yes 'no)
+(if (> 2 3) 'no 'yes)
+(if (> 2 3) 'no)
+
+                                       ; simple math operators
+
+(define zero? (macro (value rest) `(eq? ,value 0)))
+

 (zero? 1)
 (zero? 0)
 (zero? "hello")
 
 (zero? 1)
 (zero? 0)
 (zero? "hello")
 

-(define positive? (macro (value rest)
-                        (list
-                         >
-                         value
-                         0)
-                        )
-  )
+(define positive? (macro (value rest) `(> ,value 0)))

 
 (positive? 12)
 (positive? -12)
 
 
 (positive? 12)
 (positive? -12)
 

-(define negative? (macro (value rest)
-                        (list
-                         <
-                         value
-                         0)
-                        )
-  )
+(define negative? (macro (value rest) `(< ,value 0)))

 
 (negative? 12)
 (negative? -12)
 
 
 (negative? 12)
 (negative? -12)
 

-(defun abs (x) (cond ((>= x 0) x)
-                    (else (- x)))
-       )
+(define (abs x) (if (>= x 0) x (- x)))

 
 (abs 12)
 (abs -12)
 
 (abs 12)
 (abs -12)


@@ -145,44 +358,20 @@
 (min 1 2 3)
 (min 3 2 1)
 
 (min 1 2 3)
 (min 3 2 1)
 

-(defun even? (x) (zero? (% x 2)))
+(define (even? x) (zero? (% x 2)))

 
 (even? 2)
 (even? -2)
 (even? 3)
 (even? -1)
 
 
 (even? 2)
 (even? -2)
 (even? 3)
 (even? -1)
 

-(defun odd? (x) (not (even? x)))
+(define (odd? x) (not (even? x)))

 
 (odd? 2)
 (odd? -2)
 (odd? 3)
 (odd? -1)
 
 
 (odd? 2)
 (odd? -2)
 (odd? 3)
 (odd? -1)
 

-                                       ; (if <condition> <if-true>)
-                                       ; (if <condition> <if-true> <if-false)
-
-(define if (macro (test args)
-              (cond ((null? (cdr args))
-                     (list
-                      cond
-                      (list test (car args)))
-                     )
-                    (else
-                     (list
-                      cond
-                      (list test (car args))
-                      (list 'else (cadr args))
-                      )
-                     )
-                    )
-              )
-     )
-
-(if (> 3 2) 'yes)
-(if (> 3 2) 'yes 'no)
-(if (> 2 3) 'no 'yes)
-(if (> 2 3) 'no)

 
                                        ; define a set of local
                                        ; variables and then evaluate
 
                                        ; define a set of local
                                        ; variables and then evaluate


@@ -213,6 +402,7 @@
                                      (cond ((not (null? vars))
                                             (cons (car (car vars))
                                                   (make-names (cdr vars))))
                                      (cond ((not (null? vars))
                                             (cons (car (car vars))
                                                   (make-names (cdr vars))))

+                                           (else ())

                                            )
                                      )
                         )
                                            )
                                      )
                         )


@@ -235,7 +425,7 @@
                                              (make-exprs (cdr vars) exprs)
                                              )
                                             )
                                              (make-exprs (cdr vars) exprs)
                                              )
                                             )

-                                           (exprs)
+                                           (else exprs)

                                            )
                                      )
                         )
                                            )
                                      )
                         )


@@ -245,6 +435,7 @@
 
                   (set! make-nils (lambda (vars)
                                     (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))
 
                   (set! make-nils (lambda (vars)
                                     (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))

+                                          (else ())

                                           )
                                     )
                         )
                                           )
                                     )
                         )


@@ -269,65 +460,22 @@
 (let ((x 1)) x)
 
 (define let* let)
 (let ((x 1)) x)
 
 (define let* let)

-                                       ; boolean operators

 
 

-(define or (lexpr (l)
-              (let ((ret #f))
-                (while (not (null? l))
-                  (cond ((car l) (set! ret #t) (set! l ()))
-                        ((set! l (cdr l)))))
-                ret
-                )
-              )
-     )
+(define when (macro (test l)
+                   (list
+                    cond
+                    (cons test l))))

 
 

-                                       ; execute to resolve macros
-
-(or #f #t)
+(when #t (display 'when))

 
 

-(define and (lexpr (l)
-              (let ((ret #t))
-                (while (not (null? l))
-                  (cond ((car l)
-                         (set! l (cdr l)))
-                        (#t
-                         (set! ret #f)
-                         (set! l ()))
-                        )
-                  )
-                ret
-                )
-              )
-     )
-
-                                       ; execute to resolve macros
-
-(and #t #f)
-
-
-(define append (lexpr (args)
-                     (let ((append-list (lambda (a b)
-                                          (cond ((null? a) b)
-                                                (else (cons (car a) (append-list (cdr a) b)))
-                                                )
-                                          )
-                                        )
-                           (append-lists (lambda (lists)
-                                           (cond ((null? lists) lists)
-                                                 ((null? (cdr lists)) (car lists))
-                                                 (else (append-list (car lists) (append-lists (cdr lists))))
-                                                 )
-                                           )
-                                         )
-                           )
-                       (append-lists args)
-                       )
-                     )
-  )
+(define unless (macro (test l)
+                     (list
+                      cond
+                      (cons (list not test) l))))

 
 

-(append '(a b c) '(d e f) '(g h i))
+(unless #f (display 'unless))

 
 

-(defun reverse (list)
+(define (reverse list)

   (let ((result ()))
     (while (not (null? list))
       (set! result (cons (car list) result))
   (let ((result ()))
     (while (not (null? list))
       (set! result (cons (car list) result))


@@ -338,22 +486,20 @@
 
 (reverse '(1 2 3))
 
 
 (reverse '(1 2 3))
 

-(define list-tail
-  (lambda (x k)
-    (if (zero? k)
-       x
-      (list-tail (cdr x) (- k 1)))))
+(define (list-tail x k)
+  (if (zero? k)
+      x
+    (list-tail (cdr x) (- k 1)))))

 
 (list-tail '(1 2 3) 2)
 
 
 (list-tail '(1 2 3) 2)
 

-(defun list-ref (x k) (car (list-tail x k)))
+(define (list-ref x k) (car (list-tail x k)))

 
 (list-ref '(1 2 3) 2)
 
 (list-ref '(1 2 3) 2)

-

     
                                        ; recursive equality
 
     
                                        ; recursive equality
 

-(defun equal? (a b)
+(define (equal? a b)

   (cond ((eq? a b) #t)
        ((and (pair? a) (pair? b))
         (and (equal? (car a) (car b))
   (cond ((eq? a b) #t)
        ((and (pair? a) (pair? b))
         (and (equal? (car a) (car b))


@@ -366,32 +512,32 @@
 (equal? '(a b c) '(a b c))
 (equal? '(a b c) '(a b b))
 
 (equal? '(a b c) '(a b c))
 (equal? '(a b c) '(a b b))
 

-(defun _member (obj list test?)
+(define (_member obj list test?)

   (if (null? list)
       #f
     (if (test? obj (car list))
        list
       (memq obj (cdr list)))))
 
   (if (null? list)
       #f
     (if (test? obj (car list))
        list
       (memq obj (cdr list)))))
 

-(defun memq (obj list) (_member obj list eq?))
+(define (memq obj list) (_member obj list eq?))

 
 (memq 2 '(1 2 3))
 
 (memq 4 '(1 2 3))
 
 
 (memq 2 '(1 2 3))
 
 (memq 4 '(1 2 3))
 

-(defun memv (obj list) (_member obj list eqv?))
+(define (memv obj list) (_member obj list eqv?))

 
 (memv 2 '(1 2 3))
 
 (memv 4 '(1 2 3))
 
 
 (memv 2 '(1 2 3))
 
 (memv 4 '(1 2 3))
 

-(defun member (obj list) (_member obj list equal?))
+(define (member obj list) (_member obj list equal?))

 
 (member '(2) '((1) (2) (3)))
 
 (member '(4) '((1) (2) (3)))
 
 
 (member '(2) '((1) (2) (3)))
 
 (member '(4) '((1) (2) (3)))
 

-(defun _assoc (obj list test?)
+(define (_assoc obj list test?)

   (if (null? list)
       #f
     (if (test? obj (caar list))
   (if (null? list)
       #f
     (if (test? obj (caar list))


@@ -401,9 +547,9 @@
     )
   )
 
     )
   )
 

-(defun assq (obj list) (_assoc obj list eq?))
-(defun assv (obj list) (_assoc obj list eqv?))
-(defun assoc (obj list) (_assoc obj list equal?))
+(define (assq obj list) (_assoc obj list eq?))
+(define (assv obj list) (_assoc obj list eqv?))
+(define (assoc obj list) (_assoc obj list equal?))

 
 (assq 'a '((a 1) (b 2) (c 3)))
 (assv 'b '((a 1) (b 2) (c 3)))
 
 (assq 'a '((a 1) (b 2) (c 3)))
 (assv 'b '((a 1) (b 2) (c 3)))


@@ -414,52 +560,52 @@
 (char? #\q)
 (char? "h")
 
 (char? #\q)
 (char? "h")
 

-(defun char-upper-case? (c) (<= #\A c #\Z))
+(define (char-upper-case? c) (<= #\A c #\Z))

 
 (char-upper-case? #\a)
 (char-upper-case? #\B)
 (char-upper-case? #\0)
 (char-upper-case? #\space)
 
 
 (char-upper-case? #\a)
 (char-upper-case? #\B)
 (char-upper-case? #\0)
 (char-upper-case? #\space)
 

-(defun char-lower-case? (c) (<= #\a c #\a))
+(define (char-lower-case? c) (<= #\a c #\a))

 
 (char-lower-case? #\a)
 (char-lower-case? #\B)
 (char-lower-case? #\0)
 (char-lower-case? #\space)
 
 
 (char-lower-case? #\a)
 (char-lower-case? #\B)
 (char-lower-case? #\0)
 (char-lower-case? #\space)
 

-(defun char-alphabetic? (c) (or (char-upper-case? c) (char-lower-case? c)))
+(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))

 
 (char-alphabetic? #\a)
 (char-alphabetic? #\B)
 (char-alphabetic? #\0)
 (char-alphabetic? #\space)
 
 
 (char-alphabetic? #\a)
 (char-alphabetic? #\B)
 (char-alphabetic? #\0)
 (char-alphabetic? #\space)
 

-(defun char-numeric? (c) (<= #\0 c #\9))
+(define (char-numeric? c) (<= #\0 c #\9))

 
 (char-numeric? #\a)
 (char-numeric? #\B)
 (char-numeric? #\0)
 (char-numeric? #\space)
 
 
 (char-numeric? #\a)
 (char-numeric? #\B)
 (char-numeric? #\0)
 (char-numeric? #\space)
 

-(defun char-whitespace? (c) (or (<= #\tab c #\return) (= #\space c)))
+(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))

 
 (char-whitespace? #\a)
 (char-whitespace? #\B)
 (char-whitespace? #\0)
 (char-whitespace? #\space)
 
 
 (char-whitespace? #\a)
 (char-whitespace? #\B)
 (char-whitespace? #\0)
 (char-whitespace? #\space)
 

-(defun char->integer (c) c)
-(defun integer->char (c) char-integer)
+(define (char->integer c) c)
+(define (integer->char c) char-integer)

 
 

-(defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
+(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))

 
 (char-upcase #\a)
 (char-upcase #\B)
 (char-upcase #\0)
 (char-upcase #\space)
 
 
 (char-upcase #\a)
 (char-upcase #\B)
 (char-upcase #\0)
 (char-upcase #\space)
 

-(defun char-downcase (c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
+(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))

 
 (char-downcase #\a)
 (char-downcase #\B)
 
 (char-downcase #\a)
 (char-downcase #\B)


@@ -493,17 +639,17 @@
 
 (for-each display '("hello" " " "world" "\n"))
 
 
 (for-each display '("hello" " " "world" "\n"))
 

-(define -string-ml (lambda (strings)
+(define _string-ml (lambda (strings)

                             (if (null? strings) ()
                             (if (null? strings) ()

-                              (cons (string->list (car strings)) (-string-ml (cdr strings))))))
+                              (cons (string->list (car strings)) (_string-ml (cdr strings))))))

 
 (define string-map (lexpr (proc strings)
 
 (define string-map (lexpr (proc strings)

-                         (list->string (apply map proc (-string-ml strings))))))
+                         (list->string (apply map proc (_string-ml strings))))))

 
 

-(string-map 1+ "HAL")
+(string-map (lambda (x) (+ 1 x)) "HAL")

 
 (define string-for-each (lexpr (proc strings)
 
 (define string-for-each (lexpr (proc strings)

-                              (apply for-each proc (-string-ml strings))))
+                              (apply for-each proc (_string-ml strings))))

 
 (string-for-each write-char "IBM\n")
 
 
 (string-for-each write-char "IBM\n")
 


@@ -520,25 +666,64 @@
             '(54 0 37 -3 245 19))
    #t))
 
             '(54 0 37 -3 245 19))
    #t))
 

+
+                                       ; `q -> (quote q)
+                                       ; `(q) -> (append (quote (q)))
+                                       ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
+                                       ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
+
+
+
+`(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
+

 (define repeat (macro (count rest)
 (define repeat (macro (count rest)

-                       (list
-                        let
-                        (list
-                         (list '__count__ count))
-                        (append
-                         (list
-                          while
-                          (list
-                           <=
-                           0
-                           (list
-                            set!
-                            '__count__
-                            (list
-                             -
-                             '__count__
-                             1))))
-                         rest))))
+                      `(let ((__count__ ,count))
+                         (while (<= 0 (set! __count__ (- __count__ 1))) ,@rest))))
+
+(repeat 2 (write 'hello))
+(repeat 3 (write 'goodbye))
+
+(define case (macro (test l)
+                   (let ((_unarrow
+                                       ; construct the body of the
+                                       ; case, dealing with the
+                                       ; lambda version ( => lambda)
+                          
+                          (lambda (l)
+                            (cond ((null? l) l)
+                                  ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
+                                  (else l))))
+                         (_case (lambda (l)
+
+                                       ; Build the case elements, which is
+                                       ; simply a list of cond clauses
+
+                                  (cond ((null? l) ())
+
+                                       ; else case
+
+                                        ((eq? (caar l) 'else)
+                                         `((else ,@(_unarrow (cdr (car l))))))
+
+                                       ; regular case
+                                         
+                                        (else
+                                         (cons
+                                          `((eqv? ,(caar l) __key__)
+                                            ,@(_unarrow (cdr (car l))))
+                                          (_case (cdr l)))
+                                         )
+                                        ))))
+
+                                       ; now construct the overall
+                                       ; expression, using a lambda
+                                       ; to hold the computed value
+                                       ; of the test expression
+
+                     `((lambda (__key__)
+                         (cond ,@(_case l))) ,test))))
+
+(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))

 
 ;(define number->string (lexpr (arg opt)
 ;                            (let ((base (if (null? opt) 10 (car opt)))
 
 ;(define number->string (lexpr (arg opt)
 ;                            (let ((base (if (null? opt) 10 (car opt)))

diff --git a/src/lisp/ao_lisp_make_builtin b/src/lisp/ao_lisp_make_builtin
index 531e388d8627d165826d8f4cae08ed2c6aca4f88..c4ba9d9426bf5c72b9274029d7ee7dfcdd8a5205 100644 (file)
--- a/src/lisp/ao_lisp_make_builtin
+++ b/src/lisp/ao_lisp_make_builtin
@@ -13,6 +13,7 @@ string[string] type_map = {
        "macro" => "MACRO",
        "f_lambda" => "F_LAMBDA",
        "f_lexpr" => "F_LEXPR",
        "macro" => "MACRO",
        "f_lambda" => "F_LAMBDA",
        "f_lexpr" => "F_LEXPR",

+       "atom" => "atom",

 };
 
 string[*]
 };
 
 string[*]


@@ -50,13 +51,16 @@ read_builtins(file f) {
        return builtins;
 }
 
        return builtins;
 }
 

+bool is_atom(builtin_t b) = b.type == "atom";
+

 void
 dump_ids(builtin_t[*] builtins) {
        printf("#ifdef AO_LISP_BUILTIN_ID\n");
        printf("#undef AO_LISP_BUILTIN_ID\n");
        printf("enum ao_lisp_builtin_id {\n");
        for (int i = 0; i < dim(builtins); i++)
 void
 dump_ids(builtin_t[*] builtins) {
        printf("#ifdef AO_LISP_BUILTIN_ID\n");
        printf("#undef AO_LISP_BUILTIN_ID\n");
        printf("enum ao_lisp_builtin_id {\n");
        for (int i = 0; i < dim(builtins); i++)

-               printf("\tbuiltin_%s,\n", builtins[i].c_name);
+               if (!is_atom(builtins[i]))
+                       printf("\tbuiltin_%s,\n", builtins[i].c_name);

        printf("\t_builtin_last\n");
        printf("};\n");
        printf("#endif /* AO_LISP_BUILTIN_ID */\n");
        printf("\t_builtin_last\n");
        printf("};\n");
        printf("#endif /* AO_LISP_BUILTIN_ID */\n");


@@ -69,8 +73,9 @@ dump_casename(builtin_t[*] builtins) {
        printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n");
        printf("\tswitch(b) {\n");
        for (int i = 0; i < dim(builtins); i++)
        printf("static char *ao_lisp_builtin_name(enum ao_lisp_builtin_id b) {\n");
        printf("\tswitch(b) {\n");
        for (int i = 0; i < dim(builtins); i++)

-               printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n",
-                      builtins[i].c_name, builtins[i].lisp_names[0]);
+               if (!is_atom(builtins[i]))
+                       printf("\tcase builtin_%s: return ao_lisp_poly_atom(_atom(\"%s\"))->name;\n",
+                              builtins[i].c_name, builtins[i].lisp_names[0]);

        printf("\tdefault: return \"???\";\n");
        printf("\t}\n");
        printf("}\n");
        printf("\tdefault: return \"???\";\n");
        printf("\t}\n");
        printf("}\n");


@@ -94,10 +99,12 @@ dump_arrayname(builtin_t[*] builtins) {
        printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n");
        printf("static const ao_poly builtin_names[] = {\n");
        for (int i = 0; i < dim(builtins); i++) {
        printf("#undef AO_LISP_BUILTIN_ARRAYNAME\n");
        printf("static const ao_poly builtin_names[] = {\n");
        for (int i = 0; i < dim(builtins); i++) {

-               printf("\t[builtin_%s] = _ao_lisp_atom_",
-                      builtins[i].c_name);
-               cify_lisp(builtins[i].lisp_names[0]);
-               printf(",\n");
+               if (!is_atom(builtins[i])) {
+                       printf("\t[builtin_%s] = _ao_lisp_atom_",
+                              builtins[i].c_name);
+                       cify_lisp(builtins[i].lisp_names[0]);
+                       printf(",\n");
+               }

        }
        printf("};\n");
        printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n");
        }
        printf("};\n");
        printf("#endif /* AO_LISP_BUILTIN_ARRAYNAME */\n");


@@ -109,9 +116,10 @@ dump_funcs(builtin_t[*] builtins) {
        printf("#undef AO_LISP_BUILTIN_FUNCS\n");
        printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n");
        for (int i = 0; i < dim(builtins); i++) {
        printf("#undef AO_LISP_BUILTIN_FUNCS\n");
        printf("const ao_lisp_func_t ao_lisp_builtins[] = {\n");
        for (int i = 0; i < dim(builtins); i++) {

-               printf("\t[builtin_%s] = ao_lisp_do_%s,\n",
-                      builtins[i].c_name,
-                      builtins[i].c_name);
+               if (!is_atom(builtins[i]))
+                       printf("\t[builtin_%s] = ao_lisp_do_%s,\n",
+                              builtins[i].c_name,
+                              builtins[i].c_name);

        }
        printf("};\n");
        printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n");
        }
        printf("};\n");
        printf("#endif /* AO_LISP_BUILTIN_FUNCS */\n");


@@ -122,9 +130,11 @@ dump_decls(builtin_t[*] builtins) {
        printf("#ifdef AO_LISP_BUILTIN_DECLS\n");
        printf("#undef AO_LISP_BUILTIN_DECLS\n");
        for (int i = 0; i < dim(builtins); i++) {
        printf("#ifdef AO_LISP_BUILTIN_DECLS\n");
        printf("#undef AO_LISP_BUILTIN_DECLS\n");
        for (int i = 0; i < dim(builtins); i++) {

-               printf("ao_poly\n");
-               printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n",
-                      builtins[i].c_name);
+               if (!is_atom(builtins[i])) {
+                       printf("ao_poly\n");
+                       printf("ao_lisp_do_%s(struct ao_lisp_cons *cons);\n",
+                              builtins[i].c_name);
+               }

        }
        printf("#endif /* AO_LISP_BUILTIN_DECLS */\n");
 }
        }
        printf("#endif /* AO_LISP_BUILTIN_DECLS */\n");
 }


@@ -135,11 +145,13 @@ dump_consts(builtin_t[*] builtins) {
        printf("#undef AO_LISP_BUILTIN_CONSTS\n");
        printf("struct builtin_func funcs[] = {\n");
        for (int i = 0; i < dim(builtins); i++) {
        printf("#undef AO_LISP_BUILTIN_CONSTS\n");
        printf("struct builtin_func funcs[] = {\n");
        for (int i = 0; i < dim(builtins); i++) {

-               for (int j = 0; j < dim(builtins[i].lisp_names); j++) {
-                       printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n",
-                               builtins[i].lisp_names[j],
-                               builtins[i].type,
-                               builtins[i].c_name);
+               if (!is_atom(builtins[i])) {
+                       for (int j = 0; j < dim(builtins[i].lisp_names); j++) {
+                               printf ("\t{ .name = \"%s\", .args = AO_LISP_FUNC_%s, .func = builtin_%s },\n",
+                                       builtins[i].lisp_names[j],
+                                       builtins[i].type,
+                                       builtins[i].c_name);
+                       }

                }
        }
        printf("};\n");
                }
        }
        printf("};\n");

diff --git a/src/lisp/ao_lisp_read.c b/src/lisp/ao_lisp_read.c
index c5a238cc5513132bbbda6107173995d3335e3dfa..747963ab632b3cdba14d67930c8419b875c8c570 100644 (file)
--- a/src/lisp/ao_lisp_read.c
+++ b/src/lisp/ao_lisp_read.c
@@ -61,7 +61,7 @@ static const uint16_t lex_classes[128] = {
        PRINTABLE|SPECIAL,      /* ) */
        PRINTABLE,              /* * */
        PRINTABLE|SIGN,         /* + */
        PRINTABLE|SPECIAL,      /* ) */
        PRINTABLE,              /* * */
        PRINTABLE|SIGN,         /* + */

-       PRINTABLE,              /* , */
+       PRINTABLE|SPECIAL,      /* , */

        PRINTABLE|SIGN,         /* - */
        PRINTABLE|DOTC|FLOATC,  /* . */
        PRINTABLE,              /* / */
        PRINTABLE|SIGN,         /* - */
        PRINTABLE|DOTC|FLOATC,  /* . */
        PRINTABLE,              /* / */


@@ -113,7 +113,7 @@ static const uint16_t       lex_classes[128] = {
        PRINTABLE,              /*  ] */
        PRINTABLE,              /*  ^ */
        PRINTABLE,              /*  _ */
        PRINTABLE,              /*  ] */
        PRINTABLE,              /*  ^ */
        PRINTABLE,              /*  _ */

-       PRINTABLE,              /*  ` */
+       PRINTABLE|SPECIAL,      /*  ` */

        PRINTABLE,              /*  a */
        PRINTABLE,              /*  b */
        PRINTABLE,              /*  c */
        PRINTABLE,              /*  a */
        PRINTABLE,              /*  b */
        PRINTABLE,              /*  c */


@@ -314,6 +314,18 @@ _lex(void)
                                return QUOTE;
                        case '.':
                                return DOT;
                                return QUOTE;
                        case '.':
                                return DOT;

+                       case '`':
+                               return QUASIQUOTE;
+                       case ',':
+                               c = lexc();
+                               if (c == '@') {
+                                       add_token(c);
+                                       end_token();
+                                       return UNQUOTE_SPLICING;
+                               } else {
+                                       lex_unget(c);
+                                       return UNQUOTE;
+                               }

                        }
                }
                if (lex_class & POUND) {
                        }
                }
                if (lex_class & POUND) {


@@ -562,11 +574,27 @@ ao_lisp_read(void)
                                v = AO_LISP_NIL;
                        break;
                case QUOTE:
                                v = AO_LISP_NIL;
                        break;
                case QUOTE:

+               case QUASIQUOTE:
+               case UNQUOTE:
+               case UNQUOTE_SPLICING:

                        if (!push_read_stack(cons, read_state))
                                return AO_LISP_NIL;
                        cons++;
                        read_state = READ_IN_QUOTE;
                        if (!push_read_stack(cons, read_state))
                                return AO_LISP_NIL;
                        cons++;
                        read_state = READ_IN_QUOTE;

-                       v = _ao_lisp_atom_quote;
+                       switch (parse_token) {
+                       case QUOTE:
+                               v = _ao_lisp_atom_quote;
+                               break;
+                       case QUASIQUOTE:
+                               v = _ao_lisp_atom_quasiquote;
+                               break;
+                       case UNQUOTE:
+                               v = _ao_lisp_atom_unquote;
+                               break;
+                       case UNQUOTE_SPLICING:
+                               v = _ao_lisp_atom_unquote2dsplicing;
+                               break;
+                       }

                        break;
                case CLOSE:
                        if (!cons) {
                        break;
                case CLOSE:
                        if (!cons) {

diff --git a/src/lisp/ao_lisp_read.h b/src/lisp/ao_lisp_read.h
index 20c9c18a4a8abfd7fd56abfcc566bacf6e9042eb..8f6bf130a542100afaad4368433f62180dcd85b6 100644 (file)
--- a/src/lisp/ao_lisp_read.h
+++ b/src/lisp/ao_lisp_read.h
@@ -19,23 +19,26 @@
  * token classes
  */
 
  * token classes
  */
 

-# define END   0
-# define NAME  1
-# define OPEN          2
-# define CLOSE 3
-# define QUOTE 4
-# define STRING        5
-# define NUM   6
-# define FLOAT 7
-# define DOT   8
-# define BOOL  9
+# define END                   0
+# define NAME                  1
+# define OPEN                          2
+# define CLOSE                 3
+# define QUOTE                 4
+# define QUASIQUOTE            5
+# define UNQUOTE               6
+# define UNQUOTE_SPLICING      7
+# define STRING                        8
+# define NUM                   9
+# define FLOAT                 10
+# define DOT                   11
+# define BOOL                  12

 
 /*
  * character classes
  */
 
 
 /*
  * character classes
  */
 

-# define PRINTABLE     0x0001  /* \t \n ' ' - '~' */
-# define SPECIAL       0x0002  /* ( [ { ) ] } ' */
+# define PRINTABLE     0x0001  /* \t \n ' ' - ~ */
+# define SPECIAL       0x0002  /* ( [ { ) ] } ' ` , */

 # define DOTC          0x0004  /* . */
 # define WHITE         0x0008  /* ' ' \t \n */
 # define DIGIT         0x0010  /* [0-9] */
 # define DOTC          0x0004  /* . */
 # define WHITE         0x0008  /* ' ' \t \n */
 # define DIGIT         0x0010  /* [0-9] */