altos/lisp: More schemisms

[fw/altos] / src / lisp / ao_lisp_const.lisp

diff --git a/src/lisp/ao_lisp_const.lisp b/src/lisp/ao_lisp_const.lisp
index 13bb81391fd570e95a41544a1a4e921a65705c4d..37307a6877758938bb1f9258a701940770560c30 100644 (file)
--- a/src/lisp/ao_lisp_const.lisp
+++ b/src/lisp/ao_lisp_const.lisp
@@ -23,17 +23,17 @@
                                        ; having lots of output generated
                                        ;
 
-(setq def (macro (name val rest)
-                (list
-                 'progn
-                 (list
-                  'set
-                  (list 'quote name)
-                  val)
-                 (list 'quote name)
-                 )
-                )
-      )
+(set (quote define) (macro (name val rest)
+                       (list
+                        'progn
+                        (list
+                         'set
+                         (list 'quote name)
+                         val)
+                        (list 'quote name)
+                        )
+                       )
+     )
 
                                        ;
                                        ; A slightly more convenient form
@@ -42,24 +42,15 @@
                                        ; (defun <name> (<params>) s-exprs)
                                        ;
 
-(def defun (macro (name args exprs)
+(define defun (macro (name args exprs)
                  (list
-                  def
+                  define
                   name
-                  (list
-                   'lambda
-                   args
-                   (cond (exprs
-                          (cond ((cdr exprs)
-                                 (cons progn exprs))
-                                ((car exprs))
-                                )
-                          )
-                         )
-                   )
+                  (cons 'lambda (cons args exprs))
                   )
                  )
      )
+
                                        ; basic list accessors
 
 
@@ -78,6 +69,28 @@
 (defun 1+ (x) (+ x 1))
 (defun 1- (x) (- x 1))
 
+(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
                                        ; a list of sexprs
@@ -94,73 +107,62 @@
                                        ;
                                        ; e.g.
                                        ;
-                                       ; (let ((x 1) (y)) (setq y (+ x 1)) y)
+                                       ; (let ((x 1) (y)) (set! y (+ x 1)) y)
 
-(def let (macro (vars exprs)
+(define let (macro (vars exprs)
                ((lambda (make-names make-exprs make-nils)
-                  (progn
 
                                        ;
                                        ; make the list of names in the let
                                        ;
 
-                    (setq make-names (lambda (vars)
-                                      (cond (vars
-                                             (cons (car (car vars))
-                                                   (make-names (cdr vars))))
-                                            )
-                                      )
-                         )
+                  (set! make-names (lambda (vars)
+                                     (cond ((not (null? vars))
+                                            (cons (car (car vars))
+                                                  (make-names (cdr vars))))
+                                           )
+                                     )
+                        )
 
                                        ; the set of expressions is
                                        ; the list of set expressions
                                        ; pre-pended to the
                                        ; expressions to evaluate
 
-                    (setq make-exprs (lambda (vars exprs)
-                                      (progn
-                                        (cond (vars (cons
-                                                     (list set
-                                                           (list quote
-                                                                 (car (car vars))
-                                                                 )
-                                                           (cadr (car vars))
-                                                           )
-                                                     (make-exprs (cdr vars) exprs)
-                                                     )
-                                                    )
-                                              (exprs)
-                                              )
-                                        )
-                                      )
-                         )
+                  (set! make-exprs (lambda (vars exprs)
+                                     (cond ((not (null? vars)) (cons
+                                                  (list set
+                                                        (list quote
+                                                              (car (car vars))
+                                                              )
+                                                        (cadr (car vars))
+                                                        )
+                                                  (make-exprs (cdr vars) exprs)
+                                                  )
+                                                 )
+                                           (exprs)
+                                           )
+                                     )
+                        )
 
                                        ; the parameters to the lambda is a list
                                        ; of nils of the right length
 
-                    (setq make-nils (lambda (vars)
-                                     (cond (vars (cons nil (make-nils (cdr vars))))
-                                           )
-                                     )
-                         )
+                  (set! make-nils (lambda (vars)
+                                    (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))
+                                          )
+                                    )
+                        )
                                        ; prepend the set operations
                                        ; to the expressions
 
-                    (setq exprs (make-exprs vars exprs))
+                  (set! exprs (make-exprs vars exprs))
 
                                        ; build the lambda.
 
-                    (cons
-                     (list
-                      'lambda
-                      (make-names vars)
-                      (cond ((cdr exprs) (cons 'progn exprs))
-                            ((car exprs))
-                            )
-                      )
-                     (make-nils vars)
-                     )
-                    )
+                  (cons (cons 'lambda (cons (make-names vars) exprs))
+                        (make-nils vars)
+                        )
                   )
                 ()
                 ()
@@ -169,14 +171,15 @@
                )
      )
 
+(let ((x 1)) x)
+
                                        ; boolean operators
 
-(def or (lexpr (l)
-              (let ((ret nil))
-                (while l
-                  (cond ((setq ret (car l))
-                         (setq l nil))
-                        ((setq l (cdr l)))))
+(define or (lexpr (l)
+              (let ((ret #f))
+                (while (not (null? l))
+                  (cond ((car l) (set! ret #t) (set! l ()))
+                        ((set! l (cdr l)))))
                 ret
                 )
               )
@@ -184,14 +187,16 @@
 
                                        ; execute to resolve macros
 
-(or nil t)
+(or #f #t)
 
-(def and (lexpr (l)
-              (let ((ret t))
-                (while l
-                  (cond ((setq ret (car l))
-                         (setq l (cdr l)))
-                        ((setq ret (setq l nil)))
+(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
@@ -201,5 +206,17 @@
 
                                        ; execute to resolve macros
 
-(and t nil)
+(and #t #f)
+
+(defun equal? (a b)
+  (cond ((eq? a b) #t)
+       ((and (pair? a) (pair? b))
+        (and (equal? (car a) (car b))
+             (equal? (cdr a) (cdr b)))
+        )
+       (else #f)
+       )
+  )
 
+(equal? '(a b c) '(a b c))
+(equal? '(a b c) '(a b b))