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) (lexpr (l) l))
20 (macro (name value rest)
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
108 ; execute to resolve macros
116 ; A constant value is either a pair starting with quote,
117 ; or anything which is neither a pair nor a symbol
121 (eq? (car exp) 'quote)
129 (def! combine-skeletons
130 (lambda (left right exp)
132 ((and (constant? left) (constant? right))
133 (cond ((and (eqv? (eval left) (car exp))
134 (eqv? (eval right) (cdr exp)))
138 (list 'quote (cons (eval left) (eval right)))
145 ((and (pair? right) (eq? (car right) 'list))
146 (cons 'list (cons left (cdr right)))
149 (list 'cons left right)
155 (def! expand-quasiquote
156 (lambda (exp nesting)
159 ; non cons -- constants
160 ; themselves, others are
164 (cond ((constant? exp)
173 ; check for an unquote exp and
174 ; add the param unquoted
176 ((and (eq? (car exp) 'unquote) (= (length exp) 2))
181 (combine-skeletons ''unquote
182 (expand-quasiquote (cdr exp) (- nesting 1))
187 ; nested quasi-quote --
188 ; construct the right
191 ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
192 (combine-skeletons ''quasiquote
193 (expand-quasiquote (cdr exp) (+ nesting 1))
197 ; unquote-splicing member,
198 ; compute the expansion of the
199 ; value and append the rest of
200 ; the quasiquote result to it
202 ((and (pair? (car exp))
203 (eq? (car (car exp)) 'unquote-splicing)
204 (= (length (car exp)) 2))
206 (list 'append (car (cdr (car exp)))
207 (expand-quasiquote (cdr exp) nesting))
210 (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
211 (expand-quasiquote (cdr exp) nesting)
216 ; for other lists, just glue
217 ; the expansion of the first
218 ; element to the expansion of
219 ; the rest of the list
221 (else (combine-skeletons (expand-quasiquote (car exp) nesting)
222 (expand-quasiquote (cdr exp) nesting)
228 (expand-quasiquote x 0)
233 ; Define a variable without returning the value
234 ; Useful when defining functions to avoid
235 ; having lots of output generated.
237 ; Also accepts the alternate
238 ; form for defining lambdas of
239 ; (define (name x y z) sexprs ...)
245 ; check for alternate lambda definition form
254 (set! first (car first))
257 (set! rest (car rest))
261 (def (quote ,first) ,rest)
268 ; basic list accessors
270 (define (caar l) (car (car l)))
272 (define (cadr l) (car (cdr l)))
274 (define (cdar l) (cdr (car l)))
276 (define (caddr l) (car (cdr (cdr l))))
278 (define (list-tail x k)
281 (list-tail (cdr x (- k 1)))
285 (define (list-ref x k)
286 (car (list-tail x k))
289 ; (if <condition> <if-true>)
290 ; (if <condition> <if-true> <if-false)
294 (cond ((null? (cdr args))
295 `(cond (,test ,(car args)))
298 `(cond (,test ,(car args))
306 (if (> 3 2) 'yes 'no)
307 (if (> 2 3) 'no 'yes)
310 ; simple math operators
312 (define zero? (macro (value rest) `(eq? ,value 0)))
318 (define positive? (macro (value rest) `(> ,value 0)))
323 (define negative? (macro (value rest) `(< ,value 0)))
328 (define (abs x) (if (>= x 0) x (- x)))
333 (define max (lexpr (first rest)
334 (while (not (null? rest))
335 (cond ((< first (car rest))
336 (set! first (car rest)))
338 (set! rest (cdr rest))
346 (define min (lexpr (first rest)
347 (while (not (null? rest))
348 (cond ((> first (car rest))
349 (set! first (car rest)))
351 (set! rest (cdr rest))
359 (define (even? x) (zero? (% x 2)))
366 (define (odd? x) (not (even? x)))
374 ; define a set of local
375 ; variables all at once and
376 ; then evaluate a list of
379 ; (let (var-defines) sexprs)
381 ; where var-defines are either
391 ; (let ((x 1) (y)) (set! y (+ x 1)) y)
395 (define (make-names vars)
396 (cond ((not (null? vars))
397 (cons (car (car vars))
398 (make-names (cdr vars))))
403 ; the parameters to the lambda is a list
404 ; of nils of the right length
406 (define (make-vals vars)
407 (cond ((not (null? vars))
408 (cons (cond ((null? (cdr (car vars))) ())
410 (car (cdr (car vars))))
412 (make-vals (cdr vars))))
416 ; prepend the set operations
421 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
426 (let ((x 1) (y)) (set! y 2) (+ x y))
428 ; define a set of local
429 ; variables one at a time and
430 ; then evaluate a list of
433 ; (let* (var-defines) sexprs)
435 ; where var-defines are either
445 ; (let* ((x 1) (y)) (set! y (+ x 1)) y)
451 ; make the list of names in the let
454 (define (make-names vars)
455 (cond ((not (null? vars))
456 (cons (car (car vars))
457 (make-names (cdr vars))))
462 ; the set of expressions is
463 ; the list of set expressions
465 ; expressions to evaluate
467 (define (make-exprs vars exprs)
468 (cond ((null? vars) exprs)
475 (cond ((null? (cdr (car vars))) ())
476 (else (cadr (car vars))))
478 (make-exprs (cdr vars) exprs)
484 ; the parameters to the lambda is a list
485 ; of nils of the right length
487 (define (make-nils vars)
488 (cond ((null? vars) ())
489 (else (cons () (make-nils (cdr vars))))
494 `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars))
498 (let* ((x 1) (y x)) (+ x y))
500 (define when (macro (test l) `(cond (,test ,@l))))
502 (when #t (write 'when))
504 (define unless (macro (test l) `(cond ((not ,test) ,@l))))
506 (unless #f (write 'unless))
508 (define (reverse list)
510 (while (not (null? list))
511 (set! result (cons (car list) result))
512 (set! list (cdr list))
519 (define (list-tail x k)
522 (list-tail (cdr x) (- k 1))))
524 (list-tail '(1 2 3) 2)
526 (define (list-ref x k) (car (list-tail x k)))
528 (list-ref '(1 2 3) 2)
534 ((and (pair? a) (pair? b))
535 (and (equal? (car a) (car b))
536 (equal? (cdr a) (cdr b)))
542 (equal? '(a b c) '(a b c))
543 (equal? '(a b c) '(a b b))
545 (define member (lexpr (obj list test?)
550 (if (null? test?) (set! test? equal?) (set! test? (car test?)))
551 (if (test? obj (car list))
553 (member obj (cdr list) test?))
559 (member '(2) '((1) (2) (3)))
561 (member '(4) '((1) (2) (3)))
563 (define (memq obj list) (member obj list eq?))
569 (memq '(2) '((1) (2) (3)))
571 (define (memv obj list) (member obj list eqv?))
577 (memv '(2) '((1) (2) (3)))
579 (define (_assoc obj list test?)
582 (if (test? obj (caar list))
584 (_assoc obj (cdr list) test?)
589 (define (assq obj list) (_assoc obj list eq?))
590 (define (assv obj list) (_assoc obj list eqv?))
591 (define (assoc obj list) (_assoc obj list equal?))
593 (assq 'a '((a 1) (b 2) (c 3)))
594 (assv 'b '((a 1) (b 2) (c 3)))
595 (assoc '(c) '((a 1) (b 2) ((c) 3)))
597 (define char? integer?)
602 (define (char-upper-case? c) (<= #\A c #\Z))
604 (char-upper-case? #\a)
605 (char-upper-case? #\B)
606 (char-upper-case? #\0)
607 (char-upper-case? #\space)
609 (define (char-lower-case? c) (<= #\a c #\a))
611 (char-lower-case? #\a)
612 (char-lower-case? #\B)
613 (char-lower-case? #\0)
614 (char-lower-case? #\space)
616 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
618 (char-alphabetic? #\a)
619 (char-alphabetic? #\B)
620 (char-alphabetic? #\0)
621 (char-alphabetic? #\space)
623 (define (char-numeric? c) (<= #\0 c #\9))
628 (char-numeric? #\space)
630 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
632 (char-whitespace? #\a)
633 (char-whitespace? #\B)
634 (char-whitespace? #\0)
635 (char-whitespace? #\space)
637 (define (char->integer c) c)
638 (define (integer->char c) char-integer)
640 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
645 (char-upcase #\space)
647 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
652 (char-downcase #\space)
654 (define string (lexpr (chars) (list->string chars)))
662 (cond ((null? lists) ())
664 (cons (caar lists) (args (cdr lists)))
669 (cond ((null? lists) ())
671 (cons (cdr (car lists)) (next (cdr lists)))
675 (define (domap lists)
676 (cond ((null? (car lists)) ())
678 (cons (apply proc (args lists)) (domap (next lists)))
686 (map cadr '((a b) (d e) (g h)))
688 (define for-each (lexpr (proc lists)
689 (apply map proc lists)
692 (for-each display '("hello" " " "world" "\n"))
694 (define (_string-ml strings)
695 (if (null? strings) ()
696 (cons (string->list (car strings)) (_string-ml (cdr strings)))
700 (define string-map (lexpr (proc strings)
701 (list->string (apply map proc (_string-ml strings))))))
703 (string-map (lambda (x) (+ 1 x)) "HAL")
705 (define string-for-each (lexpr (proc strings)
706 (apply for-each proc (_string-ml strings))))
708 (string-for-each write-char "IBM\n")
710 (define (newline) (write-char #\newline))
714 (call-with-current-continuation
716 (for-each (lambda (x)
720 '(54 0 37 -3 245 19))
725 ; `(q) -> (append (quote (q)))
726 ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
727 ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
731 `(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
736 (define counter '__count__)
738 (set! counter (car count))
739 (set! count (cadr count))
745 (while (< ,counter __max__)
747 (set! ,counter (+ ,counter 1))
753 (repeat 2 (write 'hello))
754 (repeat (x 3) (write 'goodbye x))
758 ; construct the body of the
759 ; case, dealing with the
760 ; lambda version ( => lambda)
764 ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
768 ; Build the case elements, which is
769 ; simply a list of cond clauses
777 ((eq? (caar l) 'else)
778 `((else ,@(_unarrow (cdr (car l))))))
784 `((eqv? ,(caar l) __key__)
785 ,@(_unarrow (cdr (car l))))
791 ; now construct the overall
792 ; expression, using a lambda
793 ; to hold the computed value
794 ; of the test expression
797 (cond ,@(_case l))) ,test)
801 (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))
803 ;(define number->string (lexpr (arg opt)
804 ; (let ((base (if (null? opt) 10 (car opt)))