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)
31 ((lambda (append-list append-lists)
35 (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))))
53 (append '(a b c) '(d e f) '(g h i))
82 ; execute to resolve macros
109 ; execute to resolve macros
117 ; A constant value is either a pair starting with quote,
118 ; or anything which is neither a pair nor a symbol
122 (eq? (car exp) 'quote)
130 (def! combine-skeletons
131 (lambda (left right exp)
133 ((and (constant? left) (constant? right))
134 (cond ((and (eqv? (eval left) (car exp))
135 (eqv? (eval right) (cdr exp)))
139 (list 'quote (cons (eval left) (eval right)))
146 ((and (pair? right) (eq? (car right) 'list))
147 (cons 'list (cons left (cdr right)))
150 (list 'cons left right)
156 (def! expand-quasiquote
157 (lambda (exp nesting)
160 ; non cons -- constants
161 ; themselves, others are
165 (cond ((constant? exp)
174 ; check for an unquote exp and
175 ; add the param unquoted
177 ((and (eq? (car exp) 'unquote) (= (length exp) 2))
182 (combine-skeletons ''unquote
183 (expand-quasiquote (cdr exp) (- nesting 1))
188 ; nested quasi-quote --
189 ; construct the right
192 ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
193 (combine-skeletons ''quasiquote
194 (expand-quasiquote (cdr exp) (+ nesting 1))
198 ; unquote-splicing member,
199 ; compute the expansion of the
200 ; value and append the rest of
201 ; the quasiquote result to it
203 ((and (pair? (car exp))
204 (eq? (car (car exp)) 'unquote-splicing)
205 (= (length (car exp)) 2))
207 (list 'append (car (cdr (car exp)))
208 (expand-quasiquote (cdr exp) nesting))
211 (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
212 (expand-quasiquote (cdr exp) nesting)
217 ; for other lists, just glue
218 ; the expansion of the first
219 ; element to the expansion of
220 ; the rest of the list
222 (else (combine-skeletons (expand-quasiquote (car exp) nesting)
223 (expand-quasiquote (cdr exp) nesting)
229 (expand-quasiquote x 0)
234 ; Define a variable without returning the value
235 ; Useful when defining functions to avoid
236 ; having lots of output generated.
238 ; Also accepts the alternate
239 ; form for defining lambdas of
240 ; (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)
266 ; basic list accessors
268 (define (caar l) (car (car l)))
270 (define (cadr l) (car (cdr l)))
272 (define (cdar l) (cdr (car l)))
274 (define (caddr l) (car (cdr (cdr l))))
276 (define (list-tail x k)
279 (list-tail (cdr x (- k 1)))
283 (define (list-ref x k)
284 (car (list-tail x k))
287 ; (if <condition> <if-true>)
288 ; (if <condition> <if-true> <if-false)
292 (cond ((null? (cdr args))
293 `(cond (,test ,(car args)))
296 `(cond (,test ,(car args))
304 (if (> 3 2) 'yes 'no)
305 (if (> 2 3) 'no 'yes)
308 ; simple math operators
310 (define zero? (macro (value rest) `(eq? ,value 0)))
316 (define positive? (macro (value rest) `(> ,value 0)))
321 (define negative? (macro (value rest) `(< ,value 0)))
326 (define (abs x) (if (>= x 0) x (- x)))
331 (define max (lexpr (first rest)
332 (while (not (null? rest))
333 (cond ((< first (car rest))
334 (set! first (car rest)))
336 (set! rest (cdr rest))
344 (define min (lexpr (first rest)
345 (while (not (null? rest))
346 (cond ((> first (car rest))
347 (set! first (car rest)))
349 (set! rest (cdr rest))
357 (define (even? x) (zero? (% x 2)))
364 (define (odd? x) (not (even? x)))
372 ; define a set of local
373 ; variables all at once and
374 ; then evaluate a list of
377 ; (let (var-defines) sexprs)
379 ; where var-defines are either
389 ; (let ((x 1) (y)) (set! y (+ x 1)) y)
393 (define (make-names vars)
394 (cond ((not (null? vars))
395 (cons (car (car vars))
396 (make-names (cdr vars))))
401 ; the parameters to the lambda is a list
402 ; of nils of the right length
404 (define (make-vals vars)
405 (cond ((not (null? vars))
406 (cons (cond ((null? (cdr (car vars))) ())
408 (car (cdr (car vars))))
410 (make-vals (cdr vars))))
414 ; prepend the set operations
419 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
424 (let ((x 1) (y)) (set! y 2) (+ x y))
426 ; define a set of local
427 ; variables one at a time and
428 ; then evaluate a list of
431 ; (let* (var-defines) sexprs)
433 ; where var-defines are either
443 ; (let* ((x 1) (y)) (set! y (+ x 1)) y)
449 ; make the list of names in the let
452 (define (make-names vars)
453 (cond ((not (null? vars))
454 (cons (car (car vars))
455 (make-names (cdr vars))))
460 ; the set of expressions is
461 ; the list of set expressions
463 ; expressions to evaluate
465 (define (make-exprs vars exprs)
466 (cond ((null? vars) exprs)
473 (cond ((null? (cdr (car vars))) ())
474 (else (cadr (car vars))))
476 (make-exprs (cdr vars) exprs)
482 ; the parameters to the lambda is a list
483 ; of nils of the right length
485 (define (make-nils vars)
486 (cond ((null? vars) ())
487 (else (cons () (make-nils (cdr vars))))
492 `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars))
496 (let* ((x 1) (y x)) (+ x y))
498 (define when (macro (test l) `(cond (,test ,@l))))
500 (when #t (write 'when))
502 (define unless (macro (test l) `(cond ((not ,test) ,@l))))
504 (unless #f (write 'unless))
506 (define (reverse list)
508 (while (not (null? list))
509 (set! result (cons (car list) result))
510 (set! list (cdr list))
517 (define (list-tail x k)
520 (list-tail (cdr x) (- k 1))))
522 (list-tail '(1 2 3) 2)
524 (define (list-ref x k) (car (list-tail x k)))
526 (list-ref '(1 2 3) 2)
532 ((and (pair? a) (pair? b))
533 (and (equal? (car a) (car b))
534 (equal? (cdr a) (cdr b)))
540 (equal? '(a b c) '(a b c))
541 (equal? '(a b c) '(a b b))
543 (define member (lexpr (obj list test?)
548 (if (null? test?) (set! test? equal?) (set! test? (car test?)))
549 (if (test? obj (car list))
551 (member obj (cdr list) test?))
557 (member '(2) '((1) (2) (3)))
559 (member '(4) '((1) (2) (3)))
561 (define (memq obj list) (member obj list eq?))
567 (memq '(2) '((1) (2) (3)))
569 (define (memv obj list) (member obj list eqv?))
575 (memv '(2) '((1) (2) (3)))
577 (define (_assoc obj list test?)
580 (if (test? obj (caar list))
582 (_assoc obj (cdr list) test?)
587 (define (assq obj list) (_assoc obj list eq?))
588 (define (assv obj list) (_assoc obj list eqv?))
589 (define (assoc obj list) (_assoc obj list equal?))
591 (assq 'a '((a 1) (b 2) (c 3)))
592 (assv 'b '((a 1) (b 2) (c 3)))
593 (assoc '(c) '((a 1) (b 2) ((c) 3)))
595 (define char? integer?)
600 (define (char-upper-case? c) (<= #\A c #\Z))
602 (char-upper-case? #\a)
603 (char-upper-case? #\B)
604 (char-upper-case? #\0)
605 (char-upper-case? #\space)
607 (define (char-lower-case? c) (<= #\a c #\a))
609 (char-lower-case? #\a)
610 (char-lower-case? #\B)
611 (char-lower-case? #\0)
612 (char-lower-case? #\space)
614 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
616 (char-alphabetic? #\a)
617 (char-alphabetic? #\B)
618 (char-alphabetic? #\0)
619 (char-alphabetic? #\space)
621 (define (char-numeric? c) (<= #\0 c #\9))
626 (char-numeric? #\space)
628 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
630 (char-whitespace? #\a)
631 (char-whitespace? #\B)
632 (char-whitespace? #\0)
633 (char-whitespace? #\space)
635 (define (char->integer c) c)
636 (define (integer->char c) char-integer)
638 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
643 (char-upcase #\space)
645 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
650 (char-downcase #\space)
652 (define string (lexpr (chars) (list->string chars)))
660 (cond ((null? lists) ())
662 (cons (caar lists) (args (cdr lists)))
667 (cond ((null? lists) ())
669 (cons (cdr (car lists)) (next (cdr lists)))
673 (define (domap lists)
674 (cond ((null? (car lists)) ())
676 (cons (apply proc (args lists)) (domap (next lists)))
684 (map cadr '((a b) (d e) (g h)))
686 (define for-each (lexpr (proc lists)
687 (apply map proc lists)
690 (for-each display '("hello" " " "world" "\n"))
692 (define _string-ml (lambda (strings)
693 (if (null? strings) ()
694 (cons (string->list (car strings)) (_string-ml (cdr strings))))))
696 (define string-map (lexpr (proc strings)
697 (list->string (apply map proc (_string-ml strings))))))
699 (string-map (lambda (x) (+ 1 x)) "HAL")
701 (define string-for-each (lexpr (proc strings)
702 (apply for-each proc (_string-ml strings))))
704 (string-for-each write-char "IBM\n")
706 (define newline (lambda () (write-char #\newline)))
710 (call-with-current-continuation
712 (for-each (lambda (x)
716 '(54 0 37 -3 245 19))
721 ; `(q) -> (append (quote (q)))
722 ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
723 ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
727 `(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
729 (define repeat (macro (count rest)
730 `(let ((__count__ ,count))
731 (while (<= 0 (set! __count__ (- __count__ 1))) ,@rest))))
733 (repeat 2 (write 'hello))
734 (repeat 3 (write 'goodbye))
736 (define case (macro (test l)
738 ; construct the body of the
739 ; case, dealing with the
740 ; lambda version ( => lambda)
744 ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
748 ; Build the case elements, which is
749 ; simply a list of cond clauses
755 ((eq? (caar l) 'else)
756 `((else ,@(_unarrow (cdr (car l))))))
762 `((eqv? ,(caar l) __key__)
763 ,@(_unarrow (cdr (car l))))
768 ; now construct the overall
769 ; expression, using a lambda
770 ; to hold the computed value
771 ; of the test expression
774 (cond ,@(_case l))) ,test))))
776 (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))
778 ;(define number->string (lexpr (arg opt)
779 ; (let ((base (if (null? opt) 10 (car opt)))