2 ; Copyright © 2016 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 ; Lisp code placed in ROM
16 ; return a list containing all of the arguments
18 (set (quote list) (lexpr (l) l))
21 ; Define a variable without returning the value
22 ; Useful when defining functions to avoid
23 ; having lots of output generated
26 (set (quote define) (macro (name val rest)
39 ; A slightly more convenient form
40 ; for defining lambdas.
42 ; (defun <name> (<params>) s-exprs)
45 (define defun (macro (name args exprs)
49 (cons 'lambda (cons args exprs))
54 ; basic list accessors
57 (defun caar (l) (car (car l)))
59 (defun cadr (l) (car (cdr l)))
61 (defun caddr (l) (car (cdr (cdr l))))
63 (define list-tail (lambda (x k)
66 (list-tail (cdr x (- k 1)))
71 (define list-ref (lambda (x k)
76 ; simple math operators
78 (defun 1+ (x) (+ x 1))
79 (defun 1- (x) (- x 1))
81 (define zero? (macro (value rest)
93 (define positive? (macro (value rest)
104 (define negative? (macro (value rest)
115 (defun abs (x) (cond ((>= x 0) x)
122 (define max (lexpr (first rest)
123 (while (not (null? rest))
124 (cond ((< first (car rest))
125 (set! first (car rest)))
127 (set! rest (cdr rest))
135 (define min (lexpr (first rest)
136 (while (not (null? rest))
137 (cond ((> first (car rest))
138 (set! first (car rest)))
140 (set! rest (cdr rest))
148 (defun even? (x) (zero? (% x 2)))
155 (defun odd? (x) (not (even? x)))
162 (define exact? number?)
163 (defun inexact? (x) #f)
165 ; (if <condition> <if-true>)
166 ; (if <condition> <if-true> <if-false)
168 (define if (macro (test args)
169 (cond ((null? (cdr args))
172 (list test (car args)))
177 (list test (car args))
178 (list 'else (cadr args))
186 (if (> 3 2) 'yes 'no)
187 (if (> 2 3) 'no 'yes)
190 ; define a set of local
191 ; variables and then evaluate
194 ; (let (var-defines) sexprs)
196 ; where var-defines are either
206 ; (let ((x 1) (y)) (set! y (+ x 1)) y)
208 (define let (macro (vars exprs)
209 ((lambda (make-names make-exprs make-nils)
212 ; make the list of names in the let
215 (set! make-names (lambda (vars)
216 (cond ((not (null? vars))
217 (cons (car (car vars))
218 (make-names (cdr vars))))
223 ; the set of expressions is
224 ; the list of set expressions
226 ; expressions to evaluate
228 (set! make-exprs (lambda (vars exprs)
229 (cond ((not (null? vars))
235 (cond ((null? (cdr (car vars))) ())
236 (else (cadr (car vars))))
238 (make-exprs (cdr vars) exprs)
246 ; the parameters to the lambda is a list
247 ; of nils of the right length
249 (set! make-nils (lambda (vars)
250 (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))
254 ; prepend the set operations
257 (set! exprs (make-exprs vars exprs))
261 (cons (cons 'lambda (cons (make-names vars) exprs))
277 (define or (lexpr (l)
279 (while (not (null? l))
280 (cond ((car l) (set! ret #t) (set! l ()))
287 ; execute to resolve macros
291 (define and (lexpr (l)
293 (while (not (null? l))
306 ; execute to resolve macros
311 (define append (lexpr (args)
312 (let ((append-list (lambda (a b)
314 (else (cons (car a) (append-list (cdr a) b)))
318 (append-lists (lambda (lists)
319 (cond ((null? lists) lists)
320 ((null? (cdr lists)) (car lists))
321 (else (append-list (car lists) (append-lists (cdr lists))))
331 (append '(a b c) '(d e f) '(g h i))
333 (defun reverse (list)
335 (while (not (null? list))
336 (set! result (cons (car list) result))
337 (set! list (cdr list))
348 (list-tail (cdr x) (- k 1)))))
350 (list-tail '(1 2 3) 2)
352 (defun list-ref (x k) (car (list-tail x k)))
354 (list-ref '(1 2 3) 2)
361 ((and (pair? a) (pair? b))
362 (and (equal? (car a) (car b))
363 (equal? (cdr a) (cdr b)))
369 (equal? '(a b c) '(a b c))
370 (equal? '(a b c) '(a b b))
372 (defun _member (obj list test?)
375 (if (test? obj (car list))
377 (memq obj (cdr list)))))
379 (defun memq (obj list) (_member obj list eq?))
385 (defun memv (obj list) (_member obj list eqv?))
391 (defun member (obj list) (_member obj list equal?))
393 (member '(2) '((1) (2) (3)))
395 (member '(4) '((1) (2) (3)))
397 (defun _assoc (obj list test?)
400 (if (test? obj (caar list))
402 (_assoc obj (cdr list) test?)
407 (defun assq (obj list) (_assoc obj list eq?))
408 (defun assv (obj list) (_assoc obj list eqv?))
409 (defun assoc (obj list) (_assoc obj list equal?))
411 (assq 'a '((a 1) (b 2) (c 3)))
412 (assv 'b '((a 1) (b 2) (c 3)))
413 (assoc '(c) '((a 1) (b 2) ((c) 3)))
415 (define char? integer?)
420 (defun char-upper-case? (c) (<= #\A c #\Z))
422 (char-upper-case? #\a)
423 (char-upper-case? #\B)
424 (char-upper-case? #\0)
425 (char-upper-case? #\space)
427 (defun char-lower-case? (c) (<= #\a c #\a))
429 (char-lower-case? #\a)
430 (char-lower-case? #\B)
431 (char-lower-case? #\0)
432 (char-lower-case? #\space)
434 (defun char-alphabetic? (c) (or (char-upper-case? c) (char-lower-case? c)))
436 (char-alphabetic? #\a)
437 (char-alphabetic? #\B)
438 (char-alphabetic? #\0)
439 (char-alphabetic? #\space)
441 (defun char-numeric? (c) (<= #\0 c #\9))
446 (char-numeric? #\space)
448 (defun char-whitespace? (c) (or (<= #\tab c #\return) (= #\space c)))
450 (char-whitespace? #\a)
451 (char-whitespace? #\B)
452 (char-whitespace? #\0)
453 (char-whitespace? #\space)
455 (defun char->integer (c) c)
456 (defun integer->char (c) char-integer)
458 (defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
463 (char-upcase #\space)
465 (defun char-downcase (c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
470 (char-downcase #\space)
472 (define string (lexpr (chars) (list->string chars)))
477 (define map (lexpr (proc lists)
478 (let ((args (lambda (lists)
480 (cons (caar lists) (args (cdr lists))))))
481 (next (lambda (lists)
483 (cons (cdr (car lists)) (next (cdr lists))))))
484 (domap (lambda (lists)
485 (if (null? (car lists)) ()
486 (cons (apply proc (args lists)) (domap (next lists)))
491 (map cadr '((a b) (d e) (g h)))
493 (define for-each (lexpr (proc lists)
494 (apply map proc lists)
497 (for-each display '("hello" " " "world" "\n"))
499 (define -string-ml (lambda (strings)
500 (if (null? strings) ()
501 (cons (string->list (car strings)) (-string-ml (cdr strings))))))
503 (define string-map (lexpr (proc strings)
504 (list->string (apply map proc (-string-ml strings))))))
506 (string-map 1+ "HAL")
508 (define string-for-each (lexpr (proc strings)
509 (apply for-each proc (-string-ml strings))))
511 (string-for-each write-char "IBM\n")
513 (define newline (lambda () (write-char #\newline)))
517 (call-with-current-continuation
519 (for-each (lambda (x)
523 '(54 0 37 -3 245 19))
526 ;(define number->string (lexpr (arg opt)
527 ; (let ((base (if (null? opt) 10 (car opt)))