1
0

Syntax-rules macroes can now capture variables and use them in the template. Ellipsis not implemented yet.

This commit is contained in:
Jon Michael Aanes 2019-01-03 00:39:03 +01:00
parent c6150e3005
commit fcdcf72841
2 changed files with 118 additions and 22 deletions

View File

@ -3,6 +3,10 @@
;;; Standard lib, in scheme ;;; Standard lib, in scheme
; TODO: Fix below
(define eq? eqv?)
(define equal? eqv?)
; Lists ; Lists
(define (foldl f i l) (define (foldl f i l)
@ -37,6 +41,30 @@
x x
(list-tail (cdr x) (- k 1))))) (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 ; Math
@ -379,32 +407,86 @@
(header "Testing syntax-rules (move to macro once implemented)") (header "Testing syntax-rules (move to macro once implemented)")
(define equal? eqv?)
(define construct-pattern-predicate (define construct-pattern-predicate
(lambda (name pat) (lambda (name pat literals)
(if (if (symbol? pat) #t (number? pat)) (if (number? pat)
`(equal? ,name ,pat)
; Is symbol
(if (symbol? pat)
(if (member pat literals)
; Is literal
`(equal? ,name ',pat) `(equal? ,name ',pat)
; Or is variable binding
#t)
(if (null? pat) (if (null? pat)
`(null? ,name) `(null? ,name)
(if (pair? pat) (if (pair? pat)
`(if (pair? ,name) `(if (pair? ,name)
(if ,(construct-pattern-predicate `(car ,name) (car pat)) (if ,(construct-pattern-predicate `(car ,name)
,(construct-pattern-predicate `(cdr ,name) (cdr pat)) (car pat)
literals)
,(construct-pattern-predicate `(cdr ,name)
(cdr pat)
literals)
#f) #f)
#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 (define syntax-rules-rec
(lambda (macro-name var-name rules) (lambda (macro-name var-name literals rules)
(if (null? rules) (if (null? rules)
'doublefuck 'doublefuck
(let ((pattern (caar rules)) (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 (eqv? macro-name (car pattern))
`(if ,(construct-pattern-predicate var-name pattern) `(if ,(construct-pattern-predicate var-name
',result pattern
,(syntax-rules-rec macro-name var-name (cdr rules))) 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.") (begin (display "Incorrect usage of syntax-rules-rec: Each rule must have same first symbol.")
(display "\n\tFirst had ") (display "\n\tFirst had ")
@ -417,19 +499,16 @@
(define-syntax syntax-rules (define-syntax syntax-rules
(lambda (vo) (lambda (vo)
(let ((literals (cadr vo)) (let ((literals (cons (car (caaddr vo)) (cadr vo)))
(rules (cddr vo)) (rules (cddr vo))
(name (car (caaddr vo)))) (name (car (caaddr vo))))
`(lambda (vo2) `(lambda (vo2)
,( syntax-rules-rec name 'vo2 rules)) ,( syntax-rules-rec name 'vo2 literals rules ))
))) )))
; Define true ; Define true
(syntax-rules ()
((name ...) ...))
(define-syntax true (define-syntax true
(syntax-rules () (syntax-rules ()
((true) #t))) ((true) #t)))
@ -464,7 +543,7 @@
)) ))
(define-syntax derp (define-syntax derp
(syntax-rules () (syntax-rules (two)
((derp) 1) ((derp) 1)
((derp two) (+ (derp) (derp))) ((derp two) (+ (derp) (derp)))
)) ))
@ -475,6 +554,20 @@
( 2 . ,(derp two)) ( 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) (exit)

View File

@ -9,6 +9,9 @@ let /* Booleans */
var IS_NIL_TRUTHY : bool := false var IS_NIL_TRUTHY : bool := false
var HAS_NIL_SYMBOL : 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_STACK : bool := false
var DEBUG_PRINT_TAPE : bool := false var DEBUG_PRINT_TAPE : bool := false
var DEBUG_PRINT_PARSED : bool := false var DEBUG_PRINT_PARSED : bool := false
@ -16,8 +19,6 @@ let /* Booleans */
var DEBUG_PRINT_MACRO : bool := true var DEBUG_PRINT_MACRO : bool := true
var DEBUG_SHOW_FULL_ENVIRONMENT : bool := false var DEBUG_SHOW_FULL_ENVIRONMENT : bool := false
var ALLOW_TAPE_RESIZE : bool := true
var TRIGGERED_EXIT : bool := false var TRIGGERED_EXIT : bool := false
/* Basic utility */ /* Basic utility */
@ -2031,7 +2032,9 @@ let /* Booleans */
; /* TODO: Assert that there is something on the stack */ ; /* TODO: Assert that there is something on the stack */
derp := stack_pop(stack) derp := stack_pop(stack)
; if DEBUG_PRINT_MACRO ; 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(value_to_string(derp))
; print("\n") ) ; print("\n") )
; compile_rec(derp, can_tail_call, type_any) ; compile_rec(derp, can_tail_call, type_any)