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
17 (def (quote list) (lambda l l))
34 (else (cons (car a) (append-list (cdr a) b)))
41 (cond ((null? lists) lists)
42 ((null? (cdr lists)) (car lists))
43 (else (append-list (car lists) (append-lists (cdr lists))))
52 (append '(a b c) '(d e f) '(g h i))
81 ; execute to resolve macros
110 ; execute to resolve macros
118 ; A constant value is either a pair starting with quote,
119 ; or anything which is neither a pair nor a symbol
123 (eq? (car exp) 'quote)
131 (def! combine-skeletons
132 (lambda (left right exp)
134 ((and (constant? left) (constant? right))
135 (cond ((and (eqv? (eval left) (car exp))
136 (eqv? (eval right) (cdr exp)))
140 (list 'quote (cons (eval left) (eval right)))
147 ((and (pair? right) (eq? (car right) 'list))
148 (cons 'list (cons left (cdr right)))
151 (list 'cons left right)
157 (def! expand-quasiquote
158 (lambda (exp nesting)
161 ; non cons -- constants
162 ; themselves, others are
166 (cond ((constant? exp)
175 ; check for an unquote exp and
176 ; add the param unquoted
178 ((and (eq? (car exp) 'unquote) (= (length exp) 2))
183 (combine-skeletons ''unquote
184 (expand-quasiquote (cdr exp) (- nesting 1))
189 ; nested quasi-quote --
190 ; construct the right
193 ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
194 (combine-skeletons ''quasiquote
195 (expand-quasiquote (cdr exp) (+ nesting 1))
199 ; unquote-splicing member,
200 ; compute the expansion of the
201 ; value and append the rest of
202 ; the quasiquote result to it
204 ((and (pair? (car exp))
205 (eq? (car (car exp)) 'unquote-splicing)
206 (= (length (car exp)) 2))
208 (list 'append (car (cdr (car exp)))
209 (expand-quasiquote (cdr exp) nesting))
212 (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
213 (expand-quasiquote (cdr exp) nesting)
218 ; for other lists, just glue
219 ; the expansion of the first
220 ; element to the expansion of
221 ; the rest of the list
223 (else (combine-skeletons (expand-quasiquote (car exp) nesting)
224 (expand-quasiquote (cdr exp) nesting)
230 (def! result (expand-quasiquote x 0))
237 ; Define a variable without returning the value
238 ; Useful when defining functions to avoid
239 ; having lots of output generated.
241 ; Also accepts the alternate
242 ; form for defining lambdas of
243 ; (define (name x y z) sexprs ...)
248 (macro (first . rest)
249 ; check for alternate lambda definition form
258 (set! first (car first))
261 (set! rest (car rest))
264 (def! result `(,begin
265 (,def (,quote ,first) ,rest)
274 ; basic list accessors
276 (define (caar l) (car (car l)))
278 (define (cadr l) (car (cdr l)))
280 (define (cdar l) (cdr (car l)))
282 (define (caddr l) (car (cdr (cdr l))))
284 ; (if <condition> <if-true>)
285 ; (if <condition> <if-true> <if-false)
289 (cond ((null? (cdr args))
290 `(cond (,test ,(car args)))
293 `(cond (,test ,(car args))
301 (if (> 3 2) 'yes 'no)
302 (if (> 2 3) 'no 'yes)
305 ; simple math operators
307 (define zero? (macro (value) `(eq? ,value 0)))
313 (define positive? (macro (value) `(> ,value 0)))
318 (define negative? (macro (value) `(< ,value 0)))
323 (define (abs x) (if (>= x 0) x (- x)))
328 (define max (lambda (first . rest)
329 (while (not (null? rest))
330 (cond ((< first (car rest))
331 (set! first (car rest)))
333 (set! rest (cdr rest))
341 (define min (lambda (first . rest)
342 (while (not (null? rest))
343 (cond ((> first (car rest))
344 (set! first (car rest)))
346 (set! rest (cdr rest))
354 (define (even? x) (zero? (% x 2)))
361 (define (odd? x) (not (even? x)))
369 (define (list-tail x k)
372 (list-tail (cdr x (- k 1)))
376 (define (list-ref x k)
377 (car (list-tail x k))
380 ; define a set of local
381 ; variables all at once and
382 ; then evaluate a list of
385 ; (let (var-defines) sexprs)
387 ; where var-defines are either
397 ; (let ((x 1) (y)) (set! y (+ x 1)) y)
400 (macro (vars . exprs)
401 (define (make-names vars)
402 (cond ((not (null? vars))
403 (cons (car (car vars))
404 (make-names (cdr vars))))
409 ; the parameters to the lambda is a list
410 ; of nils of the right length
412 (define (make-vals vars)
413 (cond ((not (null? vars))
414 (cons (cond ((null? (cdr (car vars))) ())
416 (car (cdr (car vars))))
418 (make-vals (cdr vars))))
422 ; prepend the set operations
427 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
432 (let ((x 1) (y)) (set! y 2) (+ x y))
434 ; define a set of local
435 ; variables one at a time and
436 ; then evaluate a list of
439 ; (let* (var-defines) sexprs)
441 ; where var-defines are either
451 ; (let* ((x 1) (y)) (set! y (+ x 1)) y)
454 (macro (vars . exprs)
457 ; make the list of names in the let
460 (define (make-names vars)
461 (cond ((not (null? vars))
462 (cons (car (car vars))
463 (make-names (cdr vars))))
468 ; the set of expressions is
469 ; the list of set expressions
471 ; expressions to evaluate
473 (define (make-exprs vars exprs)
474 (cond ((null? vars) exprs)
481 (cond ((null? (cdr (car vars))) ())
482 (else (cadr (car vars))))
484 (make-exprs (cdr vars) exprs)
490 ; the parameters to the lambda is a list
491 ; of nils of the right length
493 (define (make-nils vars)
494 (cond ((null? vars) ())
495 (else (cons () (make-nils (cdr vars))))
500 `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars))
504 (let* ((x 1) (y x)) (+ x y))
506 (define when (macro (test . l) `(cond (,test ,@l))))
508 (when #t (write 'when))
510 (define unless (macro (test . l) `(cond ((not ,test) ,@l))))
512 (unless #f (write 'unless))
514 (define (reverse list)
516 (while (not (null? list))
517 (set! result (cons (car list) result))
518 (set! list (cdr list))
525 (define (list-tail x k)
528 (list-tail (cdr x) (- k 1))))
530 (list-tail '(1 2 3) 2)
532 (define (list-ref x k) (car (list-tail x k)))
534 (list-ref '(1 2 3) 2)
540 ((and (pair? a) (pair? b))
541 (and (equal? (car a) (car b))
542 (equal? (cdr a) (cdr b)))
548 (equal? '(a b c) '(a b c))
549 (equal? '(a b c) '(a b b))
551 (define member (lambda (obj list . test?)
556 (if (null? test?) (set! test? equal?) (set! test? (car test?)))
557 (if (test? obj (car list))
559 (member obj (cdr list) test?))
565 (member '(2) '((1) (2) (3)))
567 (member '(4) '((1) (2) (3)))
569 (define (memq obj list) (member obj list eq?))
575 (memq '(2) '((1) (2) (3)))
577 (define (memv obj list) (member obj list eqv?))
583 (memv '(2) '((1) (2) (3)))
585 (define (_assoc obj list test?)
588 (if (test? obj (caar list))
590 (_assoc obj (cdr list) test?)
595 (define (assq obj list) (_assoc obj list eq?))
596 (define (assv obj list) (_assoc obj list eqv?))
597 (define (assoc obj list) (_assoc obj list equal?))
599 (assq 'a '((a 1) (b 2) (c 3)))
600 (assv 'b '((a 1) (b 2) (c 3)))
601 (assoc '(c) '((a 1) (b 2) ((c) 3)))
603 (define char? integer?)
608 (define (char-upper-case? c) (<= #\A c #\Z))
610 (char-upper-case? #\a)
611 (char-upper-case? #\B)
612 (char-upper-case? #\0)
613 (char-upper-case? #\space)
615 (define (char-lower-case? c) (<= #\a c #\a))
617 (char-lower-case? #\a)
618 (char-lower-case? #\B)
619 (char-lower-case? #\0)
620 (char-lower-case? #\space)
622 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
624 (char-alphabetic? #\a)
625 (char-alphabetic? #\B)
626 (char-alphabetic? #\0)
627 (char-alphabetic? #\space)
629 (define (char-numeric? c) (<= #\0 c #\9))
634 (char-numeric? #\space)
636 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
638 (char-whitespace? #\a)
639 (char-whitespace? #\B)
640 (char-whitespace? #\0)
641 (char-whitespace? #\space)
643 (define (char->integer c) c)
644 (define integer->char char->integer)
646 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
651 (char-upcase #\space)
653 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
658 (char-downcase #\space)
660 (define string (lambda chars (list->string chars)))
666 (lambda (proc . lists)
668 (cond ((null? lists) ())
670 (cons (caar lists) (args (cdr lists)))
675 (cond ((null? lists) ())
677 (cons (cdr (car lists)) (next (cdr lists)))
681 (define (domap lists)
682 (cond ((null? (car lists)) ())
684 (cons (apply proc (args lists)) (domap (next lists)))
692 (map cadr '((a b) (d e) (g h)))
694 (define for-each (lambda (proc . lists)
695 (apply map proc lists)
698 (for-each display '("hello" " " "world" "\n"))
700 (define (_string-ml strings)
701 (if (null? strings) ()
702 (cons (string->list (car strings)) (_string-ml (cdr strings)))
706 (define string-map (lambda (proc . strings)
707 (list->string (apply map proc (_string-ml strings))))))
709 (string-map (lambda (x) (+ 1 x)) "HAL")
711 (define string-for-each (lambda (proc . strings)
712 (apply for-each proc (_string-ml strings))))
714 (string-for-each write-char "IBM\n")
716 (define (newline) (write-char #\newline))
720 (call-with-current-continuation
722 (for-each (lambda (x)
726 '(54 0 37 -3 245 19))
731 ; `(q) -> (append (quote (q)))
732 ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
733 ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
737 `(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
741 (macro (count . rest)
742 (define counter '__count__)
744 (set! counter (car count))
745 (set! count (cadr count))
751 (while (< ,counter __max__)
753 (set! ,counter (+ ,counter 1))
759 (repeat 2 (write 'hello))
760 (repeat (x 3) (write 'goodbye x))
764 ; construct the body of the
765 ; case, dealing with the
766 ; lambda version ( => lambda)
770 ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
774 ; Build the case elements, which is
775 ; simply a list of cond clauses
783 ((eq? (caar l) 'else)
784 `((else ,@(_unarrow (cdr (car l))))))
790 `((eqv? ,(caar l) __key__)
791 ,@(_unarrow (cdr (car l))))
797 ; now construct the overall
798 ; expression, using a lambda
799 ; to hold the computed value
800 ; of the test expression
803 (cond ,@(_case l))) ,test)
807 (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))