From fcdcf72841cc668ed8635eb015e98c350c1ab62d Mon Sep 17 00:00:00 2001 From: Jon Michael Aanes Date: Thu, 3 Jan 2019 00:39:03 +0100 Subject: [PATCH] Syntax-rules macroes can now capture variables and use them in the template. Ellipsis not implemented yet. --- example.scm | 131 +++++++++++++++++++++++++++++++++++++++++------- tigerscheme.tig | 9 ++-- 2 files changed, 118 insertions(+), 22 deletions(-) diff --git a/example.scm b/example.scm index 5828518..2fa6f09 100644 --- a/example.scm +++ b/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) diff --git a/tigerscheme.tig b/tigerscheme.tig index b9970cd..992f045 100644 --- a/tigerscheme.tig +++ b/tigerscheme.tig @@ -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)