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 (set (quote list) (lexpr (l) l))
20 (macro (name value rest)
32 ((lambda (append-list append-lists)
36 (else (cons (car a) (append-list (cdr a) b)))
42 (cond ((null? lists) lists)
43 ((null? (cdr lists)) (car lists))
44 (else (append-list (car lists) (append-lists (cdr lists))))
53 (append '(a b c) '(d e f) '(g h i))
81 ; execute to resolve macros
111 ; execute to resolve macros
117 ((lambda (constant? combine-skeletons expand-quasiquote)
119 ; A constant value is either a pair starting with quote,
120 ; or anything which is neither a pair nor a symbol
124 (eq? (car exp) 'quote)
132 (set! combine-skeletons
133 (lambda (left right exp)
135 ((and (constant? left) (constant? right))
136 (cond ((and (eqv? (eval left) (car exp))
137 (eqv? (eval right) (cdr exp)))
141 (list 'quote (cons (eval left) (eval right)))
148 ((and (pair? right) (eq? (car right) 'list))
149 (cons 'list (cons left (cdr right)))
152 (list 'cons left right)
158 (set! expand-quasiquote
159 (lambda (exp nesting)
162 ; non cons -- constants
163 ; themselves, others are
167 (cond ((constant? exp)
176 ; check for an unquote exp and
177 ; add the param unquoted
179 ((and (eq? (car exp) 'unquote) (= (length exp) 2))
184 (combine-skeletons ''unquote
185 (expand-quasiquote (cdr exp) (- nesting 1))
190 ; nested quasi-quote --
191 ; construct the right
194 ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
195 (combine-skeletons ''quasiquote
196 (expand-quasiquote (cdr exp) (+ nesting 1))
200 ; unquote-splicing member,
201 ; compute the expansion of the
202 ; value and append the rest of
203 ; the quasiquote result to it
205 ((and (pair? (car exp))
206 (eq? (car (car exp)) 'unquote-splicing)
207 (= (length (car exp)) 2))
209 (list 'append (car (cdr (car exp)))
210 (expand-quasiquote (cdr exp) nesting))
213 (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
214 (expand-quasiquote (cdr exp) nesting)
219 ; for other lists, just glue
220 ; the expansion of the first
221 ; element to the expansion of
222 ; the rest of the list
224 (else (combine-skeletons (expand-quasiquote (car exp) nesting)
225 (expand-quasiquote (cdr exp) nesting)
231 (expand-quasiquote x 0)
236 ; Define a variable without returning the value
237 ; Useful when defining functions to avoid
238 ; having lots of output generated.
240 ; Also accepts the alternate
241 ; form for defining lambdas of
242 ; (define (name x y z) sexprs ...)
248 ; check for alternate lambda definition form
257 (set! first (car first))
260 (set! rest (car rest))
269 ; basic list accessors
272 (define (caar l) (car (car l)))
274 (define (cadr l) (car (cdr l)))
276 (define (cdar l) (cdr (car l)))
278 (define (caddr l) (car (cdr (cdr l))))
280 (define (list-tail x k)
283 (list-tail (cdr x (- k 1)))
287 (define (list-ref x k)
288 (car (list-tail x k))
291 ; (if <condition> <if-true>)
292 ; (if <condition> <if-true> <if-false)
296 (cond ((null? (cdr args))
297 `(cond (,test ,(car args)))
300 `(cond (,test ,(car args))
308 (if (> 3 2) 'yes 'no)
309 (if (> 2 3) 'no 'yes)
312 ; simple math operators
314 (define zero? (macro (value rest) `(eq? ,value 0)))
320 (define positive? (macro (value rest) `(> ,value 0)))
325 (define negative? (macro (value rest) `(< ,value 0)))
330 (define (abs x) (if (>= x 0) x (- x)))
335 (define max (lexpr (first rest)
336 (while (not (null? rest))
337 (cond ((< first (car rest))
338 (set! first (car rest)))
340 (set! rest (cdr rest))
348 (define min (lexpr (first rest)
349 (while (not (null? rest))
350 (cond ((> first (car rest))
351 (set! first (car rest)))
353 (set! rest (cdr rest))
361 (define (even? x) (zero? (% x 2)))
368 (define (odd? x) (not (even? x)))
376 ; define a set of local
377 ; variables all at once and
378 ; then evaluate a list of
381 ; (let (var-defines) sexprs)
383 ; where var-defines are either
393 ; (let ((x 1) (y)) (set! y (+ x 1)) y)
395 (define let (macro (vars exprs)
396 ((lambda (make-names make-vals)
399 ; make the list of names in the let
402 (set! make-names (lambda (vars)
403 (cond ((not (null? vars))
404 (cons (car (car vars))
405 (make-names (cdr vars))))
411 ; the parameters to the lambda is a list
412 ; of nils of the right length
414 (set! make-vals (lambda (vars)
415 (cond ((not (null? vars))
416 (cons (cond ((null? (cdr (car vars))) ())
418 (car (cdr (car vars))))
420 (make-vals (cdr vars))))
425 ; prepend the set operations
430 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
439 (let ((x 1) (y)) (set! y 2) (+ x y))
441 ; define a set of local
442 ; variables one at a time and
443 ; then evaluate a list of
446 ; (let* (var-defines) sexprs)
448 ; where var-defines are either
458 ; (let* ((x 1) (y)) (set! y (+ x 1)) y)
460 (define let* (macro (vars exprs)
461 ((lambda (make-names make-exprs make-nils)
464 ; make the list of names in the let
467 (set! make-names (lambda (vars)
468 (cond ((not (null? vars))
469 (cons (car (car vars))
470 (make-names (cdr vars))))
476 ; the set of expressions is
477 ; the list of set expressions
479 ; expressions to evaluate
481 (set! make-exprs (lambda (vars exprs)
482 (cond ((not (null? vars))
488 (cond ((null? (cdr (car vars))) ())
489 (else (cadr (car vars))))
491 (make-exprs (cdr vars) exprs)
499 ; the parameters to the lambda is a list
500 ; of nils of the right length
502 (set! make-nils (lambda (vars)
503 (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))
508 ; prepend the set operations
511 (set! exprs (make-exprs vars exprs))
515 `((lambda ,(make-names vars) ,@exprs) ,@(make-nils vars))
526 (define when (macro (test l) `(cond (,test ,@l))))
528 (when #t (write 'when))
530 (define unless (macro (test l) `(cond ((not ,test) ,@l))))
532 (unless #f (write 'unless))
534 (define (reverse list)
536 (while (not (null? list))
537 (set! result (cons (car list) result))
538 (set! list (cdr list))
545 (define (list-tail x k)
548 (list-tail (cdr x) (- k 1)))))
550 (list-tail '(1 2 3) 2)
552 (define (list-ref x k) (car (list-tail x k)))
554 (list-ref '(1 2 3) 2)
560 ((and (pair? a) (pair? b))
561 (and (equal? (car a) (car b))
562 (equal? (cdr a) (cdr b)))
568 (equal? '(a b c) '(a b c))
569 (equal? '(a b c) '(a b b))
571 (define member (lexpr (obj list test?)
576 (if (null? test?) (set! test? equal?) (set! test? (car test?)))
577 (if (test? obj (car list))
579 (member obj (cdr list) test?))
585 (member '(2) '((1) (2) (3)))
587 (member '(4) '((1) (2) (3)))
589 (define (memq obj list) (member obj list eq?))
595 (memq '(2) '((1) (2) (3)))
597 (define (memv obj list) (member obj list eqv?))
603 (memv '(2) '((1) (2) (3)))
605 (define (_assoc obj list test?)
608 (if (test? obj (caar list))
610 (_assoc obj (cdr list) test?)
615 (define (assq obj list) (_assoc obj list eq?))
616 (define (assv obj list) (_assoc obj list eqv?))
617 (define (assoc obj list) (_assoc obj list equal?))
619 (assq 'a '((a 1) (b 2) (c 3)))
620 (assv 'b '((a 1) (b 2) (c 3)))
621 (assoc '(c) '((a 1) (b 2) ((c) 3)))
623 (define char? integer?)
628 (define (char-upper-case? c) (<= #\A c #\Z))
630 (char-upper-case? #\a)
631 (char-upper-case? #\B)
632 (char-upper-case? #\0)
633 (char-upper-case? #\space)
635 (define (char-lower-case? c) (<= #\a c #\a))
637 (char-lower-case? #\a)
638 (char-lower-case? #\B)
639 (char-lower-case? #\0)
640 (char-lower-case? #\space)
642 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
644 (char-alphabetic? #\a)
645 (char-alphabetic? #\B)
646 (char-alphabetic? #\0)
647 (char-alphabetic? #\space)
649 (define (char-numeric? c) (<= #\0 c #\9))
654 (char-numeric? #\space)
656 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
658 (char-whitespace? #\a)
659 (char-whitespace? #\B)
660 (char-whitespace? #\0)
661 (char-whitespace? #\space)
663 (define (char->integer c) c)
664 (define (integer->char c) char-integer)
666 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
671 (char-upcase #\space)
673 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
678 (char-downcase #\space)
680 (define string (lexpr (chars) (list->string chars)))
685 (define map (lexpr (proc lists)
686 (let* ((args (lambda (lists)
688 (cons (caar lists) (args (cdr lists))))))
689 (next (lambda (lists)
691 (cons (cdr (car lists)) (next (cdr lists))))))
692 (domap (lambda (lists)
693 (if (null? (car lists)) ()
694 (cons (apply proc (args lists)) (domap (next lists)))
699 (map cadr '((a b) (d e) (g h)))
701 (define for-each (lexpr (proc lists)
702 (apply map proc lists)
705 (for-each display '("hello" " " "world" "\n"))
707 (define _string-ml (lambda (strings)
708 (if (null? strings) ()
709 (cons (string->list (car strings)) (_string-ml (cdr strings))))))
711 (define string-map (lexpr (proc strings)
712 (list->string (apply map proc (_string-ml strings))))))
714 (string-map (lambda (x) (+ 1 x)) "HAL")
716 (define string-for-each (lexpr (proc strings)
717 (apply for-each proc (_string-ml strings))))
719 (string-for-each write-char "IBM\n")
721 (define newline (lambda () (write-char #\newline)))
725 (call-with-current-continuation
727 (for-each (lambda (x)
731 '(54 0 37 -3 245 19))
736 ; `(q) -> (append (quote (q)))
737 ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
738 ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
742 `(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
744 (define repeat (macro (count rest)
745 `(let ((__count__ ,count))
746 (while (<= 0 (set! __count__ (- __count__ 1))) ,@rest))))
748 (repeat 2 (write 'hello))
749 (repeat 3 (write 'goodbye))
751 (define case (macro (test l)
753 ; construct the body of the
754 ; case, dealing with the
755 ; lambda version ( => lambda)
759 ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
763 ; Build the case elements, which is
764 ; simply a list of cond clauses
770 ((eq? (caar l) 'else)
771 `((else ,@(_unarrow (cdr (car l))))))
777 `((eqv? ,(caar l) __key__)
778 ,@(_unarrow (cdr (car l))))
783 ; now construct the overall
784 ; expression, using a lambda
785 ; to hold the computed value
786 ; of the test expression
789 (cond ,@(_case l))) ,test))))
791 (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))
793 ;(define number->string (lexpr (arg opt)
794 ; (let ((base (if (null? opt) 10 (car opt)))