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))))
64 (cond ((= n 0) (car list))
65 ((nth (cdr list) (1- n)))
69 ; simple math operators
71 (defun 1+ (x) (+ x 1))
72 (defun 1- (x) (- x 1))
74 (define zero? (macro (value rest)
86 (define positive? (macro (value rest)
97 (define negative? (macro (value rest)
108 (defun abs (x) (cond ((>= x 0) x)
115 (define max (lexpr (first rest)
116 (while (not (null? rest))
117 (cond ((< first (car rest))
118 (set! first (car rest)))
120 (set! rest (cdr rest))
128 (define min (lexpr (first rest)
129 (while (not (null? rest))
130 (cond ((> first (car rest))
131 (set! first (car rest)))
133 (set! rest (cdr rest))
141 (defun even? (x) (zero? (% x 2)))
148 (defun odd? (x) (not (even? x)))
155 (define exact? number?)
156 (defun inexact? (x) #f)
158 ; (if <condition> <if-true>)
159 ; (if <condition> <if-true> <if-false)
161 (define if (macro (test args)
162 (cond ((null? (cdr args))
165 (list test (car args)))
170 (list test (car args))
171 (list 'else (cadr args))
179 (if (> 3 2) 'yes 'no)
180 (if (> 2 3) 'no 'yes)
183 ; define a set of local
184 ; variables and then evaluate
187 ; (let (var-defines) sexprs)
189 ; where var-defines are either
199 ; (let ((x 1) (y)) (set! y (+ x 1)) y)
201 (define let (macro (vars exprs)
202 ((lambda (make-names make-exprs make-nils)
205 ; make the list of names in the let
208 (set! make-names (lambda (vars)
209 (cond ((not (null? vars))
210 (cons (car (car vars))
211 (make-names (cdr vars))))
216 ; the set of expressions is
217 ; the list of set expressions
219 ; expressions to evaluate
221 (set! make-exprs (lambda (vars exprs)
222 (cond ((not (null? vars)) (cons
229 (make-exprs (cdr vars) exprs)
237 ; the parameters to the lambda is a list
238 ; of nils of the right length
240 (set! make-nils (lambda (vars)
241 (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))
245 ; prepend the set operations
248 (set! exprs (make-exprs vars exprs))
252 (cons (cons 'lambda (cons (make-names vars) exprs))
267 (define or (lexpr (l)
269 (while (not (null? l))
270 (cond ((car l) (set! ret #t) (set! l ()))
277 ; execute to resolve macros
281 (define and (lexpr (l)
283 (while (not (null? l))
296 ; execute to resolve macros
301 (define append (lexpr (args)
302 (let ((append-list (lambda (a b)
304 (else (cons (car a) (append-list (cdr a) b)))
308 (append-lists (lambda (lists)
309 (cond ((null? lists) lists)
310 ((null? (cdr lists)) (car lists))
311 (else (append-list (car lists) (append-lists (cdr lists))))
321 (append '(a b c) '(d e f) '(g h i))
323 (defun reverse (list)
325 (while (not (null? list))
326 (set! result (cons (car list) result))
327 (set! list (cdr list))
338 (list-tail (cdr x) (- k 1)))))
340 (list-tail '(1 2 3) 2)
342 (defun list-ref (x k) (car (list-tail x k)))
344 (list-ref '(1 2 3) 2)
351 ((and (pair? a) (pair? b))
352 (and (equal? (car a) (car b))
353 (equal? (cdr a) (cdr b)))
359 (equal? '(a b c) '(a b c))
360 (equal? '(a b c) '(a b b))
362 (defun _member (obj list test?)
365 (if (test? obj (car list))
367 (memq obj (cdr list)))))
369 (defun memq (obj list) (_member obj list eq?))
375 (defun memv (obj list) (_member obj list eqv?))
381 (defun member (obj list) (_member obj list equal?))
383 (member '(2) '((1) (2) (3)))
385 (member '(4) '((1) (2) (3)))
387 (defun _assoc (obj list test?)
390 (if (test? obj (caar list))
392 (_assoc obj (cdr list) test?)
397 (defun assq (obj list) (_assoc obj list eq?))
398 (defun assv (obj list) (_assoc obj list eqv?))
399 (defun assoc (obj list) (_assoc obj list equal?))
401 (assq 'a '((a 1) (b 2) (c 3)))
402 (assv 'b '((a 1) (b 2) (c 3)))
403 (assoc '(c) '((a 1) (b 2) ((c) 3)))
405 (define char? integer?)
410 (defun char-upper-case? (c) (<= #\A c #\Z))
412 (char-upper-case? #\a)
413 (char-upper-case? #\B)
414 (char-upper-case? #\0)
415 (char-upper-case? #\space)
417 (defun char-lower-case? (c) (<= #\a c #\a))
419 (char-lower-case? #\a)
420 (char-lower-case? #\B)
421 (char-lower-case? #\0)
422 (char-lower-case? #\space)
424 (defun char-alphabetic? (c) (or (char-upper-case? c) (char-lower-case? c)))
426 (char-alphabetic? #\a)
427 (char-alphabetic? #\B)
428 (char-alphabetic? #\0)
429 (char-alphabetic? #\space)
431 (defun char-numeric? (c) (<= #\0 c #\9))
436 (char-numeric? #\space)
438 (defun char-whitespace? (c) (or (<= #\tab c #\return) (= #\space c)))
440 (char-whitespace? #\a)
441 (char-whitespace? #\B)
442 (char-whitespace? #\0)
443 (char-whitespace? #\space)
445 (defun char->integer (c) c)
446 (defun integer->char (c) char-integer)
448 (defun char-upcase (c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
453 (char-upcase #\space)
455 (defun char-downcase (c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
460 (char-downcase #\space)
462 (define string (lexpr (chars) (list->string chars)))
464 ;(define number->string (lexpr (arg opt)
465 ; (let ((base (if (null? opt) 10 (car opt)))