diff --git a/mes.c b/mes.c index 951f7518..24a26dc7 100644 --- a/mes.c +++ b/mes.c @@ -1121,12 +1121,14 @@ mes_builtins (SCM a) #include "string.environment.i" #include "type.environment.i" +#if QUASIQUOTE SCM cell_unquote = assq_ref_cache (cell_symbol_unquote, a); SCM cell_unquote_splicing = assq_ref_cache (cell_symbol_unquote_splicing, a); SCM the_unquoters = cons (cons (cell_symbol_unquote, cell_unquote), cons (cons (cell_symbol_unquote_splicing, cell_unquote_splicing), cell_nil)); a = acons (cell_symbol_the_unquoters, the_unquoters, a); +#endif a = add_environment (a, "*foo-bar-baz*", cell_nil); // FIXME: some off-by one? diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes index 9128020d..bc5c1103 100644 --- a/module/mes/base-0.mes +++ b/module/mes/base-0.mes @@ -90,20 +90,21 @@ (define *input-ports* '()) (define-macro (push! stack o) - `(begin - (set! ,stack (cons ,o ,stack)) - ,stack)) + (cons + 'begin + (list + (list 'set! stack (list cons o stack)) + stack))) (define-macro (pop! stack) - `(let ((o (car ,stack))) - (set! ,stack (cdr ,stack)) - o)) + (list 'let (list (list 'o (list car stack))) + (list 'set! stack (list cdr stack)) + 'o)) (define-macro (load file) - `(begin - (push! *input-ports* (current-input-port)) - (set-current-input-port (open-input-file ,file)) - (primitive-load) - (set-current-input-port (pop! *input-ports*)))) - + (list 'begin + (list 'push! '*input-ports* (list current-input-port)) + (list 'set-current-input-port (list open-input-file file)) + (list 'primitive-load) + (list 'set-current-input-port (list 'pop! '*input-ports*)))) (define (memq x lst) (if (null? lst) #f (if (eq? x (car lst)) lst @@ -126,18 +127,19 @@ a))) (set-current-input-port (pop! *input-ports*)) x)) -(define-macro (mes-use-module module) - `(begin - (if (not (memq (string->symbol ,(module->file module)) *modules*)) - (begin - (set! *modules* (cons (string->symbol ,(module->file module)) *modules*)) - ;; (display "loading file=" (current-error-port)) - ;; (display ,(module->file module) (current-error-port)) - ;; (newline (current-error-port)) - (load ,(string-append *mes-prefix* (module->file module))))))) - (define (not x) (if x #f #t)) +(define-macro (mes-use-module module) + (list + 'begin + (list 'if (list 'not (list 'memq (list string->symbol (module->file module)) '*modules*)) + (list + 'begin + (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*)) + ;; (list display "loading file=" (list current-error-port)) + ;; (list display (module->file module) (list current-error-port)) + ;; (list newline (list current-error-port)) + (list 'load (list string-append '*mes-prefix* (module->file module))))))) (mes-use-module (srfi srfi-0)) (mes-use-module (mes base)) diff --git a/module/mes/quasiquote.mes b/module/mes/quasiquote.mes index 8712370a..05bf41b8 100644 --- a/module/mes/quasiquote.mes +++ b/module/mes/quasiquote.mes @@ -28,67 +28,26 @@ (mes-use-module (mes base)) (define-macro (quasiquote x) - (define (check x) - (cond ((pair? (cdr x)) (cond ((null? (cddr x))) - (#t (error (car x) "invalid form ~s" x)))))) (define (loop x) - ;;(display "LOOP") (newline) - (cond - ((not (pair? x)) (cons 'quote (cons x '()))) - ((eq? (car x) 'quasiquote) (check x) (loop (loop (cadr x)))) - ((eq? (car x) 'unquote) (check x) (cadr x)) - ((eq? (car x) 'unquote-splicing) - (error 'unquote-splicing "invalid context for ~s" x)) - (;;(and (pair? (car x)) (eq? (caar x) 'unquote-splicing)) - (cond ((pair? (car x)) (eq? (caar x) 'unquote-splicing)) - (#t #f)) - (check (car x)) - ;; (let ((d (loop (cdr x)))) - ;; (cond ((equal? d '(quote ())) (cadar x)) - ;; ;;(#t `(append ,(cadar x) ,d)) - ;; (#t (list 'append (cadar x) d)) - ;; )) - ((lambda (d) - (list 'append (cadar x) d)) - (loop (cdr x)))) - (#t - ;; (let ((a (loop (car x))) - ;; (d (loop (cdr x)))) - ;; (cond ((pair? d) - ;; (cond ((eq? (car d) 'quote) - ;; (cond ((and (pair? a) (eq? (car a) 'quote)) - ;; `'(,(cadr a) . ,(cadr d))) - ;; (#t (cond ((null? (cadr d)) - ;; `(list ,a)) - ;; (#t `(cons* ,a ,d)))))) - ;; (#t (cond ((memq (car d) '(list cons*)) - ;; `(,(car d) ,a ,@(cdr d))) - ;; (#t `(cons* ,a ,d)))))) - ;; (#t `(cons* ,a ,d)))) - - ((lambda (a d) - ;;(display "LAMBDA AD") (newline) - (cond ((pair? d) - (cond ((eq? (car d) 'quote) - (cond (;;(and (pair? a) (eq? (car a) 'quote)) - (cond ((pair? a) (eq? (car a) 'quote)) - (#t #f)) - (list 'quote (cons (cadr a) (cadr d)))) - (#t (cond ((null? (cadr d)) - (list 'list a)) - (#t (list 'cons* a d)))))) - (#t (cond ((memq (car d) '(list cons*)) - ;;`(,(car d) ,a ,@(cdr d)) - (cons (car d) (cons a (cdr d))) - ) - ;;(#t `(cons* ,a ,d)) - (#t (list 'cons* a d)) - )))) - ;;(#t `(cons* ,a ,d)) - (#t (list 'cons* a d)) - )) - (loop (car x)) - (loop (cdr x))) - - ))) + (if (not (pair? x)) (cons 'quote (cons x '())) + (if (eq? (car x) 'quasiquote) (loop (loop (cadr x))) + (if (eq? (car x) 'unquote) (cadr x) + (if (and (pair? (car x)) (eq? (caar x) 'unquote-splicing)) + ((lambda (d) + (list 'append (cadar x) d)) + (loop (cdr x))) + ((lambda (a d) + (if (pair? d) + (if (eq? (car d) 'quote) + (if (and (pair? a) (eq? (car a) 'quote)) + (list 'quote (cons (cadr a) (cadr d))) + (if (null? (cadr d)) + (list 'list a) + (list 'cons* a d))) + (if (memq (car d) '(list cons*)) + (cons (car d) (cons a (cdr d))) + (list 'cons* a d))) + (list 'cons* a d))) + (loop (car x)) + (loop (cdr x)))))))) (loop x)) diff --git a/module/srfi/srfi-0.mes b/module/srfi/srfi-0.mes index e5ff2e5b..5330b067 100644 --- a/module/srfi/srfi-0.mes +++ b/module/srfi/srfi-0.mes @@ -32,4 +32,4 @@ (cond-expand-expander (cdr clauses)))) (define-macro (cond-expand . clauses) - `(begin ,@(cond-expand-expander clauses))) + (cons 'begin (cond-expand-expander clauses))) diff --git a/quasiquote.c b/quasiquote.c index 6230f087..6a7cb5bc 100644 --- a/quasiquote.c +++ b/quasiquote.c @@ -65,6 +65,10 @@ add_unquoters (SCM a) SCM add_unquoters (SCM a){} SCM eval_quasiquote (SCM e, SCM a){} +SCM unquote (SCM x){} +SCM unquote_splicing (SCM x){} +SCM vm_eval_quasiquote () {} + #endif // QUASIQUOTE #if QUASISYNTAX @@ -112,7 +116,6 @@ SCM syntax (SCM x){} SCM unsyntax (SCM x){} SCM unsyntax_splicing (SCM x){} SCM add_unsyntaxers (SCM a){} -SCM eval_unsyntax (SCM e, SCM a){} SCM eval_quasisyntax (SCM e, SCM a){} #endif // !QUASISYNTAX