If you choose to engage yourself in OxyScheme upgrade, I'll be glad to give you a helping hand wherever I can.
At the moment simple errors like (1 + 1) will crash Oxyscheme / o2scm.;D
#define clearinput() currentline = endline = linebuff
#define clearinput() currentline = endline := linebuff
else if (isstring(l)) then
if (flg == 0) then
p = cast char strvalue(l)
else
else if (isstring(l)) then
if (flg == 0) then
p = cast char* strvalue(l)
else
#define istrue(p) (((p) != NIL) && ((p) != F))
#define isfalse(p) (((p) == NIL) || ((p) == F))
sub mark(sys a)
===============
sys t, q, p
printl "in sub mark"
t = 0
p = a
E2:
printl "in E2"
setmark(p)
if (isatom(p)) then goto E6
q = car(p)
if ((q != 0) && (ismark(q) == 0)) then
setatom(p)
car(p) = t
t = p
p = q
goto E2
end if
E5:
printl "in E5"
print ",t = " t " --- Enter: " : waitkey
q = cdr(p)
if ((q != 0) && (ismark(q) == 0)) then
cdr(p) = t
t = p
p = q
printl "from E5 to E2"
goto E2
end if
E6:
printl "in E6"
print ",t = " t
if (t == 0) then exit sub
q = t
if (isatom(q)) then
clratom(q)
t = car(q)
car(q) = p
p = q
printl "from E6 to E5"
goto E5
else
t = cdr(q)
cdr(q) = p
p = q
printl "from E6 to E6" ': waitkey
goto E6
end if
end sub
'#define istrue(p) (((p) != NIL) && ((p) != F))
'#define isfalse(p) (((p) == NIL) || ((p) == F))
#define istrue(p) call istrue_asm(p)
#define isfalse(p) call isfalse_asm(p)
... 'append to o2 asm helper functions
.istrue_asm
mov eax,0
mov ecx,[esp+4]
(
cmp ecx,NIL
jnz exit
ret 4
)
(
cmp ecx,F
jnz exit
ret 4
)
mov eax,-1
ret 4
.isfalse_asm
mov eax,-1
mov ecx,[esp+4]
(
cmp ecx,NIL
jnz exit
ret 4
)
(
cmp ecx,F
jnz exit
ret 4
)
mov eax,0
ret 4
'12:44 09/11/2019
'sheme and basic compare
'(define fibo*
' (lambda (a b x)
' (if (= x 0) a
' (fibo* b (+ a b) (- x 1)))))
'
function fibo(int a,b,x) as int
if x=0 then return a else return fibo(b,a+b,x-1)
end function
uses corewin
function fibo(quad a,b,x) as quad
if x=0 then return a else return fibo(b,a+b,x-1)
end function
quad x = fibo(1,1,91)
' print x
char s[30]
sprintf(s, "%I64d", x)
print s
But both _atoi64() and _i64toa() use and return VC long long integers, not O2 64-bit floating point quads! Charles, please comment here whether O2 currently makes an equivalent substitution of quads in its integer registers automatically and transparently when it pushes and receives 64-bit integers to/from a DLL?
uses corewin
uses console
sub grains(int x)
int i
quad j = 1
char s[20]
for i = 1 to x
printl " field " i ": number of grains: "
sprintf(s, "%I64u", j)
print s
j *= 2
next
end sub
printl " The reward of the King"
printl " ----------------------" + cr
grains 64
printl "Enter ..."
waitkey
/* ---------- Mini-Scheme Interpreter Version 0.85 ----------
* coded by Atsushi Moriwaki (11/5/1989)
* This version has been modified by Chris Pressey.
* current version is 0.85 mod (as yet unreleased)
* This version has been modified by R.C. Secrist.
* This is a revised and modified version by Akira KIDA.
* THIS SOFTWARE IS IN THE PUBLIC DOMAIN
* ------------------------------------
*/
// only for Windows, tested with Win10
// added TOK_EOF, EOF_OBJ, OP_GENSYM, some other modifications
// works with "msinit.scm"
...
(macro when (lambda(a b) (cond (a b) ) ) )
(when (> 2 1) 'greater )
`(list ,(+ 1 2) 4)
;; simple test cases
(define CheckResult
(lambda (num expected)
(display "Test ")
(display num)
(display " Expected: ")
(display expected)
(newline)
))
; (display ", result: ")
; (display result)
...
;; simple test cases
(define result)
(define CheckResult
(lambda (num result expected)
(if (equal? result expected ) (begin (display "Test: ")
(display num) (display " ok "))
(begin
(display "Test ") (display num) (display ", result: ") (display result)
(display " Expected: ") (display expected)
(newline)))
))
...
;; simple test cases
(define TestResult)
(define tmpTestResult)
(define FailedCases)
(define Counter 0)
(define CheckResult
(lambda (num TestResult Expected)
(if (equal? TestResult Expected )
(begin (for-each display (list "Test: " num " ok ")))
;else
(begin
(for-each display (list "Test: " num ", Result: " TestResult " Expected: " Expected))
(newline)
(set! Counter (+ Counter 1))
(set! FailedCases (append FailedCases (list num TestResult Expected))))
)))
(define ReportFailures
(lambda (Counter)
(if (= 0 Counter)
(display "All Tests passed OK")
;else
(begin
(display Counter) (display " Test(s) failed")
(newline)
(display FailedCases)
(newline)
))))
;;; lambda
;;;; syntax: (lambda formals body)
;1
(set! tmpTestResult `,(lambda (x) (+ x x))) ;(CheckResult 1 TestResult `"#<CLOSURE>" )
(set! TestResult `,(closure? tmpTestResult)) (CheckResult 1 TestResult `#t )
;2
(set! TestResult `,((lambda (x) (+ x x)) 4)) (CheckResult 2 TestResult 8 )
;3
(define reverse-subtract
(lambda (x y) (- y x)))
(set! TestResult `,(reverse-subtract 7 10)) (CheckResult 3 TestResult 3 )
;4
(define add4
(let ((x 4))
(lambda (y) (+ x y))))
(set! TestResult `,(add4 6)) (CheckResult 4 TestResult 10 )
;5
(set! TestResult `,((lambda x x)
3 4 5 6)) (CheckResult 5 TestResult '(3 4 5 6) )
;6
(set! TestResult `,((lambda (x y . z) z)
3 4 5 6)) (CheckResult 6 TestResult '(5 6) )
;7
(set! TestResult `,(= 10 0)) (CheckResult 7 TestResult `#f)
;Test function
;8
(define factorial
(lambda (n)
(let fact ((i n))
(if (= i 0)
1
(* i (fact (- i 1)))))))
(set! TestResult `,(factorial 12)) (CheckResult 8 TestResult 479001600 )
(newline)
(ReportFailures Counter)
(newline)
(display "End of tests")
(macro do
(lambda (do-macro)
(apply (lambda (do vars endtest . body)
(let ((do-loop (gensym)))
`(letrec ((,do-loop
(lambda ,(map (lambda (x)
(if (pair? x) (car x) x))
`,vars)
(if ,(car endtest)
(begin ,@(cdr endtest))
(begin
,@body
(,do-loop
,@(map (lambda (x)
(cond
((not (pair? x)) x)
((< (length x) 3) (car x))
(else (car (cdr (cdr x))))))
`,vars)))))))
(,do-loop
,@(map (lambda (x)
(if (and (pair? x) (cdr x))
(car (cdr x))
nil))
`,vars)))))
do-macro)))