;
; 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))
; execute to resolve macros
-(or #f #t)
+(_?_ (or #f #t) #t)
(begin
(def! and
; execute to resolve macros
-(and #t #f)
+(_?_ (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 (first . rest)
; check for alternate lambda definition form
- (cond ((list? first)
+ (cond ((pair? first)
(set! rest
(append
(list
(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)
)
)
-(if (> 3 2) 'yes)
-(if (> 3 2) 'yes 'no)
-(if (> 2 3) 'no 'yes)
-(if (> 2 3) 'no)
+(_??_ (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)
-(zero? 0)
-(zero? "hello")
+(_??_ (zero? 1) #f)
+(_??_ (zero? 0) #t)
+(_??_ (zero? "hello") #f)
(define positive? (macro (value) `(> ,value 0)))
-(positive? 12)
-(positive? -12)
+(_??_ (positive? 12) #t)
+(_??_ (positive? -12) #f)
(define negative? (macro (value) `(< ,value 0)))
-(negative? 12)
-(negative? -12)
+(_??_ (negative? 12) #f)
+(_??_ (negative? -12) #t)
(define (abs x) (if (>= x 0) x (- x)))
-(abs 12)
-(abs -12)
+(_??_ (abs 12) 12)
+(_??_ (abs -12) 12)
(define max (lambda (first . rest)
(while (not (null? rest))
first)
)
-(max 1 2 3)
-(max 3 2 1)
+(_??_ (max 1 2 3) 3)
+(_??_ (max 3 2 1) 3)
(define min (lambda (first . rest)
(while (not (null? rest))
first)
)
-(min 1 2 3)
-(min 3 2 1)
+(_??_ (min 1 2 3) 1)
+(_??_ (min 3 2 1) 1)
(define (even? x) (zero? (% x 2)))
-(even? 2)
-(even? -2)
-(even? 3)
-(even? -1)
+(_??_ (even? 2) #t)
+(_??_ (even? -2) #t)
+(_??_ (even? 3) #f)
+(_??_ (even? -1) #f)
(define (odd? x) (not (even? x)))
-(odd? 2)
-(odd? -2)
-(odd? 3)
-(odd? -1)
+(_??_ (odd? 2) #f)
+(_??_ (odd? -2) #f)
+(_??_ (odd? 3) #t)
+(_??_ (odd? -1) #t)
-
-(define (list-tail x k)
- (if (zero? k)
- x
- (list-tail (cdr x (- k 1)))
- )
- )
+(_??_ (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
)
-(let ((x 1) (y)) (set! y 2) (+ x y))
+(_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3)
; define a set of local
; variables one at a time and
;
; (let* ((x 1) (y)) (set! y (+ x 1)) y)
-(define let*
+(define letrec
(macro (vars . exprs)
;
)
)
-(let* ((x 1) (y x)) (+ x y))
+(_??_ (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 (write 'when))
+(_??_ (when #t (+ 1 2)) 3)
+(_??_ (when #f (+ 1 2)) #f)
(define unless (macro (test . l) `(cond ((not ,test) ,@l))))
-(unless #f (write 'unless))
+(_??_ (unless #f (+ 2 3)) 5)
+(_??_ (unless #t (+ 2 3)) #f)
(define (reverse list)
- (let ((result ()))
- (while (not (null? list))
- (set! result (cons (car list) result))
- (set! list (cdr list))
- )
- result)
+ (define (_r old new)
+ (if (null? old)
+ new
+ (_r (cdr old) (cons (car old) new))
+ )
+ )
+ (_r list ())
)
-(reverse '(1 2 3))
-
-(define (list-tail x k)
- (if (zero? k)
- x
- (list-tail (cdr x) (- k 1))))
-
-(list-tail '(1 2 3) 2)
-
-(define (list-ref x k) (car (list-tail x k)))
-
-(list-ref '(1 2 3) 2)
-
- ; recursive equality
+(_??_ (reverse '(1 2 3)) '(3 2 1))
-(define (equal? a b)
- (cond ((eq? a b) #t)
- ((and (pair? a) (pair? b))
- (and (equal? (car a) (car b))
- (equal? (cdr a) (cdr b)))
- )
- (else #f)
+(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))
-(equal? '(a b c) '(a b c))
-(equal? '(a b c) '(a b b))
+(_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f))
(define member (lambda (obj list . test?)
(cond ((null? list)
)
)
-(member '(2) '((1) (2) (3)))
+(_??_ (member '(2) '((1) (2) (3))) '((2) (3)))
-(member '(4) '((1) (2) (3)))
+(_??_ (member '(4) '((1) (2) (3))) #f)
(define (memq obj list) (member obj list eq?))
-(memq 2 '(1 2 3))
+(_??_ (memq 2 '(1 2 3)) '(2 3))
-(memq 4 '(1 2 3))
+(_??_ (memq 4 '(1 2 3)) #f)
-(memq '(2) '((1) (2) (3)))
+(_??_ (memq '(2) '((1) (2) (3))) #f)
(define (memv obj list) (member obj list eqv?))
-(memv 2 '(1 2 3))
+(_??_ (memv 2 '(1 2 3)) '(2 3))
-(memv 4 '(1 2 3))
+(_??_ (memv 4 '(1 2 3)) #f)
-(memv '(2) '((1) (2) (3)))
+(_??_ (memv '(2) '((1) (2) (3))) #f)
-(define (_assoc obj list test?)
+(define (assoc obj list . compare)
+ (if (null? compare)
+ (set! compare equal?)
+ (set! compare (car compare))
+ )
(if (null? list)
#f
- (if (test? obj (caar list))
+ (if (compare obj (caar list))
(car list)
- (_assoc obj (cdr list) test?)
- )
+ (assoc obj (cdr list) compare)
+ )
)
)
-(define (assq obj list) (_assoc obj list eq?))
-(define (assv obj list) (_assoc obj list eqv?))
-(define (assoc obj list) (_assoc obj list equal?))
+(define (assq obj list) (assoc obj list eq?))
+(define (assv obj list) (assoc obj list eqv?))
-(assq 'a '((a 1) (b 2) (c 3)))
-(assv 'b '((a 1) (b 2) (c 3)))
-(assoc '(c) '((a 1) (b 2) ((c) 3)))
+(_??_ (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)
-(char? "h")
+(_??_ (char? #\q) #t)
+(_??_ (char? "h") #f)
(define (char-upper-case? c) (<= #\A c #\Z))
-(char-upper-case? #\a)
-(char-upper-case? #\B)
-(char-upper-case? #\0)
-(char-upper-case? #\space)
+(_??_ (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)
-(char-lower-case? #\B)
-(char-lower-case? #\0)
-(char-lower-case? #\space)
+(_??_ (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)
-(char-alphabetic? #\B)
-(char-alphabetic? #\0)
-(char-alphabetic? #\space)
+(_??_ (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)
-(char-numeric? #\B)
-(char-numeric? #\0)
-(char-numeric? #\space)
+(_??_ (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)
-(char-whitespace? #\B)
-(char-whitespace? #\0)
-(char-whitespace? #\space)
+(_??_ (char-whitespace? #\a) #f)
+(_??_ (char-whitespace? #\B) #f)
+(_??_ (char-whitespace? #\0) #f)
+(_??_ (char-whitespace? #\space) #t)
-(define (char->integer c) c)
+(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)
-(char-upcase #\B)
-(char-upcase #\0)
-(char-upcase #\space)
+(_??_ (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)
-(char-downcase #\B)
-(char-downcase #\0)
-(char-downcase #\space)
+(_??_ (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)))
-(display "apply\n")
-(apply cons '(a b))
+(_??_ (string #\a #\b #\c) "abc")
+
+(_??_ (apply cons '(a b)) '(a . b))
(define map
(lambda (proc . lists)
- (define (args lists)
+ (define (_a lists)
(cond ((null? lists) ())
(else
- (cons (caar lists) (args (cdr lists)))
+ (cons (caar lists) (_a (cdr lists)))
)
)
)
- (define (next lists)
+ (define (_n lists)
(cond ((null? lists) ())
(else
- (cons (cdr (car lists)) (next (cdr lists)))
+ (cons (cdr (car lists)) (_n (cdr lists)))
)
)
)
- (define (domap lists)
+ (define (_m lists)
(cond ((null? (car lists)) ())
(else
- (cons (apply proc (args lists)) (domap (next lists)))
+ (cons (apply proc (_a lists)) (_m (_n lists)))
)
)
)
- (domap lists)
+ (_m lists)
)
)
-(map cadr '((a b) (d e) (g h)))
-
-(define for-each (lambda (proc . lists)
- (apply map proc lists)
- #t))
+(_??_ (map cadr '((a b) (d e) (g h))) '(b e h))
-(for-each display '("hello" " " "world" "\n"))
-
-(define (_string-ml strings)
- (if (null? strings) ()
- (cons (string->list (car strings)) (_string-ml (cdr strings)))
+(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)
)
)
-(define string-map (lambda (proc . strings)
- (list->string (apply map proc (_string-ml strings))))))
-
-(string-map (lambda (x) (+ 1 x)) "HAL")
-
-(define string-for-each (lambda (proc . strings)
- (apply for-each proc (_string-ml strings))))
-
-(string-for-each write-char "IBM\n")
+(_??_ (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)
- (write "test" x)
- (if (negative? x)
- (exit x)))
- '(54 0 37 -3 245 19))
- #t))
+(_??_ (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)
-`(hello ,(+ 1 2) ,@(list 1 2 3) `foo)
+(_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))
(define repeat
)
(repeat 2 (write 'hello))
-(repeat (x 3) (write 'goodbye x))
+(repeat (x 3) (write (list 'goodbye x)))
(define case
(macro (test . l)
)
)
-(case 12 (1 "one") (2 "two") (3 => (lambda (x) (write "the value is" x))) (12 "twelve") (else "else"))
+(_??_ (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))