altos/lambdakey-v1.0: Add back and/or macros

With scheme shrinking a bit, there's now space for these useful macros.

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

diff --git a/src/lambdakey-v1.0/ao_lambdakey_const.scheme b/src/lambdakey-v1.0/ao_lambdakey_const.scheme
index 503732723e7088880858e80a8a1956a1af98f423..a912b8ae96363c2817dddfa0d456c058d5a613c0 100644 (file)
--- a/src/lambdakey-v1.0/ao_lambdakey_const.scheme
+++ b/src/lambdakey-v1.0/ao_lambdakey_const.scheme
@@ -49,7 +49,7 @@
    )
  'append)
 
    )
  'append)
 

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

 
                                        ;
                                        ; Define a variable without returning the value
 
                                        ;
                                        ; Define a variable without returning the value


@@ -66,7 +66,7 @@
    (macro (a . b)
                                        ; check for alternate lambda definition form
 
    (macro (a . b)
                                        ; check for alternate lambda definition form
 

-         (cond ((list? a)
+         (cond ((pair? a)

                 (set! b
                       (cons lambda (cons (cdr a) b)))
                 (set! a (car a))
                 (set! b
                       (cons lambda (cons (cdr a) b)))
                 (set! a (car a))


@@ -92,26 +92,86 @@
  'define
  )
 
  'define
  )
 

+                                       ; boolean operators
+
+(begin
+ (def! or
+   (macro a
+         (def! _or
+           (lambda (a)
+             (cond ((null? a) #f)
+                   ((null? (cdr a))
+                    (car a))
+                   (else
+                    (list
+                     cond
+                     (list
+                      (car a))
+                     (list
+                      'else
+                      (_or (cdr a))
+                      )
+                     )
+                    )
+                   )
+             )
+           )
+         (_or a)))
+ 'or)
+
+                                       ; execute to resolve macros
+
+(or #f #t)
+
+(begin
+ (def! and
+   (macro a
+         (def! _and
+           (lambda (a)
+             (cond ((null? a) #t)
+                   ((null? (cdr a))
+                    (car a))
+                   (else
+                    (list
+                     cond
+                     (list
+                      (car a)
+                      (_and (cdr a))
+                      )
+                     )
+                    )
+                   )
+             )
+           )
+         (_and a)
+         )
+   )
+ 'and)
+
+                                       ; execute to resolve macros
+
+(and #t #f)
+

                                        ; basic list accessors
 
                                        ; basic list accessors
 

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

 
 

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

 
 

-(define (cdar l) (cdr (car l)))
+; (define (cdar a) (cdr (car a)))

 
                                        ; (if <condition> <if-true>)
                                        ; (if <condition> <if-true> <if-false)
 
 (define if
 
                                        ; (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)))
+  (macro (test . b)
+    (cond ((null? (cdr b))
+          (list cond (list test (car b)))

                )
          (else
           (list cond
                )
          (else
           (list cond

-                (list test (car args))
-                (list 'else (cadr args))
+                (list test (car b))
+                (list 'else (cadr b))

                 )
           )
          )
                 )
           )
          )


@@ -291,25 +351,24 @@
 (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))
 

-(define member (lambda (obj a . test?)
-                     (cond ((null? a)
-                            #f
-                            )
-                           (else
-                            (if (null? test?) (set! test? equal?) (set! test? (car test?)))
-                            (if (test? obj (car a))
-                                a
-                              (member obj (cdr a) test?))
-                            )
-                           )
-                     )
+(define (member a b . t?)
+  (cond ((null? b)
+        #f
+        )
+       (else
+        (if (null? t?) (set! t? equal?) (set! t? (car t?)))
+        (if (t? a (car b))
+            b
+            (member a (cdr b) t?))
+        )
+       )

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

-(define (memq obj a) (member obj a eq?))
+(define (memq a b) (member a b eq?))

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


@@ -317,18 +376,18 @@
 
 (memq '(2) '((1) (2) (3)))
 
 
 (memq '(2) '((1) (2) (3)))
 

-(define (_assoc a b t?)
+(define (_as a b t?)

   (if (null? b)
       #f
     (if (t? a (caar b))
        (car b)
   (if (null? b)
       #f
     (if (t? a (caar b))
        (car b)

-      (_assoc a (cdr b) t?)
+      (_as a (cdr b) t?)

       )
     )
   )
 
       )
     )
   )
 

-(define (assq a b) (_assoc a b eq?))
-(define (assoc a b) (_assoc a b equal?))
+(define (assq a b) (_as a b eq?))
+(define (assoc a b) (_as a b equal?))

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


@@ -337,28 +396,28 @@
 
 (define map
   (lambda (a . b)
 
 (define map
   (lambda (a . b)

-        (define (args b)
+        (define (_a b)

           (cond ((null? b) ())
                 (else
           (cond ((null? b) ())
                 (else

-                 (cons (caar b) (args (cdr b)))
+                 (cons (caar b) (_a (cdr b)))

                  )
                 )
           )
                  )
                 )
           )

-        (define (next b)
+        (define (_n b)

           (cond ((null? b) ())
                 (else
           (cond ((null? b) ())
                 (else

-                 (cons (cdr (car b)) (next (cdr b)))
+                 (cons (cdr (car b)) (_n (cdr b)))

                  )
                 )
           )
                  )
                 )
           )

-        (define (domap b)
+        (define (_d b)

           (cond ((null? (car b)) ())
                 (else
           (cond ((null? (car b)) ())
                 (else

-                 (cons (apply a (args b)) (domap (next b)))
+                 (cons (apply a (_a b)) (_d (_n b)))

                  )
                 )
           )
                  )
                 )
           )

-        (domap b)
+        (_d b)

         )
   )
 
         )
   )