+;
+; Copyright © 2018 Keith Packard <keithp@keithp.com>
+;
+; This program is free software; you can redistribute it and/or modify
+; it under the terms of the GNU General Public License as published by
+; the Free Software Foundation, either version 2 of the License, or
+; (at your option) any later version.
+;
+; This program is distributed in the hope that it will be useful, but
+; WITHOUT ANY WARRANTY; without even the implied warranty of
+; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+; General Public License for more details.
+;
+; Advanced syntax, including vectors and floats
+
+(begin
+ (def! equal?
+ (lambda (a b)
+ (cond ((eq? a b) #t)
+ ((and (pair? a) (pair? b))
+ (and (equal? (car a) (car b))
+ (equal? (cdr a) (cdr b)))
+ )
+ ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
+ ((lambda (i l)
+ (while (and (< i l)
+ (equal? (vector-ref a i)
+ (vector-ref b i)))
+ (set! i (+ i 1)))
+ (eq? i l)
+ )
+ 0
+ (vector-length a)
+ )
+ )
+ (else #f)
+ )
+ )
+ )
+ 'equal?
+ )
+
+(_?_ (equal? '(a b c) '(a b c)) #t)
+(_?_ (equal? '(a b c) '(a b b)) #f)
+(_?_ (equal? #(1 2 3) #(1 2 3)) #t)
+(_?_ (equal? #(1 2 3) #(4 5 6)) #f)
+
+(define (_??_ a b)
+ (cond ((equal? a b)
+ a
+ )
+ (else
+ (exit 1)
+ )
+ )
+ )
+
+(define quasiquote
+ (macro (x)
+ (define (constant? exp)
+ ; A constant value is either a pair starting with quote,
+ ; or anything which is neither a pair nor a symbol
+
+ (cond ((pair? exp)
+ (eq? (car exp) 'quote)
+ )
+ (else
+ (not (symbol? exp))
+ )
+ )
+ )
+
+ (define (combine-skeletons left right exp)
+ (cond
+ ((and (constant? left) (constant? right))
+ (cond ((and (eqv? (eval left) (car exp))
+ (eqv? (eval right) (cdr exp)))
+ (list 'quote exp)
+ )
+ (else
+ (list 'quote (cons (eval left) (eval right)))
+ )
+ )
+ )
+ ((null? right)
+ (list 'list left)
+ )
+ ((and (pair? right) (eq? (car right) 'list))
+ (cons 'list (cons left (cdr right)))
+ )
+ (else
+ (list 'cons left right)
+ )
+ )
+ )
+
+ (define (expand-quasiquote exp nesting)
+ (cond
+
+ ; non cons -- constants
+ ; themselves, others are
+ ; quoted
+
+ ((not (pair? exp))
+ (cond ((constant? exp)
+ exp
+ )
+ (else
+ (list 'quote exp)
+ )
+ )
+ )
+
+ ; check for an unquote exp and
+ ; add the param unquoted
+
+ ((and (eq? (car exp) 'unquote) (= (length exp) 2))
+ (cond ((= nesting 0)
+ (car (cdr exp))
+ )
+ (else
+ (combine-skeletons ''unquote
+ (expand-quasiquote (cdr exp) (- nesting 1))
+ exp))
+ )
+ )
+
+ ; nested quasi-quote --
+ ; construct the right
+ ; expression
+
+ ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
+ (combine-skeletons ''quasiquote
+ (expand-quasiquote (cdr exp) (+ nesting 1))
+ exp))
+
+ ; check for an
+ ; unquote-splicing member,
+ ; compute the expansion of the
+ ; value and append the rest of
+ ; the quasiquote result to it
+
+ ((and (pair? (car exp))
+ (eq? (car (car exp)) 'unquote-splicing)
+ (= (length (car exp)) 2))
+ (cond ((= nesting 0)
+ (list 'append (car (cdr (car exp)))
+ (expand-quasiquote (cdr exp) nesting))
+ )
+ (else
+ (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
+ (expand-quasiquote (cdr exp) nesting)
+ exp))
+ )
+ )
+
+ ; for other lists, just glue
+ ; the expansion of the first
+ ; element to the expansion of
+ ; the rest of the list
+
+ (else (combine-skeletons (expand-quasiquote (car exp) nesting)
+ (expand-quasiquote (cdr exp) nesting)
+ exp)
+ )
+ )
+ )
+ (expand-quasiquote x 0)
+ )
+ )
+
+ ; `q -> (quote q)
+ ; `(q) -> (append (quote (q)))
+ ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
+ ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
+
+
+(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))
+
+ ; define a set of local
+ ; variables all at once and
+ ; then evaluate a list of
+ ; sexprs
+ ;
+ ; (let (var-defines) sexprs)
+ ;
+ ; where var-defines are either
+ ;
+ ; (name value)
+ ;
+ ; or
+ ;
+ ; (name)
+ ;
+ ; e.g.
+ ;
+ ; (let ((x 1) (y)) (set! y (+ x 1)) y)
+
+(define let
+ (macro (vars . exprs)
+ (define (make-names vars)
+ (cond ((not (null? vars))
+ (cons (car (car vars))
+ (make-names (cdr vars))))
+ (else ())
+ )
+ )
+
+ ; the parameters to the lambda is a list
+ ; of nils of the right length
+
+ (define (make-vals vars)
+ (cond ((not (null? vars))
+ (cons (cond ((null? (cdr (car vars))) ())
+ (else
+ (car (cdr (car vars))))
+ )
+ (make-vals (cdr vars))))
+ (else ())
+ )
+ )
+ ; prepend the set operations
+ ; to the expressions
+
+ ; build the lambda.
+
+ `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
+ )
+ )
+
+
+(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3)
+
+(define when (macro (test . l) `(cond (,test ,@l))))
+
+(_??_ (when #t (+ 1 2)) 3)
+(_??_ (when #f (+ 1 2)) #f)
+
+(define unless (macro (test . l) `(cond ((not ,test) ,@l))))
+
+(_??_ (unless #f (+ 2 3)) 5)
+(_??_ (unless #t (+ 2 3)) #f)
+
+(define (cdar l) (cdr (car l)))
+
+(_??_ (cdar '((1 2) (3 4))) '(2))
+
+(define (cddr l) (cdr (cdr l)))
+
+(_??_ (cddr '(1 2 3)) '(3))
+
+(define (caddr l) (car (cdr (cdr l))))
+
+(_??_ (caddr '(1 2 3 4)) 3)
+
+(define (reverse list)
+ (define (_r old new)
+ (if (null? old)
+ new
+ (_r (cdr old) (cons (car old) new))
+ )
+ )
+ (_r list ())
+ )
+
+(_??_ (reverse '(1 2 3)) '(3 2 1))
+
+(define make-list
+ (lambda (a . b)
+ (define (_m a x)
+ (if (zero? a)
+ x
+ (_m (- a 1) (cons b x))
+ )
+ )
+ (if (null? b)
+ (set! b #f)
+ (set! b (car b))
+ )
+ (_m a '())
+ )
+ )
+
+(_??_ (make-list 10 'a) '(a a a a a a a a a a))
+
+(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f))
+
+(define for-each
+ (lambda (proc . lists)
+ (define (_f lists)
+ (cond ((null? (car lists)) #t)
+ (else
+ (apply proc (map car lists))
+ (_f (map cdr lists))
+ )
+ )
+ )
+ (_f lists)
+ )
+ )
+
+(_??_ (let ((a 0))
+ (for-each (lambda (b) (set! a (+ a b))) '(1 2 3))
+ a
+ )
+ 6)
+
+(_??_ (call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x)
+ (if (negative? x)
+ (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
+ -3)
+
+(define case
+ (macro (test . l)
+ ; construct the body of the
+ ; case, dealing with the
+ ; lambda version ( => lambda)
+
+ (define (_unarrow l)
+ (cond ((null? l) l)
+ ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
+ (else l))
+ )
+
+ ; Build the case elements, which is
+ ; simply a list of cond clauses
+
+ (define (_case l)
+
+ (cond ((null? l) ())
+
+ ; else case
+
+ ((eq? (caar l) 'else)
+ `((else ,@(_unarrow (cdr (car l))))))
+
+ ; regular case
+
+ (else
+ (cons
+ `((eqv? ,(caar l) __key__)
+ ,@(_unarrow (cdr (car l))))
+ (_case (cdr l)))
+ )
+ )
+ )
+
+ ; now construct the overall
+ ; expression, using a lambda
+ ; to hold the computed value
+ ; of the test expression
+
+ `((lambda (__key__)
+ (cond ,@(_case l))) ,test)
+ )
+ )
+
+(_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "one")
+(_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "two")
+(_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) "three")
+(_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "else")
+(_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "twelve")
+
+(define do
+ (macro (vars test . cmds)
+ (define (_step v)
+ (if (null? v)
+ '()
+ (if (null? (cddr (car v)))
+ (_step (cdr v))
+ (cons `(set! ,(caar v) ,(caddr (car v)))
+ (_step (cdr v))
+ )
+ )
+ )
+ )
+ `(let ,(map (lambda (v) (list (car v) (cadr v))) vars)
+ (while (not ,(car test))
+ ,@cmds
+ ,@(_step vars)
+ )
+ ,@(cdr test)
+ )
+ )
+ )
+
+(_??_ (do ((x 1 (+ x 1))
+ (y 0)
+ )
+ ((= x 10) y)
+ (set! y (+ y x))
+ )
+ 45)
+
+(_??_ (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)) #(0 1 2 3 4))
projects / fw / altos / commitdiff