core: Resurrect QUASIQUOTE=0.
* mes.c (mes_builtins) [!QUASIQUOTE]: Do not add unquoters. * module/mes/base-0.mes (push!, pop!, load, mes-use-module): Rewrite without quasiquote. * module/mes/quasiquote.mes (quasiquote): Rewrite using if, and. * module/srfi/srfi-0 (cond-expand): Rewrite without quasiquote.
This commit is contained in:
Jan Nieuwenhuizen
parent
2b577eaee0
commit
3a72f1f186
2
mes.c
2
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?
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue