Jmaa/tiger-scheme
1
0
Fork 0
Code

Added support for piping files into tigerscheme.

Browse Source
This commit is contained in:
Jon Michael Aanes 2018-12-05 14:42:34 +01:00
parent 96cc19b207
commit edadfea781
2 changed files with 94 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
example.scm Normal file
View File

@ -0,0 +1,47 @@
; 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)
; Check set!
(set! x 10)
(display x) (newline)
; Test syntax-rules
(define-syntax and
(syntax-rules ()
((and) #t)
((and test) test)
((and test1 test2 ...)
(if test1 (and test2 ...) #f))))
(display (and #t #t)) (newline)
(display (and #f #t)) (newline)
(display (and #f #f)) (newline)
(display (and #t #f)) (newline)

87
tigerscheme.tig
View File

@ -262,6 +262,11 @@ let /* Booleans */
in ascii = 41
end
function is_comment_start (index: int): int =
let var ascii := ord(substring(str, index, 1))
in ascii = ord(";")
end
function is_tick (index: int): int =
let var ascii := ord(substring(str, index, 1))
in ascii = ord("'")
@ -320,8 +325,16 @@ let /* Booleans */
, pos_r = pos_r }
function ignore_ws () =
while index < size(str) & is_ws(index)
do index := index + 1
/* Ignore whitespace */
if index < size(str) & is_ws(index)
then (index := index + 1; ignore_ws())
/* Handle comments, ignore until newline */
else if is_comment_start(index)
then ( while ord(substring(str, index, 1)) <> ord("\n")
do index := index + 1
; ignore_ws())
function parse_rec (): sexp_ast =
( ignore_ws()
@ -485,6 +498,8 @@ let /* Booleans */
var OPCODE_CAR := 20
var OPCODE_CDR := 16
var OPCODE_SET := 21
var OPCODE_FRSTR := 22
var OPCODE_COMPILE:= 23
var vm_insn_num_opcodes := 0
var vm_insn_info :=
@ -526,14 +541,18 @@ let /* Booleans */
; code(OPCODE_DEFFUN, "DEFFUN", 1, 0, 0)
; code(OPCODE_POP, "POP", 0, 0, 0)
; code(OPCODE_GEQ, "GEQ", 0, 0, 0)
; code(OPCODE_OUTPUT, "OUTPUT", 0, 0, 0)
; code(OPCODE_TOSTR, "TOSTR", 0, 0, 0)
; code(OPCODE_CONS, "CONS", 0, 0, 0)
; code(OPCODE_CAR, "CAR", 0, 0, 0)
; code(OPCODE_CDR, "CDR", 0, 0, 0)
; code(OPCODE_SET, "SET", 0, 1, 0)
; code(OPCODE_OUTPUT, "OUTPUT", 0, 0, 0)
; code(OPCODE_TOSTR, "TOSTR", 0, 0, 0)
; code(OPCODE_FRSTR, "FRSTR", 0, 0, 0)
; code(OPCODE_COMPILE,"COMPILE", 0, 0, 0)
; for i := 1 to expected_number_opcodes - 1
do if a[i] <> nil & a[i-1] = nil
then print(concatm("Error: Opcode info array incorrectly initialized!\n Opcode "
@ -569,7 +588,11 @@ let /* Booleans */
else if b = nil | b.first = nil
then ()
else if (a.first = nil & a.last <> nil) | (a.first <> nil & a.last = nil)
then print(concat("Error: Instruction list invariant not maintained! First is ", concat(if a.first = nil then "" else "not ", concat( "nil, second is ", concat(if a.last = nil then "" else "not ", "nil\n")))))
then print(concatm( "Error: Instruction list invariant not maintained! First is "
, if a.first = nil then "" else "not "
, "nil, second is "
, if a.last = nil then "" else "not "
, "nil\n"))
else if a.first = nil
then ( a.first := b.first
; a.last := b.last )
@ -1354,9 +1377,15 @@ let /* Booleans */
let var tape_size := tape.length
var tape := tape.tape
var continue := true
function vm_update () =
if tape[ip] = nil
then ip := -1
if not(continue)
then ()
else if tape[ip] = nil
then run_error("Missing instruction in tape")
else if not (0 <= ip & ip < tape_size)
then run_error("Instruction pointer out of bounds")
/* Integer binary operators */
else if let var op := tape[ip].opcode
@ -1544,10 +1573,10 @@ let /* Booleans */
; print("\n Scheme: ")
; print(safe_substring(source, tape[ip].pos_l, tape[ip].pos_r))
; print("\n")
; ip := -1
; continue := false
end
in while 0 <= ip & ip < tape_size
in while continue
do ( vm_update()
; if DEBUG_PRINT_STACK
then ( print("[")
@ -1555,42 +1584,20 @@ let /* Booleans */
; print("]: ")
; print(stack_to_string(stack))
; print("\n") ))
; if not (0 <= ip & ip < tape_size)
then print("Died due to out of bounds instruction pointer.\n")
end
/* Do stuff */
var test_text := "(begin (define add-three (lambda (x y z) (+ (+ x z) y))) \
\ (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 (f . l) (cdr l)) \
\ (define x 5) \
\ (define y '(1 2 3)) \
\ (display x) (newline) \
\ (display (fac x)) (newline) \
\ (display (faca x 1)) (newline) \
\ (display y) (newline) \
\ (display (car y)) (newline) \
\ (display (cdr y)) (newline) \
\ (set! x 10) \
\ (display x) (newline) \
var test_text :=
/* TODO: Improve top-level parsing */
let var text := "(begin "
var char := "BAD SHIT HAPPENED"
in while char <> ""
do ( char := getchar()
; text := concat(text, char) )
; concat(text, " )")
end
\ (define-syntax and \
\ (syntax-rules ()\
\ ((and) #t)\
\ ((and test) test)\
\ ((and test1 test2 ...)\
\ (if test1 (and test2 ...) #f))))\
\ (display (and #t #t)) (newline) \
\ (display (and #f #t)) (newline) \
\ (display (and #f #f)) (newline) \
\ (display (and #t #f)) (newline) \
\) "
var ignore := ( print("** Parsing **\n")
; print("Original : ")
; print(test_text)