diff options
Diffstat (limited to 'src/scheme/ao_scheme_const.scheme')
| -rw-r--r-- | src/scheme/ao_scheme_const.scheme | 916 |
1 files changed, 0 insertions, 916 deletions
diff --git a/src/scheme/ao_scheme_const.scheme b/src/scheme/ao_scheme_const.scheme deleted file mode 100644 index 17dc51a9..00000000 --- a/src/scheme/ao_scheme_const.scheme +++ /dev/null @@ -1,916 +0,0 @@ -; -; Copyright © 2016 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. -; -; Lisp code placed in ROM - -(def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1))))) - - ; return a list containing all of the arguments -(def (quote list) (lambda l l)) - -(def (quote def!) - (macro (name value) - (list - def - (list quote name) - value) - ) - ) - -(begin - (def! append - (lambda args - (def! append-list - (lambda (a b) - (cond ((null? a) b) - (else (cons (car a) (append-list (cdr a) b))) - ) - ) - ) - - (def! append-lists - (lambda (lists) - (cond ((null? lists) lists) - ((null? (cdr lists)) (car lists)) - (else (append-list (car lists) (append-lists (cdr lists)))) - ) - ) - ) - (append-lists args) - ) - ) - 'append) - -(append '(a b c) '(d e f) '(g h i)) - - ; boolean operators - -(begin - (def! or - (macro l - (def! _or - (lambda (l) - (cond ((null? l) #f) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l)) - (list - 'else - (_or (cdr l)) - ) - ) - ) - ) - ) - ) - (_or l))) - 'or) - - ; execute to resolve macros - -(_?_ (or #f #t) #t) - -(begin - (def! and - (macro l - (def! _and - (lambda (l) - (cond ((null? l) #t) - ((null? (cdr l)) - (car l)) - (else - (list - cond - (list - (car l) - (_and (cdr l)) - ) - ) - ) - ) - ) - ) - (_and l) - ) - ) - 'and) - - ; execute to resolve macros - -(_?_ (and #t #f) #f) - - ; recursive equality - -(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) - -(def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit))))) - -(begin - (def! quasiquote - (macro (x) - (def! constant? - ; A constant value is either a pair starting with quote, - ; or anything which is neither a pair nor a symbol - - (lambda (exp) - (cond ((pair? exp) - (eq? (car exp) 'quote) - ) - (else - (not (symbol? exp)) - ) - ) - ) - ) - (def! combine-skeletons - (lambda (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) - ) - ) - ) - ) - - (def! expand-quasiquote - (lambda (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) - ) - ) - ) - ) - (def! result (expand-quasiquote x 0)) - result - ) - ) - 'quasiquote) - - ; - ; Define a variable without returning the value - ; Useful when defining functions to avoid - ; having lots of output generated. - ; - ; Also accepts the alternate - ; form for defining lambdas of - ; (define (name x y z) sexprs ...) - ; - -(begin - (def! define - (macro (first . rest) - ; check for alternate lambda definition form - - (cond ((pair? first) - (set! rest - (append - (list - 'lambda - (cdr first)) - rest)) - (set! first (car first)) - ) - (else - (set! rest (car rest)) - ) - ) - (def! result `(,begin - (,def (,quote ,first) ,rest) - (,quote ,first)) - ) - result - ) - ) - 'define - ) - - ; basic list accessors - -(define (caar l) (car (car l))) - -(_??_ (caar '((1 2 3) (4 5 6))) 1) - -(define (cadr l) (car (cdr l))) - -(_??_ (cadr '(1 2 3 4 5 6)) 2) - -(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) - - ; (if <condition> <if-true>) - ; (if <condition> <if-true> <if-false) - -(define if - (macro (test . args) - (cond ((null? (cdr args)) - `(cond (,test ,(car args))) - ) - (else - `(cond (,test ,(car args)) - (else ,(cadr args))) - ) - ) - ) - ) - -(_??_ (if (> 3 2) 'yes) 'yes) -(_??_ (if (> 3 2) 'yes 'no) 'yes) -(_??_ (if (> 2 3) 'no 'yes) 'yes) -(_??_ (if (> 2 3) 'no) #f) - - ; simple math operators - -(define zero? (macro (value) `(eq? ,value 0))) - -(_??_ (zero? 1) #f) -(_??_ (zero? 0) #t) -(_??_ (zero? "hello") #f) - -(define positive? (macro (value) `(> ,value 0))) - -(_??_ (positive? 12) #t) -(_??_ (positive? -12) #f) - -(define negative? (macro (value) `(< ,value 0))) - -(_??_ (negative? 12) #f) -(_??_ (negative? -12) #t) - -(define (abs x) (if (>= x 0) x (- x))) - -(_??_ (abs 12) 12) -(_??_ (abs -12) 12) - -(define max (lambda (first . rest) - (while (not (null? rest)) - (cond ((< first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(_??_ (max 1 2 3) 3) -(_??_ (max 3 2 1) 3) - -(define min (lambda (first . rest) - (while (not (null? rest)) - (cond ((> first (car rest)) - (set! first (car rest))) - ) - (set! rest (cdr rest)) - ) - first) - ) - -(_??_ (min 1 2 3) 1) -(_??_ (min 3 2 1) 1) - -(define (even? x) (zero? (% x 2))) - -(_??_ (even? 2) #t) -(_??_ (even? -2) #t) -(_??_ (even? 3) #f) -(_??_ (even? -1) #f) - -(define (odd? x) (not (even? x))) - -(_??_ (odd? 2) #f) -(_??_ (odd? -2) #f) -(_??_ (odd? 3) #t) -(_??_ (odd? -1) #t) - -(_??_ (list-tail '(1 2 3 . 4) 3) 4) - -(define (list-ref x k) - (car (list-tail x k)) - ) - -(_??_ (list-ref '(1 2 3 4) 3) 4) - -(define (list-set! x k v) - (set-car! (list-tail x k) v) - x) - -(list-set! (list 1 2 3) 1 4) - - ; 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 a set of local - ; variables one at a time 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 letrec - (macro (vars . exprs) - - ; - ; make the list of names in the let - ; - - (define (make-names vars) - (cond ((not (null? vars)) - (cons (car (car vars)) - (make-names (cdr vars)))) - (else ()) - ) - ) - - ; the set of expressions is - ; the list of set expressions - ; pre-pended to the - ; expressions to evaluate - - (define (make-exprs vars exprs) - (cond ((null? vars) exprs) - (else - (cons - (list set - (list quote - (car (car vars)) - ) - (cond ((null? (cdr (car vars))) ()) - (else (cadr (car vars)))) - ) - (make-exprs (cdr vars) exprs) - ) - ) - ) - ) - - ; the parameters to the lambda is a list - ; of nils of the right length - - (define (make-nils vars) - (cond ((null? vars) ()) - (else (cons () (make-nils (cdr vars)))) - ) - ) - ; build the lambda. - - `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars)) - ) - ) - -(_??_ (letrec ((x 1) (y x)) (+ x y)) 2) - - ; letrec is sufficient for let* - -(define let* letrec) - -(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 (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 member (lambda (obj list . test?) - (cond ((null? list) - #f - ) - (else - (if (null? test?) (set! test? equal?) (set! test? (car test?))) - (if (test? obj (car list)) - list - (member obj (cdr list) test?)) - ) - ) - ) - ) - -(_??_ (member '(2) '((1) (2) (3))) '((2) (3))) - -(_??_ (member '(4) '((1) (2) (3))) #f) - -(define (memq obj list) (member obj list eq?)) - -(_??_ (memq 2 '(1 2 3)) '(2 3)) - -(_??_ (memq 4 '(1 2 3)) #f) - -(_??_ (memq '(2) '((1) (2) (3))) #f) - -(define (memv obj list) (member obj list eqv?)) - -(_??_ (memv 2 '(1 2 3)) '(2 3)) - -(_??_ (memv 4 '(1 2 3)) #f) - -(_??_ (memv '(2) '((1) (2) (3))) #f) - -(define (assoc obj list . compare) - (if (null? compare) - (set! compare equal?) - (set! compare (car compare)) - ) - (if (null? list) - #f - (if (compare obj (caar list)) - (car list) - (assoc obj (cdr list) compare) - ) - ) - ) - -(define (assq obj list) (assoc obj list eq?)) -(define (assv obj list) (assoc obj list eqv?)) - -(_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1)) -(_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2)) -(_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3)) - -(define char? integer?) - -(_??_ (char? #\q) #t) -(_??_ (char? "h") #f) - -(define (char-upper-case? c) (<= #\A c #\Z)) - -(_??_ (char-upper-case? #\a) #f) -(_??_ (char-upper-case? #\B) #t) -(_??_ (char-upper-case? #\0) #f) -(_??_ (char-upper-case? #\space) #f) - -(define (char-lower-case? c) (<= #\a c #\a)) - -(_??_ (char-lower-case? #\a) #t) -(_??_ (char-lower-case? #\B) #f) -(_??_ (char-lower-case? #\0) #f) -(_??_ (char-lower-case? #\space) #f) - -(define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c))) - -(_??_ (char-alphabetic? #\a) #t) -(_??_ (char-alphabetic? #\B) #t) -(_??_ (char-alphabetic? #\0) #f) -(_??_ (char-alphabetic? #\space) #f) - -(define (char-numeric? c) (<= #\0 c #\9)) - -(_??_ (char-numeric? #\a) #f) -(_??_ (char-numeric? #\B) #f) -(_??_ (char-numeric? #\0) #t) -(_??_ (char-numeric? #\space) #f) - -(define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c))) - -(_??_ (char-whitespace? #\a) #f) -(_??_ (char-whitespace? #\B) #f) -(_??_ (char-whitespace? #\0) #f) -(_??_ (char-whitespace? #\space) #t) - -(define char->integer (macro (v) v)) -(define integer->char char->integer) - -(define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c)) - -(_??_ (char-upcase #\a) #\A) -(_??_ (char-upcase #\B) #\B) -(_??_ (char-upcase #\0) #\0) -(_??_ (char-upcase #\space) #\space) - -(define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c)) - -(_??_ (char-downcase #\a) #\a) -(_??_ (char-downcase #\B) #\b) -(_??_ (char-downcase #\0) #\0) -(_??_ (char-downcase #\space) #\space) - -(define (digit-value c) - (if (char-numeric? c) - (- c #\0) - #f) - ) - -(_??_ (digit-value #\1) 1) -(_??_ (digit-value #\a) #f) - -(define string (lambda chars (list->string chars))) - -(_??_ (string #\a #\b #\c) "abc") - -(_??_ (apply cons '(a b)) '(a . b)) - -(define map - (lambda (proc . lists) - (define (_a lists) - (cond ((null? lists) ()) - (else - (cons (caar lists) (_a (cdr lists))) - ) - ) - ) - (define (_n lists) - (cond ((null? lists) ()) - (else - (cons (cdr (car lists)) (_n (cdr lists))) - ) - ) - ) - (define (_m lists) - (cond ((null? (car lists)) ()) - (else - (cons (apply proc (_a lists)) (_m (_n lists))) - ) - ) - ) - (_m lists) - ) - ) - -(_??_ (map cadr '((a b) (d e) (g h))) '(b e h)) - -(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) - - -(define (newline) (write-char #\newline)) - -(newline) - -(_??_ (call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) - (if (negative? x) - (exit x))) - '(54 0 37 -3 245 19)) - #t)) - -3) - - - ; `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 repeat - (macro (count . rest) - (define counter '__count__) - (cond ((pair? count) - (set! counter (car count)) - (set! count (cadr count)) - ) - ) - `(let ((,counter 0) - (__max__ ,count) - ) - (while (< ,counter __max__) - ,@rest - (set! ,counter (+ ,counter 1)) - ) - ) - ) - ) - -(repeat 2 (write 'hello)) -(repeat (x 3) (write (list 'goodbye x))) - -(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) - ) - ) - ) - -(define (eof-object? a) - (equal? a 'eof) - ) - -(_??_ (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)) |