2 ; Copyright © 2018 Keith Packard <keithp@keithp.com>
4 ; This program is free software; you can redistribute it and/or modify
5 ; it under the terms of the GNU General Public License as published by
6 ; the Free Software Foundation, either version 2 of the License, or
7 ; (at your option) any later version.
9 ; This program is distributed in the hope that it will be useful, but
10 ; WITHOUT ANY WARRANTY; without even the implied warranty of
11 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12 ; General Public License for more details.
14 ; Basic syntax placed in ROM
16 (def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1)))))
18 (def (quote list) (lambda l l))
35 (else (cons (car a) (_a (cdr a) b)))
43 ((null? (cdr l)) (car l))
44 (else (_a (car l) (_b (cdr l))))
57 ; Define a variable without returning the value
58 ; Useful when defining functions to avoid
59 ; having lots of output generated.
61 ; Also accepts the alternate
62 ; form for defining lambdas of
63 ; (define (name x y z) sexprs ...)
69 ; check for alternate lambda definition form
85 (cons (cons quote (cons a '()))
90 (cons quote (cons a '()))
123 ; execute to resolve macros
150 ; execute to resolve macros
154 ; (if <condition> <if-true>)
155 ; (if <condition> <if-true> <if-false)
159 (cond ((null? (cdr b))
160 (list cond (list a (car b)))
165 (list 'else (car (cdr b)))
172 (_?_ (if (> 3 2) 'yes) 'yes)
173 (_?_ (if (> 3 2) 'yes 'no) 'yes)
174 (_?_ (if (> 2 3) 'no 'yes) 'yes)
175 (_?_ (if (> 2 3) 'no) #f)
181 ; make the list of names in the let
185 (cond ((not (null? a))
192 ; the set of expressions is
193 ; the list of set expressions
195 ; expressions to evaluate
205 (cond ((null? (cdr (car a)))
219 ; the parameters to the lambda is a list
220 ; of nils of the right length
224 (else (cons () (_c (cdr a))))
229 (cons (cons lambda (cons (_a a) (_b a b))) (_c a))
233 (_?_ (letrec ((a 1) (b a)) (+ a b)) 2)
235 ; letrec is sufficient for let*
239 ; use letrec for let in basic
245 ; equality. Replaced with
246 ; vector-capable version in
253 (cond ((equal? (car a) (car b))
254 (equal? (cdr a) (cdr b)))
262 (_?_ (equal? '(a b c) '(a b c)) #t)
263 (_?_ (equal? '(a b c) '(a b b)) #f)
265 (def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit 1)))))
267 ; basic list accessors
269 (define (caar a) (car (car a)))
271 (define (cadr a) (car (cdr a)))
273 (define (cdar l) (cdr (car l)))
275 (_??_ (cdar '((1 2) (3 4))) '(2))
277 (define (cddr l) (cdr (cdr l)))
279 (_??_ (cddr '(1 2 3)) '(3))
281 (define (caddr l) (car (cdr (cdr l))))
283 (_??_ (caddr '(1 2 3 4)) 3)
285 (define (list-ref a b)
286 (car (list-tail a b))
289 (list-ref '(1 2 3) 2)
291 (define (member a b . t?)
296 (if (null? t?) (set! t? equal?) (set! t? (car t?)))
299 (member a (cdr b) t?))
304 (_??_ (member '(2) '((1) (2) (3))) '((2) (3)))
305 (_??_ (member '(4) '((1) (2) (3))) #f)
307 (define (memq a b) (member a b eq?))
309 (_??_ (memq 2 '(1 2 3)) '(2 3))
310 (_??_ (memq 4 '(1 2 3)) #f)
311 (_??_ (memq '(2) '((1) (2) (3))) #f)
313 (define (assoc a b . t?)
327 (define (assq a b) (assoc a b eq?))
330 (_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1))
331 (_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2))
332 (_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3))
335 (lambda (proc . lists)
337 (cond ((null? lists) ())
339 (cons (caar lists) (_a (cdr lists)))
344 (cond ((null? lists) ())
346 (cons (cdr (car lists)) (_n (cdr lists)))
351 (cond ((null? (car lists)) ())
353 (cons (apply proc (_a lists)) (_m (_n lists)))
361 (_??_ (map cadr '((a b) (d e) (g h))) '(b e h))
363 ; use map as for-each in basic
366 (define for-each map)
367 ; simple math operators
369 (define zero? (macro (value) (list eq? value 0)))
375 (define positive? (macro (value) (list > value 0)))
380 (define negative? (macro (value) (list < value 0)))
385 (define (abs a) (if (>= a 0) a (- a)))
390 (define max (lambda (a . b)
391 (while (not (null? b))
403 (define min (lambda (a . b)
404 (while (not (null? b))
416 (define (even? a) (zero? (% a 2)))
423 (define (odd? a) (not (even? a)))
430 (define (newline) (write-char #\newline))
434 (define (eof-object? a)