Fixed implementation of boolean? and not.
This commit is contained in:
parent
380f73683f
commit
0303bcbeaa
110
example.scm
110
example.scm
|
|
@ -80,6 +80,36 @@
|
|||
(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: ")
|
||||
|
|
@ -121,29 +151,43 @@
|
|||
(display "* R5RS: Testing booleans *")
|
||||
(newline)
|
||||
|
||||
(display "Testing not\n\tExpect: #f #t #f #f\n\tGotten: ")
|
||||
(display (not #t)) (display " ")
|
||||
(display (not #f)) (display " ")
|
||||
(display (not "hi")) (display " ")
|
||||
(display (not 6)) (newline)
|
||||
(define fun-test
|
||||
(lambda (name f cases)
|
||||
(test (string-append "Testing function " name "")
|
||||
(map (lambda (a) (cons (car a) (f (cdr a))))
|
||||
cases))))
|
||||
|
||||
(newline)
|
||||
(display "* R5RS: Testing numerical operators *")
|
||||
(newline)
|
||||
(fun-test "not" not
|
||||
'( (#f . #t)
|
||||
(#t . #f)
|
||||
(#f . "hi")
|
||||
(#f . 7)
|
||||
(#f . a)
|
||||
(#f . ())
|
||||
))
|
||||
|
||||
(display "Testing number?\n\tExpect: #t #f #f #f\n\tGotten: ")
|
||||
(display (number? 5))
|
||||
(display " ")
|
||||
(display (number? #f))
|
||||
(display " ")
|
||||
(display (number? "hello"))
|
||||
(display " ")
|
||||
(display (number? '(1 2)))
|
||||
(newline)
|
||||
(fun-test "boolean?" boolean?
|
||||
'( (#t . #t)
|
||||
(#t . #f)
|
||||
(#f . "hi")
|
||||
(#f . 7)
|
||||
(#f . a)
|
||||
(#f . ())
|
||||
))
|
||||
|
||||
(newline)
|
||||
(display "* R5RS: Testing fold and map *")
|
||||
(newline)
|
||||
(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)))
|
||||
|
|
@ -173,32 +217,6 @@
|
|||
(display (string-append "Hello" " " "World"))
|
||||
(newline)
|
||||
|
||||
(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)))
|
||||
|
||||
(define do-stuffer
|
||||
(lambda (name_i arg1_i arg2_i)
|
||||
(lambda (x)
|
||||
|
|
|
|||
|
|
@ -1031,27 +1031,27 @@ let /* Booleans */
|
|||
/* R5RS: Boolean */
|
||||
|
||||
; stdfun("not")
|
||||
; app(OPCODE_TYPEOF, 0, "")
|
||||
; app2(OPCODE_PUSH, bool_val(false))
|
||||
; app(OPCODE_EQV, 0, "")
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
; stdfun("boolean?")
|
||||
/* Test for false */
|
||||
; app(OPCODE_TYPEOF, 0, "")
|
||||
; app(OPCODE_DUPL, 0, "")
|
||||
; app2(OPCODE_PUSH, bool_val(false))
|
||||
; app(OPCODE_EQV, 0, "")
|
||||
; app(OPCODE_CSKIP, 2, "")
|
||||
; app(OPCODE_CSKIP, 4, "")
|
||||
|
||||
/* Is true, remove top and return */
|
||||
; app(OPCODE_POP, 0, "")
|
||||
; app2(OPCODE_PUSH, bool_val(1))
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
/* Not false, maybe true? */
|
||||
; app2(OPCODE_PUSH, bool_val(true))
|
||||
; app(OPCODE_EQV, 0, "")
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
/* Is true, remove top and return */
|
||||
; app(OPCODE_POP, 0, "")
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
/* R5RS: Pairs and Lists */
|
||||
|
||||
|
|
@ -1224,6 +1224,11 @@ let /* Booleans */
|
|||
; app2(OPCODE_PUSH, VALUE_UNSPECIFIED)
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
; stdfun("debug-show-stack")
|
||||
; app(OPCODE_DEBUG, 2, "")
|
||||
; app2(OPCODE_PUSH, VALUE_UNSPECIFIED)
|
||||
; app(OPCODE_RET, 1, "")
|
||||
|
||||
; stdfun("exit")
|
||||
; app(OPCODE_EXIT, true, "")
|
||||
|
||||
|
|
@ -2328,10 +2333,15 @@ let /* Booleans */
|
|||
end
|
||||
|
||||
else if tape[ip].opcode = OPCODE_DEBUG
|
||||
then let var arg := stack_pop(stack)
|
||||
then let var arg := stack_pop(stack)
|
||||
var val_b := (arg = nil | is_truthy(arg))
|
||||
|
||||
in if tape[ip].arg1 = 1
|
||||
then DEBUG_PRINT_TAPE := val_b
|
||||
else if tape[ip].arg1 = 2
|
||||
then DEBUG_PRINT_STACK := val_b
|
||||
else run_error("Attempting to use unknown debug option!")
|
||||
|
||||
in if tape[ip].arg1
|
||||
then DEBUG_PRINT_TAPE := (arg = nil | is_truthy(arg))
|
||||
; ip := ip + 1
|
||||
end
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user