+++ /dev/null
-;
-; 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 list) (lambda l l))
-
-(def (quote def!)
- (macro (a b)
- (list
- def
- (list quote a)
- b)
- )
- )
-
-(begin
- (def! append
- (lambda a
- (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 a)
- )
- )
- '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)
-
-(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)
-
- ; (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)
-(if (> 3 2) 'yes 'no)
-(if (> 2 3) 'no 'yes)
-(if (> 2 3) 'no)
-
-(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))
-
- ; 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))
-
- ; basic list accessors
-
-(define (caar a) (car (car a)))
-
-(define (cadr a) (car (cdr a)))
-
-(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)))
-(member '(4) '((1) (2) (3)))
-
-(define (memq a b) (member a b eq?))
-
-(memq 2 '(1 2 3))
-(memq 4 '(1 2 3))
-(memq '(2) '((1) (2) (3)))
-
-(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?)
- )
- )
- )
-
-(assoc '(c) '((a 1) (b 2) ((c) 3)))
-
-(define (assq a b) (assoc a b eq?))
-
-(assq 'a '((a 1) (b 2) (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)))
-
- ; 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)
projects / fw / altos / blobdiff