altos/scheme: Add ports. Split scheme code up.

[fw/altos] / src / scheme / ao_scheme_basic_syntax.scheme

;
; Copyright © 2018 Keith Packard <keithp@keithp.com>
;
; This program is free software; you can redistribute it and/or modify
; it under the terms of the GNU General Public License as published by
; the Free Software Foundation, either version 2 of the License, or
; (at your option) any later version.
;
; This program is distributed in the hope that it will be useful, but
; WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
; General Public License for more details.
;
; Basic syntax placed in ROM

(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1)))))

(def (quote list) (lambda l l))

(def (quote def!)
     (macro (a b)
            (list
             def
             (list quote a)
             b)
            )
     )

(begin
 (def! append
   (lambda args
          (def! _a
            (lambda (a b)
              (cond ((null? a) b)
                    (else (cons (car a) (_a (cdr a) b)))
                    )
              )
            )
            
          (def! _b
            (lambda (l)
              (cond ((null? l) l)
                    ((null? (cdr l)) (car l))
                    (else (_a (car l) (_b (cdr l))))
                    )
              )
            )
          (_b args)
          )
   )
 'append)

(append '(a) '(b))


                                        ;
                                        ; Define a variable without returning the value
                                        ; Useful when defining functions to avoid
                                        ; having lots of output generated.
                                        ;
                                        ; Also accepts the alternate
                                        ; form for defining lambdas of
                                        ; (define (name x y z) sexprs ...) 
                                        ;

(begin
 (def! define
   (macro (a . b)
                                        ; check for alternate lambda definition form

          (cond ((pair? a)
                 (set! b
                       (cons
                        lambda
                        (cons (cdr a) b)))
                 (set! a (car a))
                 )
                (else
                 (set! b (car b))
                 )
                )
          (cons begin
                (cons
                 (cons def
                       (cons (cons quote (cons a '()))
                             (cons b '())
                             )
                       )
                 (cons
                  (cons quote (cons a '()))
                  '())
                 )
                )
          )
   )
 'define
 )
                                        ; boolean operators

(define or
  (macro a
    (def! b
      (lambda (a)
        (cond ((null? a) #f)
              ((null? (cdr a))
               (car a))
              (else
               (list
                cond
                (list
                 (car a))
                (list
                 'else
                 (b (cdr a))
                 )
                )
               )
              )
        )
      )
    (b a)))

                                        ; execute to resolve macros

(_?_ (or #f #t) #t)

(define and
  (macro a
    (def! b
      (lambda (a)
        (cond ((null? a) #t)
              ((null? (cdr a))
               (car a))
              (else
               (list
                cond
                (list
                 (car a)
                 (b (cdr a))
                 )
                )
               )
              )
        )
      )
    (b a)
    )
  )

                                        ; execute to resolve macros

(_?_ (and #t #f) #f)

                                        ; (if <condition> <if-true>)
                                        ; (if <condition> <if-true> <if-false)

(define if
  (macro (a . b)
    (cond ((null? (cdr b))
           (list cond (list a (car b)))
                )
          (else
           (list cond
                 (list a (car b))
                 (list 'else (car (cdr b)))
                 )
           )
          )
    )
  )

(_?_ (if (> 3 2) 'yes) 'yes)
(_?_ (if (> 3 2) 'yes 'no) 'yes)
(_?_ (if (> 2 3) 'no 'yes) 'yes)
(_?_ (if (> 2 3) 'no) #f)

(define letrec
  (macro (a . b)

                                        ;
                                        ; make the list of names in the let
                                        ;

         (define (_a a)
           (cond ((not (null? a))
                  (cons (car (car a))
                        (_a (cdr a))))
                 (else ())
                 )
           )

                                        ; the set of expressions is
                                        ; the list of set expressions
                                        ; pre-pended to the
                                        ; expressions to evaluate

         (define (_b a b)
           (cond ((null? a) b)
                 (else
                  (cons
                   (list set
                         (list quote
                               (car (car a))
                               )
                         (cond ((null? (cdr (car a)))
                                ()
                                )
                               (else
                                (car (cdr (car a)))
                                )
                               )
                         )
                   (_b (cdr a) b)
                   )
                  )
                 )
           )

                                        ; the parameters to the lambda is a list
                                        ; of nils of the right length

         (define (_c a)
           (cond ((null? a) ())
                 (else (cons () (_c (cdr a))))
                 )
           )
                                        ; build the lambda.

         (cons (cons lambda (cons (_a a) (_b a b))) (_c a))
         )
     )

(_?_ (letrec ((a 1) (b a)) (+ a b)) 2)

                                        ; letrec is sufficient for let*

(define let* letrec)

                                        ; use letrec for let in basic
                                        ; syntax

(define let letrec)

                                        ; Basic recursive
                                        ; equality. Replaced with
                                        ; vector-capable version in
                                        ; advanced syntax

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

(_?_ (equal? '(a b c) '(a b c)) #t)
(_?_ (equal? '(a b c) '(a b b)) #f)

(def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit 1)))))

                                        ; basic list accessors

(define (caar a) (car (car a)))

(define (cadr a) (car (cdr a)))

(define (cdar l) (cdr (car l)))

(_??_ (cdar '((1 2) (3 4))) '(2))

(define (cddr l) (cdr (cdr l)))

(_??_ (cddr '(1 2 3)) '(3))

(define (caddr l) (car (cdr (cdr l))))

(_??_ (caddr '(1 2 3 4)) 3)

(define (list-ref a b)
  (car (list-tail a b))
  )

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

(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)))  '((2) (3)))
(_??_ (member '(4) '((1) (2) (3))) #f)

(define (memq a b) (member a b eq?))

(_??_ (memq 2 '(1 2 3)) '(2 3))
(_??_ (memq 4 '(1 2 3)) #f)
(_??_ (memq '(2) '((1) (2) (3))) #f)

(define (assoc a b . t?)
  (if (null? t?)
      (set! t? equal?)
      (set! t? (car t?))
      )
  (if (null? b)
      #f
    (if (t? a (caar b))
        (car b)
      (assoc a (cdr b) t?)
      )
    )
  )

(define (assq a b) (assoc a b eq?))
(define assv assq)

(_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1))
(_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2))
(_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3))

(define map
  (lambda (proc . lists)
         (define (_a lists)
           (cond ((null? lists) ())
                 (else
                  (cons (caar lists) (_a (cdr lists)))
                  )
                 )
           )
         (define (_n lists)
           (cond ((null? lists) ())
                 (else
                  (cons (cdr (car lists)) (_n (cdr lists)))
                  )
                 )
           )
         (define (_m lists)
           (cond ((null? (car lists)) ())
                 (else
                  (cons (apply proc (_a lists)) (_m (_n lists)))
                  )
                 )
           )
         (_m lists)
         )
  )

(_??_ (map cadr '((a b) (d e) (g h))) '(b e h))

                                        ; use map as for-each in basic
                                        ; mode

(define for-each map)
                                        ; simple math operators

(define zero? (macro (value) (list eq? value 0)))

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

(define positive? (macro (value) (list > value 0)))

(positive? 12)
(positive? -12)

(define negative? (macro (value) (list < value 0)))

(negative? 12)
(negative? -12)

(define (abs a) (if (>= a 0) a (- a)))

(abs 12)
(abs -12)

(define max (lambda (a . b)
                   (while (not (null? b))
                     (cond ((< a (car b))
                            (set! a (car b)))
                           )
                     (set! b (cdr b))
                     )
                   a)
  )

(max 1 2 3)
(max 3 2 1)

(define min (lambda (a . b)
                   (while (not (null? b))
                     (cond ((> a (car b))
                            (set! a (car b)))
                           )
                     (set! b (cdr b))
                     )
                   a)
  )

(min 1 2 3)
(min 3 2 1)

(define (even? a) (zero? (% a 2)))

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

(define (odd? a) (not (even? a)))

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

(define (newline) (write-char #\newline))

(newline)

(define (eof-object? a)
  (equal? a 'eof)
  )