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 ; (if <condition> <if-true>)
163 ; (if <condition> <if-true> <if-false)
165 (define if (macro (test args)
166 (cond ((null? (cdr args))
169 (list test (car args)))
174 (list test (car args))
175 (list 'else (cadr args))
183 (if (> 3 2) 'yes 'no)
184 (if (> 2 3) 'no 'yes)
187 ; define a set of local
188 ; variables and then evaluate
191 ; (let (var-defines) sexprs)
193 ; where var-defines are either
203 ; (let ((x 1) (y)) (set! y (+ x 1)) y)
205 (define let (macro (vars exprs)
206 ((lambda (make-names make-exprs make-nils)
209 ; make the list of names in the let
212 (set! make-names (lambda (vars)
213 (cond ((not (null? vars))
214 (cons (car (car vars))
215 (make-names (cdr vars))))
220 ; the set of expressions is
221 ; the list of set expressions
223 ; expressions to evaluate
225 (set! make-exprs (lambda (vars exprs)
226 (cond ((not (null? vars))
232 (cond ((null? (cdr (car vars))) ())
233 (else (cadr (car vars))))
235 (make-exprs (cdr vars) exprs)
243 ; the parameters to the lambda is a list
244 ; of nils of the right length
246 (set! make-nils (lambda (vars)
247 (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))
251 ; prepend the set operations
254 (set! exprs (make-exprs vars exprs))
258 (cons (cons 'lambda (cons (make-names vars) exprs))
274 (define or (lexpr (l)
276 (while (not (null? l))
277 (cond ((car l) (set! ret #t) (set! l ()))
284 ; execute to resolve macros
288 (define and (lexpr (l)
290 (while (not (null? l))
303 ; execute to resolve macros
308 (define append (lexpr (args)
309 (let ((append-list (lambda (a b)
311 (else (cons (car a) (append-list (cdr a) b)))
315 (append-lists (lambda (lists)
316 (cond ((null? lists) lists)
317 ((null? (cdr lists)) (car lists))
318 (else (append-list (car lists) (append-lists (cdr lists))))
328 (append '(a b c) '(d e f) '(g h i))
330 (defun reverse (list)
332 (while (not (null? list))
333 (set! result (cons (car list) result))
334 (set! list (cdr list))
345 (list-tail (cdr x) (- k 1)))))
347 (list-tail '(1 2 3) 2)
349 (defun list-ref (x k) (car (list-tail x k)))
351 (list-ref '(1 2 3) 2)
358 ((and (pair? a) (pair? b))
359 (and (equal? (car a) (car b))
360 (equal? (cdr a) (cdr b)))
366 (equal? '(a b c) '(a b c))
367 (equal? '(a b c) '(a b b))
369 (defun _member (obj list test?)
372 (if (test? obj (car list))
374 (memq obj (cdr list)))))
376 (defun memq (obj list) (_member obj list eq?))
382 (defun memv (obj list) (_member obj list eqv?))
388 (defun member (obj list) (_member obj list equal?))
390 (member '(2) '((1) (2) (3)))
392 (member '(4) '((1) (2) (3)))
394 (defun _assoc (obj list test?)
397 (if (test? obj (caar list))
399 (_assoc obj (cdr list) test?)
404 (defun assq (obj list) (_assoc obj list eq?))
405 (defun assv (obj list) (_assoc obj list eqv?))
406 (defun assoc (obj list) (_assoc obj list equal?))
408 (assq 'a '((a 1) (b 2) (c 3)))
409 (assv 'b '((a 1) (b 2) (c 3)))
410 (assoc '(c) '((a 1) (b 2) ((c) 3)))
412 (define char? integer?)
417 (defun char-upper-case? (c) (<= #\A c #\Z))
419 (char-upper-case? #\a)
420 (char-upper-case? #\B)
421 (char-upper-case? #\0)
422 (char-upper-case? #\space)
424 (defun char-lower-case? (c) (<= #\a c #\a))
426 (char-lower-case? #\a)
427 (char-lower-case? #\B)
428 (char-lower-case? #\0)
429 (char-lower-case? #\space)
431 (defun char-alphabetic? (c) (or (char-upper-case? c) (char-lower-case? c)))
433 (char-alphabetic? #\a)
434 (char-alphabetic? #\B)
435 (char-alphabetic? #\0)
436 (char-alphabetic? #\space)
438 (defun char-numeric? (c) (<= #\0 c #\9))
443 (char-numeric? #\space)
445 (defun char-whitespace? (c) (or (<= #\tab c #\return) (= #\space c)))
447 (char-whitespace? #\a)
448 (char-whitespace? #\B)
449 (char-whitespace? #\0)
450 (char-whitespace? #\space)
452 (defun char->integer (c) c)
453 (defun integer->char (c) char-integer)
455 (defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
460 (char-upcase #\space)
462 (defun char-downcase (c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
467 (char-downcase #\space)
469 (define string (lexpr (chars) (list->string chars)))
474 (define map (lexpr (proc lists)
475 (let ((args (lambda (lists)
477 (cons (caar lists) (args (cdr lists))))))
478 (next (lambda (lists)
480 (cons (cdr (car lists)) (next (cdr lists))))))
481 (domap (lambda (lists)
482 (if (null? (car lists)) ()
483 (cons (apply proc (args lists)) (domap (next lists)))
488 (map cadr '((a b) (d e) (g h)))
490 (define for-each (lexpr (proc lists)
491 (apply map proc lists)
494 (for-each display '("hello" " " "world" "\n"))
496 (define -string-ml (lambda (strings)
497 (if (null? strings) ()
498 (cons (string->list (car strings)) (-string-ml (cdr strings))))))
500 (define string-map (lexpr (proc strings)
501 (list->string (apply map proc (-string-ml strings))))))
503 (string-map 1+ "HAL")
505 (define string-for-each (lexpr (proc strings)
506 (apply for-each proc (-string-ml strings))))
508 (string-for-each write-char "IBM\n")
510 (define newline (lambda () (write-char #\newline)))
514 (call-with-current-continuation
516 (for-each (lambda (x)
520 '(54 0 37 -3 245 19))
523 ;(define number->string (lexpr (arg opt)
524 ; (let ((base (if (null? opt) 10 (car opt)))