Syntax-rules macroes can now capture variables and use them in the template. Ellipsis not implemented yet.
This commit is contained in:
parent
c6150e3005
commit
fcdcf72841
131
example.scm
131
example.scm
|
|
@ -3,6 +3,10 @@
|
|||
|
||||
;;; Standard lib, in scheme
|
||||
|
||||
; TODO: Fix below
|
||||
(define eq? eqv?)
|
||||
(define equal? eqv?)
|
||||
|
||||
; Lists
|
||||
|
||||
(define (foldl f i l)
|
||||
|
|
@ -37,6 +41,30 @@
|
|||
x
|
||||
(list-tail (cdr x) (- k 1)))))
|
||||
|
||||
(define generic-member
|
||||
(lambda (compare obj ls)
|
||||
(if (null? ls)
|
||||
#f
|
||||
(if (compare obj (car ls))
|
||||
ls
|
||||
(generic-member compare obj (cdr ls))))))
|
||||
|
||||
(define (memq obj ls) (generic-member eq? obj ls))
|
||||
(define (memv obj ls) (generic-member eqv? obj ls))
|
||||
(define (member obj ls) (generic-member equal? obj ls))
|
||||
|
||||
(define (generic-assoc compare key als)
|
||||
(if (null? als)
|
||||
#f
|
||||
(if (compare key (caar als))
|
||||
(cdr (car als))
|
||||
(generic-assoc compare key (cdr als)))))
|
||||
|
||||
(define (assq obj ls) (generic-assoc eq? obj ls))
|
||||
(define (assv obj ls) (generic-assoc eqv? obj ls))
|
||||
(define (assoc obj ls) (generic-assoc equal? obj ls))
|
||||
|
||||
|
||||
|
||||
; Math
|
||||
|
||||
|
|
@ -379,32 +407,86 @@
|
|||
|
||||
(header "Testing syntax-rules (move to macro once implemented)")
|
||||
|
||||
(define equal? eqv?)
|
||||
|
||||
(define construct-pattern-predicate
|
||||
(lambda (name pat)
|
||||
(if (if (symbol? pat) #t (number? pat))
|
||||
`(equal? ,name ',pat)
|
||||
(lambda (name pat literals)
|
||||
(if (number? pat)
|
||||
`(equal? ,name ,pat)
|
||||
|
||||
; Is symbol
|
||||
(if (symbol? pat)
|
||||
(if (member pat literals)
|
||||
; Is literal
|
||||
`(equal? ,name ',pat)
|
||||
; Or is variable binding
|
||||
#t)
|
||||
|
||||
(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))
|
||||
(if ,(construct-pattern-predicate `(car ,name)
|
||||
(car pat)
|
||||
literals)
|
||||
,(construct-pattern-predicate `(cdr ,name)
|
||||
(cdr pat)
|
||||
literals)
|
||||
#f)
|
||||
#f)
|
||||
'fuck )))))
|
||||
'fuck ))))))
|
||||
|
||||
(define (find-variable-bindings literals path pattern)
|
||||
; Is symbol
|
||||
(if (if (symbol? pattern) (not (member pattern literals)) #f)
|
||||
`((,pattern ,path))
|
||||
|
||||
; Is pair
|
||||
|
||||
(if (pair? pattern)
|
||||
(append (find-variable-bindings literals `(car ,path) (car pattern))
|
||||
(find-variable-bindings literals `(cdr ,path) (cdr pattern)))
|
||||
|
||||
; Is anything else
|
||||
; TODO: Vector patterns
|
||||
|
||||
'() )))
|
||||
|
||||
(define (construct-result bindings template)
|
||||
; Is symbol
|
||||
(if (if (symbol? template) (assoc template bindings) #f)
|
||||
(cons 'unquote (cons template '()))
|
||||
|
||||
; Is pair
|
||||
|
||||
(if (pair? template)
|
||||
(cons (construct-result bindings (car template))
|
||||
(construct-result bindings (cdr template)))
|
||||
|
||||
; Is anything else
|
||||
; TODO: Vector patterns
|
||||
|
||||
template )))
|
||||
|
||||
(define syntax-rules-rec
|
||||
(lambda (macro-name var-name rules)
|
||||
(lambda (macro-name var-name literals rules)
|
||||
(if (null? rules)
|
||||
'doublefuck
|
||||
(let ((pattern (caar rules))
|
||||
(result (cadar rules)))
|
||||
(result (cadar rules))
|
||||
(bindings (find-variable-bindings literals var-name (caar rules)))
|
||||
)
|
||||
(if (eqv? macro-name (car pattern))
|
||||
`(if ,(construct-pattern-predicate var-name pattern)
|
||||
',result
|
||||
,(syntax-rules-rec macro-name var-name (cdr rules)))
|
||||
`(if ,(construct-pattern-predicate var-name
|
||||
pattern
|
||||
literals )
|
||||
(let ,bindings
|
||||
,(let ((sefijoesfeji (construct-result bindings result)))
|
||||
(begin (display "Mjerf: ")
|
||||
(display sefijoesfeji)
|
||||
(newline)
|
||||
(cons 'quasiquote (cons sefijoesfeji '()))))
|
||||
)
|
||||
,(syntax-rules-rec macro-name var-name literals (cdr rules)))
|
||||
|
||||
(begin (display "Incorrect usage of syntax-rules-rec: Each rule must have same first symbol.")
|
||||
(display "\n\tFirst had ")
|
||||
|
|
@ -417,19 +499,16 @@
|
|||
|
||||
(define-syntax syntax-rules
|
||||
(lambda (vo)
|
||||
(let ((literals (cadr vo))
|
||||
(let ((literals (cons (car (caaddr vo)) (cadr vo)))
|
||||
(rules (cddr vo))
|
||||
(name (car (caaddr vo))))
|
||||
|
||||
`(lambda (vo2)
|
||||
,( syntax-rules-rec name 'vo2 rules))
|
||||
,( syntax-rules-rec name 'vo2 literals rules ))
|
||||
)))
|
||||
|
||||
; Define true
|
||||
|
||||
(syntax-rules ()
|
||||
((name ...) ...))
|
||||
|
||||
(define-syntax true
|
||||
(syntax-rules ()
|
||||
((true) #t)))
|
||||
|
|
@ -464,7 +543,7 @@
|
|||
))
|
||||
|
||||
(define-syntax derp
|
||||
(syntax-rules ()
|
||||
(syntax-rules (two)
|
||||
((derp) 1)
|
||||
((derp two) (+ (derp) (derp)))
|
||||
))
|
||||
|
|
@ -475,6 +554,20 @@
|
|||
( 2 . ,(derp two))
|
||||
))
|
||||
|
||||
(define-syntax +1
|
||||
(syntax-rules ()
|
||||
((+1 n) (+ 1 n))))
|
||||
|
||||
(test "Defining +1 using syntax-rules."
|
||||
`(
|
||||
( 6 . ,(+1 5))
|
||||
( 1 . ,(+1 0))
|
||||
( 0 . ,(+1 -1))
|
||||
))
|
||||
|
||||
(exit)
|
||||
|
||||
|
||||
;;;;; ;
|
||||
|
||||
(exit)
|
||||
|
|
|
|||
|
|
@ -9,6 +9,9 @@ let /* Booleans */
|
|||
|
||||
var IS_NIL_TRUTHY : bool := false
|
||||
var HAS_NIL_SYMBOL : bool := false
|
||||
var ALLOW_TAPE_RESIZE : bool := true
|
||||
var ASSUME_NO_OVERWRITE_STDLIB : bool := true
|
||||
|
||||
var DEBUG_PRINT_STACK : bool := false
|
||||
var DEBUG_PRINT_TAPE : bool := false
|
||||
var DEBUG_PRINT_PARSED : bool := false
|
||||
|
|
@ -16,8 +19,6 @@ let /* Booleans */
|
|||
var DEBUG_PRINT_MACRO : bool := true
|
||||
var DEBUG_SHOW_FULL_ENVIRONMENT : bool := false
|
||||
|
||||
var ALLOW_TAPE_RESIZE : bool := true
|
||||
|
||||
var TRIGGERED_EXIT : bool := false
|
||||
|
||||
/* Basic utility */
|
||||
|
|
@ -2031,7 +2032,9 @@ let /* Booleans */
|
|||
; /* TODO: Assert that there is something on the stack */
|
||||
derp := stack_pop(stack)
|
||||
; if DEBUG_PRINT_MACRO
|
||||
then ( print("Macro expanded to: ")
|
||||
then ( print("Macro \"")
|
||||
; print(ast.val_car.val_s )
|
||||
; print("\" expanded to: ")
|
||||
; print(value_to_string(derp))
|
||||
; print("\n") )
|
||||
; compile_rec(derp, can_tail_call, type_any)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user