Jmaa/tiger-scheme
1
0
Fork 0
Code

Slow work on syntax-rules macro system.

Browse Source
This commit is contained in:
Jon Michael Aanes 2019-01-02 20:16:43 +01:00
parent 5b508bf75c
commit c6150e3005
2 changed files with 268 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

181
example.scm
View File

@ -1,4 +1,6 @@
;;; Standard lib, in scheme
; Lists
@ -28,6 +30,7 @@
(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)
@ -48,6 +51,42 @@
(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)
@ -78,6 +117,7 @@
(display y) (newline)
(display (car y)) (newline)
(display (cdr y)) (newline)
(display (append '(1 2 3) '(4 5 6))) (newline)
; Test system
@ -142,6 +182,11 @@
(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)
@ -290,8 +335,22 @@
(display (x))
(display "\n")
(display "Test defining let using macroes:\n Expect: 23 82 105\n Gotten: ")
(display "\n* R5RS: Lexical convention *\n")
(define-syntax let
(lambda (vo)
`( (lambda ,(map car (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
@ -318,22 +377,107 @@
; Test syntax-rules
(newline)
(display "* Testing syntax-rules (move to macro once implemented) *")
(newline)
(header "Testing syntax-rules (move to macro once implemented)")
(display "Attempting to define true using syntax rules.\n\tExpect: #t #f\n\tGotten: ")
(define equal? eqv?)
(define construct-pattern-predicate
(lambda (name pat)
(if (if (symbol? pat) #t (number? pat))
`(equal? ,name ',pat)
(if (null? pat)
`(null? ,name)
(if (pair? pat)
`(if (pair? ,name)
(if ,(construct-pattern-predicate `(car ,name) (car pat))
,(construct-pattern-predicate `(cdr ,name) (cdr pat))
#f)
#f)
'fuck )))))
(define syntax-rules-rec
(lambda (macro-name var-name rules)
(if (null? rules)
'doublefuck
(let ((pattern (caar rules))
(result (cadar rules)))
(if (eqv? macro-name (car pattern))
`(if ,(construct-pattern-predicate var-name pattern)
',result
,(syntax-rules-rec macro-name var-name (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 (cadr vo))
(rules (cddr vo))
(name (car (caaddr vo))))
`(lambda (vo2)
,( syntax-rules-rec name 'vo2 rules))
)))
; Define true
(syntax-rules ()
((name ...) ...))
(define-syntax true
(syntax-rules ()
((true) #t)))
(display (true))
(display " ")
(display (not (true)))
(test "Attempting to define true using syntax rules."
`(
( #t . ,(true))
( #f . ,(not (true)))
))
;
(display "Attempting to define and using syntax rules.\n\tExpect: #t #f #f #f\n\tGotten: ")
; 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 derp
(syntax-rules ()
((derp) 1)
((derp two) (+ (derp) (derp)))
))
(test "Defining weird macroes using syntax-rules."
`(
( 1 . ,(derp))
( 2 . ,(derp two))
))
;;;;; ;
(exit)
(define-syntax and
(syntax-rules ()
@ -342,10 +486,21 @@
((and test1 test2 ...)
(if test1 (and test2 ...) #f))))
(display (and #t #t)) (display " ")
(display (and #f #t)) (display " ")
(display (and #f #f)) (display " ")
(display (and #t #f)) (newline)
(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.

111
tigerscheme.tig
View File

@ -1024,11 +1024,12 @@ let /* Booleans */
then app_insn(prev_insns, OPCODE_RET, 1, "", pos_l, pos_r)
function tail_position_one (insn: vm_insn, return_now: bool): vm_insn_list =
let var insns := single_insn(insn)
in tail_position(insns, return_now, insn.pos_l, insn.pos_r)
; insns
end
if insn = nil
then nil
else let var insns := single_insn(insn)
in tail_position(insns, return_now, insn.pos_l, insn.pos_r)
; insns
end
var ENV_EMPTY : vm_env := nil_val()
var ENV_STD : vm_env := ENV_EMPTY
@ -1108,10 +1109,53 @@ let /* Booleans */
; app(OPCODE_CONS, 0, "")
; app(OPCODE_RET, 1, "")
; stdfun("caaaar")
; app(OPCODE_CAR, 0, "")
; stdfun("caaar")
; app(OPCODE_CAR, 0, "")
; stdfun("caar")
; app(OPCODE_CAR, 0, "")
; stdfun("car")
; app(OPCODE_CAR, 0, "")
; app(OPCODE_RET, 1, "")
; stdfun("cadddr")
; app(OPCODE_CDR, 0, "")
; stdfun("caddr")
; app(OPCODE_CDR, 0, "")
; stdfun("cadr")
; app(OPCODE_CDR, 0, "")
; app(OPCODE_CAR, 0, "")
; app(OPCODE_RET, 1, "")
; stdfun("caadar")
; app(OPCODE_CAR, 0, "")
; app(OPCODE_DGOTO, 2, "")
; stdfun("caaddr")
; app(OPCODE_CDR, 0, "")
; stdfun("caadr")
; app(OPCODE_CDR, 0, "")
; app(OPCODE_CAR, 0, "")
; app(OPCODE_CAR, 0, "")
; app(OPCODE_RET, 1, "")
; stdfun("cadadr")
; app(OPCODE_CDR, 0, "")
; app(OPCODE_DGOTO, 2, "")
; stdfun("cadaar")
; app(OPCODE_CAR, 0, "")
; stdfun("cadar")
; app(OPCODE_CAR, 0, "")
; app(OPCODE_CDR, 0, "")
; app(OPCODE_CAR, 0, "")
; app(OPCODE_RET, 1, "")
; stdfun("cddddr")
; app(OPCODE_CDR, 0, "")
; stdfun("cdddr")
; app(OPCODE_CDR, 0, "")
; stdfun("cddr")
; app(OPCODE_CDR, 0, "")
; stdfun("cdr")
; app(OPCODE_CDR, 0, "")
; app(OPCODE_RET, 1, "")
@ -1272,9 +1316,24 @@ let /* Booleans */
; app2(OPCODE_PUSH, VALUE_UNSPECIFIED)
; app(OPCODE_RET, 1, "")
; stdfun("debug-show-env")
; app(OPCODE_DEBUG, 3, "")
; app2(OPCODE_PUSH, VALUE_UNSPECIFIED)
; app(OPCODE_RET, 1, "")
; stdfun("exit")
; app(OPCODE_EXIT, true, "")
/* Should never be called as function! */
; stdfun("quote")
; stdfun("quasiquote")
; stdfun("unquote")
; stdfun("unquote-splicing")
; app2(OPCODE_PUSH, string_val("Error! This is a macro and cannot be called as an actual function!\n"))
; app(OPCODE_OUTPUT, 0, "")
; app(OPCODE_EXIT, true, "")
/* Misc??? */
; stdfun("symbol?")
; app(OPCODE_TYPEOF, 0, "")
@ -1401,6 +1460,12 @@ let /* Booleans */
| symbol = "quasiquote" | symbol = "unquote" | symbol = "unquote-splicing"
| symbol = "define" | symbol = "define-syntax"
function is_not_variable (symbol: string): bool =
symbol = "if" | symbol = "let" | symbol = "unquote"
| symbol = "lambda" | symbol = "quote" | symbol = "quasiquote"
| symbol = "unquote" | symbol = "unquote-splicing"
| symbol = ""
/**** Compilation ****/
function compile_to_vm ( ast: sexp_ast
@ -1428,11 +1493,21 @@ let /* Booleans */
else if expected_type <> 0
& sym.typ <> type_symbol
& sym.typ <> expected_type
then ( print(concat5( "Error in atom_to_list: Expected "
, type_id_to_name(expected_type)
, " but got "
, value_to_string(sym)
, "!\n"))
then ( compile_error( concat5("Error in atom_to_list: Expected "
, type_id_to_name(expected_type)
, " but got "
, value_to_string(sym)
, "!\n")
, sym)
; nil )
else if is_symbol(sym) & is_not_variable(sym.val_s)
then ( compile_error(concat5( "Error in atom_to_list: Impossible to load variable "
, sym.val_s
, " because it is not a variable!\n"
, ""
, "")
, sym)
; nil )
else if is_symbol(sym)
@ -1455,7 +1530,9 @@ let /* Booleans */
let function rec (insns: vm_insn_list_link, sum: int): int =
if insns = nil then sum
else rec(insns.next, 1 + sum)
in rec(insns.first, 0)
in if insns = nil
then 0
else rec(insns.first, 0)
end
function set_tree_positions ( ast: sexp_ast
@ -1784,6 +1861,16 @@ let /* Booleans */
( compile_error("Attempting to compile free-standing (). This is not allowed.\n Must use \"'()\", if nil value is wanted.", ast)
; nil )
/* Throw error if encountering unquote or
* unquote-splicing outside of quasiquote */
else if ast.typ = type_symbol
& (ast.val_s = "unquote" | ast.val_s = "unquote-splicing")
then ( compile_error(concat5( "Attempting to use \""
, ast.val_s
, "\" outside of a quasiquote! It may be some misplaced brackets."
, "", ""), ast)
; nil )
/* Handle numbers and other constants */
else if ast.typ <> type_pair then
tail_position_one( atom_to_insn(ast, ast.pos_l, ast.pos_r, expected_type)
@ -2467,6 +2554,8 @@ let /* Booleans */
then DEBUG_PRINT_TAPE := val_b
else if tape[ip].arg1 = 2
then DEBUG_PRINT_STACK := val_b
else if tape[ip].arg1 = 3
then DEBUG_SHOW_FULL_ENVIRONMENT := val_b
else run_error("Attempting to use unknown debug option!")
; ip := ip + 1