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 and then evaluate
380 ; (let (var-defines) sexprs)
382 ; where var-defines are either
392 ; (let ((x 1) (y)) (set! y (+ x 1)) y)
394 (define let (macro (vars exprs)
395 ((lambda (make-names make-exprs make-nils)
398 ; make the list of names in the let
401 (set! make-names (lambda (vars)
402 (cond ((not (null? vars))
403 (cons (car (car vars))
404 (make-names (cdr vars))))
410 ; the set of expressions is
411 ; the list of set expressions
413 ; expressions to evaluate
415 (set! make-exprs (lambda (vars exprs)
416 (cond ((not (null? vars))
422 (cond ((null? (cdr (car vars))) ())
423 (else (cadr (car vars))))
425 (make-exprs (cdr vars) exprs)
433 ; the parameters to the lambda is a list
434 ; of nils of the right length
436 (set! make-nils (lambda (vars)
437 (cond ((not (null? vars)) (cons () (make-nils (cdr vars))))
442 ; prepend the set operations
445 (set! exprs (make-exprs vars exprs))
449 (cons (cons 'lambda (cons (make-names vars) exprs))
464 (define when (macro (test l)
469 (when #t (display 'when))
471 (define unless (macro (test l)
474 (cons (list not test) l))))
476 (unless #f (display 'unless))
478 (define (reverse list)
480 (while (not (null? list))
481 (set! result (cons (car list) result))
482 (set! list (cdr list))
489 (define (list-tail x k)
492 (list-tail (cdr x) (- k 1)))))
494 (list-tail '(1 2 3) 2)
496 (define (list-ref x k) (car (list-tail x k)))
498 (list-ref '(1 2 3) 2)
504 ((and (pair? a) (pair? b))
505 (and (equal? (car a) (car b))
506 (equal? (cdr a) (cdr b)))
512 (equal? '(a b c) '(a b c))
513 (equal? '(a b c) '(a b b))
515 (define (_member obj list test?)
518 (if (test? obj (car list))
520 (memq obj (cdr list)))))
522 (define (memq obj list) (_member obj list eq?))
528 (define (memv obj list) (_member obj list eqv?))
534 (define (member obj list) (_member obj list equal?))
536 (member '(2) '((1) (2) (3)))
538 (member '(4) '((1) (2) (3)))
540 (define (_assoc obj list test?)
543 (if (test? obj (caar list))
545 (_assoc obj (cdr list) test?)
550 (define (assq obj list) (_assoc obj list eq?))
551 (define (assv obj list) (_assoc obj list eqv?))
552 (define (assoc obj list) (_assoc obj list equal?))
554 (assq 'a '((a 1) (b 2) (c 3)))
555 (assv 'b '((a 1) (b 2) (c 3)))
556 (assoc '(c) '((a 1) (b 2) ((c) 3)))
558 (define char? integer?)
563 (define (char-upper-case? c) (<= #\A c #\Z))
565 (char-upper-case? #\a)
566 (char-upper-case? #\B)
567 (char-upper-case? #\0)
568 (char-upper-case? #\space)
570 (define (char-lower-case? c) (<= #\a c #\a))
572 (char-lower-case? #\a)
573 (char-lower-case? #\B)
574 (char-lower-case? #\0)
575 (char-lower-case? #\space)
577 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
579 (char-alphabetic? #\a)
580 (char-alphabetic? #\B)
581 (char-alphabetic? #\0)
582 (char-alphabetic? #\space)
584 (define (char-numeric? c) (<= #\0 c #\9))
589 (char-numeric? #\space)
591 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
593 (char-whitespace? #\a)
594 (char-whitespace? #\B)
595 (char-whitespace? #\0)
596 (char-whitespace? #\space)
598 (define (char->integer c) c)
599 (define (integer->char c) char-integer)
601 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
606 (char-upcase #\space)
608 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
613 (char-downcase #\space)
615 (define string (lexpr (chars) (list->string chars)))
620 (define map (lexpr (proc lists)
621 (let ((args (lambda (lists)
623 (cons (caar lists) (args (cdr lists))))))
624 (next (lambda (lists)
626 (cons (cdr (car lists)) (next (cdr lists))))))
627 (domap (lambda (lists)
628 (if (null? (car lists)) ()
629 (cons (apply proc (args lists)) (domap (next lists)))
634 (map cadr '((a b) (d e) (g h)))
636 (define for-each (lexpr (proc lists)
637 (apply map proc lists)
640 (for-each display '("hello" " " "world" "\n"))
642 (define _string-ml (lambda (strings)
643 (if (null? strings) ()
644 (cons (string->list (car strings)) (_string-ml (cdr strings))))))
646 (define string-map (lexpr (proc strings)
647 (list->string (apply map proc (_string-ml strings))))))
649 (string-map (lambda (x) (+ 1 x)) "HAL")
651 (define string-for-each (lexpr (proc strings)
652 (apply for-each proc (_string-ml strings))))
654 (string-for-each write-char "IBM\n")
656 (define newline (lambda () (write-char #\newline)))
660 (call-with-current-continuation
662 (for-each (lambda (x)
666 '(54 0 37 -3 245 19))
671 ; `(q) -> (append (quote (q)))
672 ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
673 ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
677 `(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
679 (define repeat (macro (count rest)
680 `(let ((__count__ ,count))
681 (while (<= 0 (set! __count__ (- __count__ 1))) ,@rest))))
683 (repeat 2 (write 'hello))
684 (repeat 3 (write 'goodbye))
686 (define case (macro (test l)
688 ; construct the body of the
689 ; case, dealing with the
690 ; lambda version ( => lambda)
694 ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
698 ; Build the case elements, which is
699 ; simply a list of cond clauses
705 ((eq? (caar l) 'else)
706 `((else ,@(_unarrow (cdr (car l))))))
712 `((eqv? ,(caar l) __key__)
713 ,@(_unarrow (cdr (car l))))
718 ; now construct the overall
719 ; expression, using a lambda
720 ; to hold the computed value
721 ; of the test expression
724 (cond ,@(_case l))) ,test))))
726 (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))
728 ;(define number->string (lexpr (arg opt)
729 ; (let ((base (if (null? opt) 10 (car opt)))