2 ; Copyright © 2018 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 ; Advanced syntax, including vectors and floats
20 ((and (pair? a) (pair? b))
21 (and (equal? (car a) (car b))
22 (equal? (cdr a) (cdr b)))
24 ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
27 (equal? (vector-ref a i)
43 (equal? '(a b c) '(a b c))
44 (equal? '(a b c) '(a b b))
45 (equal? #(1 2 3) #(1 2 3))
46 (equal? #(1 2 3) #(4 5 6))
50 (define (constant? exp)
51 ; A constant value is either a pair starting with quote,
52 ; or anything which is neither a pair nor a symbol
55 (eq? (car exp) 'quote)
63 (define (combine-skeletons left right exp)
65 ((and (constant? left) (constant? right))
66 (cond ((and (eqv? (eval left) (car exp))
67 (eqv? (eval right) (cdr exp)))
71 (list 'quote (cons (eval left) (eval right)))
78 ((and (pair? right) (eq? (car right) 'list))
79 (cons 'list (cons left (cdr right)))
82 (list 'cons left right)
87 (define (expand-quasiquote exp nesting)
90 ; non cons -- constants
91 ; themselves, others are
95 (cond ((constant? exp)
104 ; check for an unquote exp and
105 ; add the param unquoted
107 ((and (eq? (car exp) 'unquote) (= (length exp) 2))
112 (combine-skeletons ''unquote
113 (expand-quasiquote (cdr exp) (- nesting 1))
118 ; nested quasi-quote --
119 ; construct the right
122 ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
123 (combine-skeletons ''quasiquote
124 (expand-quasiquote (cdr exp) (+ nesting 1))
128 ; unquote-splicing member,
129 ; compute the expansion of the
130 ; value and append the rest of
131 ; the quasiquote result to it
133 ((and (pair? (car exp))
134 (eq? (car (car exp)) 'unquote-splicing)
135 (= (length (car exp)) 2))
137 (list 'append (car (cdr (car exp)))
138 (expand-quasiquote (cdr exp) nesting))
141 (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
142 (expand-quasiquote (cdr exp) nesting)
147 ; for other lists, just glue
148 ; the expansion of the first
149 ; element to the expansion of
150 ; the rest of the list
152 (else (combine-skeletons (expand-quasiquote (car exp) nesting)
153 (expand-quasiquote (cdr exp) nesting)
158 (expand-quasiquote x 0)
163 ; `(q) -> (append (quote (q)))
164 ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
165 ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
168 `(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
170 ; define a set of local
171 ; variables all at once and
172 ; then evaluate a list of
175 ; (let (var-defines) sexprs)
177 ; where var-defines are either
187 ; (let ((x 1) (y)) (set! y (+ x 1)) y)
190 (macro (vars . exprs)
191 (define (make-names vars)
192 (cond ((not (null? vars))
193 (cons (car (car vars))
194 (make-names (cdr vars))))
199 ; the parameters to the lambda is a list
200 ; of nils of the right length
202 (define (make-vals vars)
203 (cond ((not (null? vars))
204 (cons (cond ((null? (cdr (car vars))) ())
206 (car (cdr (car vars))))
208 (make-vals (cdr vars))))
212 ; prepend the set operations
217 `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
222 (let ((x 1) (y)) (set! y 2) (+ x y))
226 (assv 'b '((a 1) (b 2) (c 3)))
228 (define when (macro (test . l) `(cond (,test ,@l))))
233 (define unless (macro (test . l) `(cond ((not ,test) ,@l))))
238 (define (cdar l) (cdr (car l)))
240 (cdar '((1 2) (3 4)))
242 (define (cddr l) (cdr (cdr l)))
246 (define (caddr l) (car (cdr (cdr l))))
250 (define (reverse list)
254 (_r (cdr old) (cons (car old) new))
267 (_m (- a 1) (cons b x))
283 (lambda (proc . lists)
285 (cond ((null? (car lists)) #t)
287 (apply proc (map car lists))
297 (for-each (lambda (b) (set! a (+ a b))) '(1 2 3))
301 (call-with-current-continuation
303 (for-each (lambda (x)
306 '(54 0 37 -3 245 19))
311 ; construct the body of the
312 ; case, dealing with the
313 ; lambda version ( => lambda)
317 ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
321 ; Build the case elements, which is
322 ; simply a list of cond clauses
330 ((eq? (caar l) 'else)
331 `((else ,@(_unarrow (cdr (car l))))))
337 `((eqv? ,(caar l) __key__)
338 ,@(_unarrow (cdr (car l))))
344 ; now construct the overall
345 ; expression, using a lambda
346 ; to hold the computed value
347 ; of the test expression
350 (cond ,@(_case l))) ,test)
354 (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else"))
355 (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else"))
356 (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else"))
357 (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else"))
358 (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else"))
361 (macro (vars test . cmds)
365 (if (null? (cddr (car v)))
367 (cons `(set! ,(caar v) ,(caddr (car v)))
373 `(let ,(map (lambda (v) (list (car v) (cadr v))) vars)
374 (while (not ,(car test))