Slow work on syntax-rules macro system.
This commit is contained in:
parent
5b508bf75c
commit
c6150e3005
181
example.scm
181
example.scm
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -1024,12 +1024,13 @@ 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)
|
||||
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
|
||||
var STD_LIB_ID_FUNCTION: scheme_value := nil
|
||||
|
|
@ -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 "
|
||||
then ( compile_error( concat5("Error in atom_to_list: Expected "
|
||||
, type_id_to_name(expected_type)
|
||||
, " but got "
|
||||
, value_to_string(sym)
|
||||
, "!\n"))
|
||||
, "!\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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user