768 lines
18 KiB
Scheme
768 lines
18 KiB
Scheme
|
|
|
|
|
|
;;; Standard lib, in scheme
|
|
|
|
; TODO: Fix below
|
|
(define eq? eqv?)
|
|
(define equal? eqv?)
|
|
(define (error str)
|
|
(begin (display "SCHEME ERROR: ")
|
|
(display str)
|
|
(display "\n")))
|
|
|
|
; Lists
|
|
|
|
(define (foldl f i l)
|
|
(if (null? l)
|
|
i
|
|
(foldl f (f (car l) i) (cdr l))))
|
|
|
|
(define (foldr f i l)
|
|
(if (null? l)
|
|
i
|
|
(f (car l) (foldr f i (cdr l)))))
|
|
|
|
|
|
(define (map f l)
|
|
(if (null? l)
|
|
'()
|
|
(foldr (lambda (e a) (cons (f e) a)) '() l)))
|
|
|
|
(define (length l)
|
|
(foldl + 0 (map (lambda (x) 1) l)))
|
|
|
|
(define (reverse l)
|
|
(foldl cons '() l))
|
|
|
|
(define (append l1 l2)
|
|
(foldr cons l2 l1))
|
|
|
|
|
|
(define list-tail; Taken from https://people.csail.mit.edu/jaffer/r5rs/Pairs-and-lists.html
|
|
(lambda (x k)
|
|
(if (zero? k)
|
|
x
|
|
(list-tail (cdr x) (- k 1)))))
|
|
|
|
(define generic-member
|
|
(lambda (compare obj ls)
|
|
(if (null? ls)
|
|
#f
|
|
(if (compare obj (car ls))
|
|
ls
|
|
(generic-member compare obj (cdr ls))))))
|
|
|
|
(define (memq obj ls) (generic-member eq? obj ls))
|
|
(define (memv obj ls) (generic-member eqv? obj ls))
|
|
(define (member obj ls) (generic-member equal? obj ls))
|
|
|
|
(define (cond-helper vo)
|
|
|
|
; Base case:
|
|
(if (null? vo)
|
|
'(if #f '()) ; This trick is used to ensure the result is identical to
|
|
; failing a one-armed if-statement.
|
|
|
|
; Error: incorrect format
|
|
(if (not (pair? vo))
|
|
(error "cond: Incorrect format")
|
|
|
|
; Else statement
|
|
(if (equal? 'else (caar vo))
|
|
(car (cdr (car vo)))
|
|
|
|
; Normal statement
|
|
`(if ,(caar vo)
|
|
(begin ,@(cdr (car vo)))
|
|
,(cond-helper (cdr vo)))
|
|
|
|
))))
|
|
|
|
(define-syntax cond
|
|
(lambda (vo)
|
|
(if (not (equal? 'cond (car vo)))
|
|
(error "cond: Expected cond as keyword")
|
|
|
|
(if (null? (cdr vo))
|
|
(error "cond: cond must not be empty")
|
|
|
|
(cond-helper (cdr vo))))))
|
|
|
|
(define (generic-assoc compare key als)
|
|
(cond
|
|
; Error check on `compare` and `key`
|
|
( (not (procedure? compare))
|
|
(error "generic-assoc: Argument #1 expected to be procedure, but was not.") )
|
|
( (not (symbol? key))
|
|
(error "generic-assoc: Argument #2 expected to be symbol, but was not.") )
|
|
|
|
; Base case
|
|
( (null? als)
|
|
#f )
|
|
|
|
; Error check `als` structure
|
|
( (if (not (pair? (car als))) #t (not (symbol? (caar als))))
|
|
(error (string-append "generic-assoc: Argument #3 should be associative list, but was not"
|
|
""
|
|
(datum->string als))))
|
|
|
|
; Found the correct one
|
|
( (compare key (caar als))
|
|
(cdr (car als)) )
|
|
|
|
; Otherwise: Continue along in the assoc list
|
|
( else
|
|
(generic-assoc compare key (cdr als)))
|
|
|
|
))
|
|
|
|
(define (assq obj ls) (generic-assoc eq? obj ls))
|
|
(define (assv obj ls) (generic-assoc eqv? obj ls))
|
|
(define (assoc obj ls) (generic-assoc equal? obj ls))
|
|
|
|
|
|
|
|
; Math
|
|
|
|
(define (= a b)
|
|
(if (<= a b)
|
|
(>= a b)
|
|
#f))
|
|
|
|
(define (zero? x) (= x 0))
|
|
(define (positive? x) (> x 0))
|
|
(define (negative? x) (< x 0))
|
|
(define (odd? x) (= (mod x 2) 1))
|
|
(define (even? x) (= (mod x 2) 0))
|
|
|
|
;;;;;;;; Testing stuff ;;;;;;;;;;
|
|
|
|
|
|
; Test some compilation stuff
|
|
|
|
(define f (lambda (x) ((lambda (y) (+ y 2)) (car x))))
|
|
|
|
(define g (lambda (x) (if ((lambda (y) (= y 2)) (car x))
|
|
y
|
|
'fuck)))
|
|
|
|
(define fac_fucked
|
|
( (lambda (f) (lambda (v) (f f v)))
|
|
(lambda (f v)
|
|
(if (= v 0)
|
|
1
|
|
(* v (f f (+ v -1)))))))
|
|
|
|
(display "Recursive combinator used on factorial.\n\tExpect: 120\n\tGotten: ")
|
|
(display (fac_fucked 5))
|
|
(newline)
|
|
|
|
; Test that function arguments are in correct order
|
|
|
|
(define (test-arg-order a b c)
|
|
(begin (display a)
|
|
(display " ")
|
|
(display b)
|
|
(display " ")
|
|
(display c)
|
|
(newline)))
|
|
|
|
(display "Testing that argument order is correct:\n\tExpect: 1 2 3\n\tGotten: ")
|
|
(test-arg-order 1 2 3)
|
|
(display "\n")
|
|
|
|
; Test string
|
|
|
|
(display "Hello World") (newline)
|
|
|
|
; Test functions
|
|
|
|
(define add-three (lambda (x y z) (+ (+ x z) y)))
|
|
|
|
; Test factorial
|
|
|
|
(define fac (lambda (x) (if (>= x 1) (* x (fac (+ x -1))) 1)))
|
|
|
|
(define (faca x a)
|
|
(if (>= x 1)
|
|
(faca (+ x -1) (* x a))
|
|
a))
|
|
|
|
(define x 5)
|
|
(display x) (newline)
|
|
(display (fac x)) (newline)
|
|
(display (faca x 1)) (newline)
|
|
|
|
; Test stuff?
|
|
|
|
(define (f . l) (cdr l))
|
|
(define y '(1 2 3))
|
|
|
|
(display y) (newline)
|
|
(display (car y)) (newline)
|
|
(display (cdr y)) (newline)
|
|
|
|
(display (append '(1 2 3) '(4 5 6))) (newline)
|
|
|
|
; Test system
|
|
|
|
(define (concat-string s sep)
|
|
(foldr (lambda (e a) (string-append (datum->string e) sep a))
|
|
""
|
|
s))
|
|
|
|
(define test
|
|
(lambda (name tests)
|
|
(begin (display name)
|
|
(display "\n\tExpect: ")
|
|
(display (concat-string (map car tests) " "))
|
|
(display "\n\tGotten: ")
|
|
(display (concat-string (map cdr tests) " "))
|
|
(newline))))
|
|
|
|
(define (header name) (display (string-append "\n * " name " *\n")))
|
|
|
|
(header "R5RS: Test equivalence")
|
|
|
|
(define (list-tail ls index)
|
|
(if (zero? index)
|
|
ls
|
|
(list-tail (cdr ls) (+ index -1))))
|
|
|
|
(define (list-ref ls index)
|
|
(car (list-tail ls index)))
|
|
|
|
; Actual Tests
|
|
|
|
(display "\n* R5RS: Quotation and quasi-quotation *\n")
|
|
|
|
(display "Testing quotation!\n\tExpect: (1 2 3)\n\tGotten: ")
|
|
(define (x) (quote (1 2 3)))
|
|
(display (x))
|
|
(newline)
|
|
|
|
(display "Testing quotation!\n\tExpect: (1 2 3)\n\tGotten: ")
|
|
(define (x) '(1 2 3))
|
|
(display (x))
|
|
(newline)
|
|
|
|
(display "Testing quasi-notation basics!\n\tExpect: (1 2 3)\n\tGotten: ")
|
|
(define (x) `(1 2 3))
|
|
(display (x))
|
|
(newline)
|
|
|
|
(display "Testing quasi-notation!\n\tExpect: (1 a 2 a 3 a 4)\n\tGotten: ")
|
|
(define (x p) `(1 ,p 2 ,p 3 ,p 4))
|
|
(display (x 'a))
|
|
(newline)
|
|
|
|
(display "Testing quasi-notation advanced!\n\tExpect: (1 2 3 4 5)\n\tGotten: ")
|
|
(define (x p) `(1 ,@p 3))
|
|
(display (x '(2 3 4)))
|
|
(newline)
|
|
|
|
(display "Testing quasi-notation advanced!\n\tExpect: (1 `(,a ,x 3) 4 5)\n\tGotten: ")
|
|
(define (f x y) `(,x `(,a ,x 3) 4 ,y))
|
|
(display (f 1 5))
|
|
(newline)
|
|
|
|
(display "Testing quasi-notation advanced!\n\tExpect: ((1 2) . 3)\n\tGotten: ")
|
|
(define (f) (cons `(1 2) 3))
|
|
(display (f))
|
|
(newline)
|
|
|
|
; Check set!
|
|
|
|
(set! x 10)
|
|
(display x) (newline)
|
|
|
|
(newline)
|
|
(display "* R5RS: Testing booleans *")
|
|
(newline)
|
|
|
|
(define fun-test
|
|
(lambda (name f cases)
|
|
(test (string-append "Testing function " name "")
|
|
(map (lambda (a) (cons (car a) (f (cdr a))))
|
|
cases))))
|
|
|
|
(fun-test "not" not
|
|
'( (#f . #t)
|
|
(#t . #f)
|
|
(#f . "hi")
|
|
(#f . 7)
|
|
(#f . a)
|
|
(#f . ())
|
|
))
|
|
|
|
(fun-test "boolean?" boolean?
|
|
'( (#t . #t)
|
|
(#t . #f)
|
|
(#f . "hi")
|
|
(#f . 7)
|
|
(#f . a)
|
|
(#f . ())
|
|
))
|
|
|
|
(header "R5RS: Testing numerical operators")
|
|
|
|
(fun-test "number?" number?
|
|
'( (#f . #t)
|
|
(#f . #f)
|
|
(#f . "hi")
|
|
(#t . 7)
|
|
(#t . 5232)
|
|
(#f . a)
|
|
(#f . ())
|
|
))
|
|
|
|
(header "R5RS: Testing fold and map")
|
|
|
|
(display "Testing sum over foldl!\n\tExpect: 28\n\tGotten: ")
|
|
(display (foldl + 0 '(1 2 3 4 5 6 7)))
|
|
(newline)
|
|
|
|
(display "Testing sum over foldr!\n\tExpect: 28\n\tGotten: ")
|
|
(display (foldr + 0 '(1 2 3 4 5 6 7)))
|
|
(newline)
|
|
|
|
(display "Testing map!\n\tExpect: (21 22 23)\n\tGotten: ")
|
|
(display (map (lambda (a) (+ 20 a)) '(1 2 3)))
|
|
(newline)
|
|
|
|
(display "Testing length!\n\tExpect: 13\n\tGotten: ")
|
|
(display (length '(1 2 3 1 2 3 1 2 3 1 2 3 1)))
|
|
(newline)
|
|
|
|
(display "Testing length!\n\tExpect: (5 4 3 2 1)\n\tGotten: ")
|
|
(display (reverse '(1 2 3 4 5)))
|
|
(newline)
|
|
|
|
(newline)
|
|
(display "* R5RS: Test string *")
|
|
(newline)
|
|
|
|
(display "Testing string-concat\n\tExpect: Hello World\n\tGotten: ")
|
|
(display (string-append "Hello" " " "World"))
|
|
(newline)
|
|
|
|
(define do-stuffer
|
|
(lambda (name_i arg1_i arg2_i)
|
|
(lambda (x)
|
|
(cons (list-ref x name_i)
|
|
(eqv? (list-ref x arg1_i)
|
|
(list-ref x arg2_i))))))
|
|
|
|
(define eqv-test
|
|
(lambda (name tests)
|
|
(test name (append (map (do-stuffer 0 1 2) tests)
|
|
(map (do-stuffer 0 2 1) tests)
|
|
))))
|
|
|
|
(eqv-test "eqv? booleans"
|
|
'(
|
|
(#t #t #t)
|
|
(#t #f #f)
|
|
(#f #t #f)
|
|
(#f #f #t)
|
|
))
|
|
|
|
(eqv-test "eqv? inter-types"
|
|
'(
|
|
(#f 2 a)
|
|
(#f 4 "Test")
|
|
(#f () (a b))
|
|
(#f 9 ())
|
|
))
|
|
|
|
(eqv-test "eqv? symbols"
|
|
'(
|
|
(#t hello hello)
|
|
(#t World wOrld)
|
|
(#f hello world)
|
|
(#f hello World)
|
|
))
|
|
|
|
|
|
(header "R5RS: Test if-expressions")
|
|
|
|
(test "If expressions exp!"
|
|
`(
|
|
(6 . ,(* 3 (if #t 2 0)))
|
|
(0 . ,(* 3 (if #f 2 0)))
|
|
("Hello World" . ,(if #t "Hello World"))
|
|
("???" . ,(if #f "Hello World"))
|
|
))
|
|
|
|
(header "R5RS: Testing Eval system")
|
|
|
|
(display "Eval expression. Expect 6: ")
|
|
(display (eval '(* 2 (cdr '(2 . 3))) (scheme-report-environment 5)))
|
|
(newline)
|
|
|
|
(newline)
|
|
(display "* R5RS: Testing Macro system *")
|
|
(newline)
|
|
|
|
; Test define-syntax
|
|
|
|
(display "Test define-syntax:\n Expect: 4 ()\n Gotten: ")
|
|
|
|
(define-syntax const
|
|
(lambda (so)
|
|
`(lambda () ,(car (cdr so)))))
|
|
|
|
(define x (const 4))
|
|
(display (x))
|
|
(display " ")
|
|
(define x (const '()))
|
|
(display (x))
|
|
(display "\n")
|
|
|
|
(display "Test defining let using macroes:\n Expect: 23 82 105\n Gotten: ")
|
|
|
|
(define (let-names-helper vo)
|
|
(cond ( (not (pair? vo))
|
|
(error "let: incorrect form: Not a pair!"))
|
|
( (not (symbol? (car vo)))
|
|
(error "let: incorrect form: Not a symbol!"))
|
|
( else
|
|
(car vo))))
|
|
|
|
(define-syntax let
|
|
(lambda (vo)
|
|
(cond ( (not (equal? 'let (car vo)))
|
|
(error "let: Incorrect form: Let was not the first keyword!"))
|
|
|
|
( else
|
|
`( (lambda ,(map let-names-helper (cadr vo)) ,(caddr vo))
|
|
,@(map cadr (cadr vo)))))))
|
|
|
|
(let ((a 23)
|
|
(b 82))
|
|
(begin (display a)
|
|
(display " ")
|
|
(display b)
|
|
(display " ")
|
|
(display (+ a b))))
|
|
|
|
(display "\n* R5RS: Lexical conventions *\n")
|
|
|
|
(define a-variable 20)
|
|
(if #f (begin
|
|
(display "Test case-insensitivity (required by R5RS)\n\tExpect: 20 20 20 20\n\tGotten: ")
|
|
(display a-variable) (display " ")
|
|
(display A-variable) (display " ")
|
|
(display a-VARiable) (display " ")
|
|
(display A-VARIABLE))
|
|
(display "Skipped test!\n"))
|
|
|
|
; Test environment set
|
|
|
|
(newline)
|
|
(display "* Testing custom library *")
|
|
(newline)
|
|
|
|
(display "Testing set-env! Expect 32: ")
|
|
(display ((set-env! (lambda () x) '((x . 32)) )))
|
|
(newline)
|
|
|
|
(display "Testing string->datum! Expect (2): ")
|
|
(display (cdr (string->datum "(display 2)")))
|
|
(newline)
|
|
|
|
; Test syntax-rules
|
|
|
|
(header "Testing syntax-rules (move to macro once implemented)")
|
|
|
|
(define (syntax-rules-dots-traversal fn ls)
|
|
(if (null? ls)
|
|
'()
|
|
(if (not (pair? ls))
|
|
#f
|
|
(if (fn (car ls))
|
|
(let ((found (syntax-rules-dots-traversal fn (cdr ls))))
|
|
(if found
|
|
`( ,(cons (car ls) (car found))
|
|
,(cdr found) )))
|
|
|
|
|
|
|
|
`(() ,ls) ))))
|
|
|
|
(define construct-pattern-predicate
|
|
(lambda (name pat literals)
|
|
(if (number? pat)
|
|
`(equal? ,name ,pat)
|
|
|
|
; Is symbol
|
|
(if (symbol? pat)
|
|
(if (member pat literals)
|
|
; Is literal
|
|
`(equal? ,name ',pat)
|
|
|
|
; Or is variable binding
|
|
#t)
|
|
|
|
(if (null? pat)
|
|
`(null? ,name)
|
|
|
|
(if (if (pair? pat) (if (pair? (cdr pat)) (equal? '... (cadr pat))
|
|
#f) #f)
|
|
(let ((predicate (construct-pattern-predicate
|
|
'vo3
|
|
(car pat)
|
|
literals)))
|
|
(cond ; Very simple pattern
|
|
( (if (equal? #t predicate) (null? (cddr pat)) #f)
|
|
#t )
|
|
|
|
; Somewhat simple predicate
|
|
( (equal? #t predicate)
|
|
(construct-pattern-predicate ''()
|
|
(cddr pat)
|
|
literals)
|
|
|
|
; Complex predicate / Default
|
|
( else
|
|
`(let ((after (syntax-rules-dots-traversal
|
|
(lambda (vo3) ,predicate)
|
|
,name)))
|
|
(if after
|
|
,(construct-pattern-predicate '(cdr after)
|
|
(cddr pat)
|
|
literals)
|
|
#f))))))
|
|
|
|
(if (pair? pat)
|
|
(let (( test
|
|
(construct-pattern-predicate `(car ,name)
|
|
(car pat)
|
|
literals))
|
|
( body
|
|
(construct-pattern-predicate `(cdr ,name)
|
|
(cdr pat)
|
|
literals)))
|
|
(cond ( (if (equal? #t test) (equal? #t body) #f)
|
|
`(pair? ,name))
|
|
( (equal? #t test)
|
|
`(if (pair? ,name) ,body #f))
|
|
( (equal? #t body)
|
|
`(if (pair? ,name) ,test #f))
|
|
( else
|
|
`(if (pair? ,name) (if ,test ,body #f) #f))
|
|
))
|
|
|
|
'fuck )))))))
|
|
|
|
(define (find-variable-bindings literals path pattern)
|
|
; Is symbol
|
|
(if (if (symbol? pattern) (not (member pattern literals)) #f)
|
|
`((,pattern ,path))
|
|
|
|
|
|
; Is dots pair
|
|
; TODO: Fix below, it is fucked.
|
|
(if (if (pair? pattern)
|
|
(if (pair? (cdr pattern))
|
|
(equal? '... (cadr pattern)) #f) #f)
|
|
(let ( ( predicate
|
|
(construct-pattern-predicate
|
|
'vo3
|
|
(car pattern)
|
|
literals)))
|
|
(if (equal? predicate '#t)
|
|
`((,(car pattern) ,path))
|
|
(error "Not implemented")))
|
|
|
|
;`(let ((found (syntax-rules-dots-traversal
|
|
;(lambda (vo3) ,predicate)
|
|
;,pattern)))
|
|
;(append
|
|
;'((,(car pattern) ,path))
|
|
;,(find-variable-bindings literals
|
|
;`(list-ref ,path (length found))
|
|
;(cddr pattern))))
|
|
; Is pair
|
|
|
|
(if (pair? pattern)
|
|
(append (find-variable-bindings literals `(car ,path) (car pattern))
|
|
(find-variable-bindings literals `(cdr ,path) (cdr pattern)))
|
|
|
|
; Is anything else
|
|
; TODO: Vector patterns
|
|
|
|
'() ))))
|
|
|
|
(define (construct-result bindings template)
|
|
; Is symbol
|
|
(if (if (symbol? template) (assoc template bindings) #f)
|
|
(cons 'unquote (cons template '()))
|
|
|
|
; Is dots pair
|
|
|
|
(if (if (pair? template)
|
|
(if (pair? (cdr template))
|
|
(equal? '... (cadr template)) #f) #f)
|
|
(cons (cons 'unquote-splicing (cons (car template) '()))
|
|
(construct-result bindings (cddr template)))
|
|
|
|
; Is normal pair
|
|
|
|
(if (pair? template)
|
|
(cons (construct-result bindings (car template))
|
|
(construct-result bindings (cdr template)))
|
|
|
|
; Is anything else
|
|
; TODO: Vector patterns
|
|
|
|
template ))))
|
|
|
|
(define syntax-rules-rec
|
|
(lambda (macro-name var-name literals rules)
|
|
(if (null? rules)
|
|
'''doublefuck
|
|
(let ((pattern (caar rules))
|
|
(result (cadar rules))
|
|
(bindings (find-variable-bindings literals var-name (caar rules)))
|
|
)
|
|
(begin (display "Test ")
|
|
(display bindings)
|
|
(newline)
|
|
|
|
(if (eqv? macro-name (car pattern))
|
|
`(if ,(construct-pattern-predicate var-name
|
|
pattern
|
|
literals )
|
|
(let ,bindings
|
|
,(cons 'quasiquote (cons (construct-result bindings result) '()))
|
|
)
|
|
,(syntax-rules-rec macro-name var-name literals (cdr rules)))
|
|
|
|
(begin (display "Incorrect usage of syntax-rules-rec: Each rule must have same first symbol.")
|
|
(display "\n\tFirst had ")
|
|
(display macro-name)
|
|
(display "\n\tBut one of them had ")
|
|
(display (car pattern))
|
|
(newline)))))))
|
|
)
|
|
|
|
|
|
(define-syntax syntax-rules
|
|
(lambda (vo)
|
|
(let ((literals (cons (car (caaddr vo)) (cadr vo)))
|
|
(rules (cddr vo))
|
|
(name (car (caaddr vo))))
|
|
|
|
`(lambda (vo2)
|
|
,( syntax-rules-rec name 'vo2 literals rules ))
|
|
)))
|
|
|
|
; Define true
|
|
|
|
(define-syntax true
|
|
(syntax-rules ()
|
|
((true) #t)))
|
|
|
|
(test "Attempting to define true using syntax rules."
|
|
`(
|
|
( #t . ,(true))
|
|
( #f . ,(not (true)))
|
|
))
|
|
|
|
;
|
|
|
|
|
|
; Below should produce an error:
|
|
;(define-syntax bad-rule
|
|
;(syntax-rules ()
|
|
;((bad-rule-1) #t)
|
|
;((bad-rule-2) #f)))
|
|
|
|
(define-syntax bool
|
|
(syntax-rules ()
|
|
((bool) #t)
|
|
((bool 0) #f)
|
|
((bool 1) #t)
|
|
))
|
|
|
|
(test "Attempting to define bool ? using syntax rules."
|
|
`(
|
|
( #t . ,(bool))
|
|
( #f . ,(bool 0))
|
|
( #t . ,(bool 1))
|
|
))
|
|
|
|
(define-syntax fun_macro
|
|
(syntax-rules (two)
|
|
((fun_macro) 1)
|
|
((fun_macro two) (+ (derp) (derp)))
|
|
))
|
|
|
|
(test "Defining weird macroes using syntax-rules."
|
|
`(
|
|
( 1 . ,(fun_macro))
|
|
( 2 . ,(fun_macro two))
|
|
))
|
|
|
|
(define-syntax +1
|
|
(syntax-rules ()
|
|
((+1 n) (+ 1 n))))
|
|
|
|
(test "Defining +1 using syntax-rules."
|
|
`(
|
|
( 6 . ,(+1 5))
|
|
( 1 . ,(+1 0))
|
|
( 0 . ,(+1 -1))
|
|
))
|
|
|
|
(define-syntax fun_macro
|
|
(syntax-rules ()
|
|
((fun_macro a) a)
|
|
((fun_macro a b ...) (+ a (derp b ...)))
|
|
))
|
|
|
|
(test "Defining list using syntax-rules."
|
|
`(
|
|
( 1 . ,(fun_macro 1))
|
|
( 6 . ,(fun_macro 6))
|
|
( 9 . ,(fun_macro 4 5))
|
|
( 3 . ,(fun_macro 1 1 1))
|
|
))
|
|
|
|
(exit)
|
|
|
|
|
|
;;;;; ;
|
|
|
|
(exit)
|
|
|
|
(define-syntax and
|
|
(syntax-rules ()
|
|
((and) #t)
|
|
((and test) test)
|
|
((and test1 test2 ...)
|
|
(if test1 (and test2 ...) #f))))
|
|
|
|
(test "Attempting to define and using syntax rules."
|
|
`(
|
|
(#t . ,(and))
|
|
(#f . ,(and #f))
|
|
(#t . ,(and #t))
|
|
(#f . ,(and #f #f))
|
|
(#f . ,(and #t #f))
|
|
(#f . ,(and #f #t))
|
|
(#t . ,(and #t #t))
|
|
(#f . ,(and #t #f #t))
|
|
(#f . ,(and #f #f #f))
|
|
(#t . ,(and #t #t #t))
|
|
(#f . ,(and #f #t #f #f #f #f))
|
|
(#t . ,(and #t #t #t #t #t #t))
|
|
))
|
|
|
|
; TODO: Use syntax-rules to implement let and or.
|
|
|
|
(display "")
|
|
|