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 "string.environment.i"
|
||||||
#include "type.environment.i"
|
#include "type.environment.i"
|
||||||
|
|
||||||
|
#if QUASIQUOTE
|
||||||
SCM cell_unquote = assq_ref_cache (cell_symbol_unquote, a);
|
SCM cell_unquote = assq_ref_cache (cell_symbol_unquote, a);
|
||||||
SCM cell_unquote_splicing = assq_ref_cache (cell_symbol_unquote_splicing, a);
|
SCM cell_unquote_splicing = assq_ref_cache (cell_symbol_unquote_splicing, a);
|
||||||
SCM the_unquoters = cons (cons (cell_symbol_unquote, cell_unquote),
|
SCM the_unquoters = cons (cons (cell_symbol_unquote, cell_unquote),
|
||||||
cons (cons (cell_symbol_unquote_splicing, cell_unquote_splicing),
|
cons (cons (cell_symbol_unquote_splicing, cell_unquote_splicing),
|
||||||
cell_nil));
|
cell_nil));
|
||||||
a = acons (cell_symbol_the_unquoters, the_unquoters, a);
|
a = acons (cell_symbol_the_unquoters, the_unquoters, a);
|
||||||
|
#endif
|
||||||
|
|
||||||
a = add_environment (a, "*foo-bar-baz*", cell_nil); // FIXME: some off-by one?
|
a = add_environment (a, "*foo-bar-baz*", cell_nil); // FIXME: some off-by one?
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -90,20 +90,21 @@
|
||||||
|
|
||||||
(define *input-ports* '())
|
(define *input-ports* '())
|
||||||
(define-macro (push! stack o)
|
(define-macro (push! stack o)
|
||||||
`(begin
|
(cons
|
||||||
(set! ,stack (cons ,o ,stack))
|
'begin
|
||||||
,stack))
|
(list
|
||||||
|
(list 'set! stack (list cons o stack))
|
||||||
|
stack)))
|
||||||
(define-macro (pop! stack)
|
(define-macro (pop! stack)
|
||||||
`(let ((o (car ,stack)))
|
(list 'let (list (list 'o (list car stack)))
|
||||||
(set! ,stack (cdr ,stack))
|
(list 'set! stack (list cdr stack))
|
||||||
o))
|
'o))
|
||||||
(define-macro (load file)
|
(define-macro (load file)
|
||||||
`(begin
|
(list 'begin
|
||||||
(push! *input-ports* (current-input-port))
|
(list 'push! '*input-ports* (list current-input-port))
|
||||||
(set-current-input-port (open-input-file ,file))
|
(list 'set-current-input-port (list open-input-file file))
|
||||||
(primitive-load)
|
(list 'primitive-load)
|
||||||
(set-current-input-port (pop! *input-ports*))))
|
(list 'set-current-input-port (list 'pop! '*input-ports*))))
|
||||||
|
|
||||||
(define (memq x lst)
|
(define (memq x lst)
|
||||||
(if (null? lst) #f
|
(if (null? lst) #f
|
||||||
(if (eq? x (car lst)) lst
|
(if (eq? x (car lst)) lst
|
||||||
|
|
@ -126,18 +127,19 @@
|
||||||
a)))
|
a)))
|
||||||
(set-current-input-port (pop! *input-ports*))
|
(set-current-input-port (pop! *input-ports*))
|
||||||
x))
|
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)
|
(define (not x)
|
||||||
(if x #f #t))
|
(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 (srfi srfi-0))
|
||||||
(mes-use-module (mes base))
|
(mes-use-module (mes base))
|
||||||
|
|
|
||||||
|
|
@ -28,67 +28,26 @@
|
||||||
(mes-use-module (mes base))
|
(mes-use-module (mes base))
|
||||||
|
|
||||||
(define-macro (quasiquote x)
|
(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)
|
(define (loop x)
|
||||||
;;(display "LOOP") (newline)
|
(if (not (pair? x)) (cons 'quote (cons x '()))
|
||||||
(cond
|
(if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
|
||||||
((not (pair? x)) (cons 'quote (cons x '())))
|
(if (eq? (car x) 'unquote) (cadr x)
|
||||||
((eq? (car x) 'quasiquote) (check x) (loop (loop (cadr x))))
|
(if (and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
|
||||||
((eq? (car x) 'unquote) (check x) (cadr x))
|
((lambda (d)
|
||||||
((eq? (car x) 'unquote-splicing)
|
(list 'append (cadar x) d))
|
||||||
(error 'unquote-splicing "invalid context for ~s" x))
|
(loop (cdr x)))
|
||||||
(;;(and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
|
((lambda (a d)
|
||||||
(cond ((pair? (car x)) (eq? (caar x) 'unquote-splicing))
|
(if (pair? d)
|
||||||
(#t #f))
|
(if (eq? (car d) 'quote)
|
||||||
(check (car x))
|
(if (and (pair? a) (eq? (car a) 'quote))
|
||||||
;; (let ((d (loop (cdr x))))
|
(list 'quote (cons (cadr a) (cadr d)))
|
||||||
;; (cond ((equal? d '(quote ())) (cadar x))
|
(if (null? (cadr d))
|
||||||
;; ;;(#t `(append ,(cadar x) ,d))
|
(list 'list a)
|
||||||
;; (#t (list 'append (cadar x) d))
|
(list 'cons* a d)))
|
||||||
;; ))
|
(if (memq (car d) '(list cons*))
|
||||||
((lambda (d)
|
(cons (car d) (cons a (cdr d)))
|
||||||
(list 'append (cadar x) d))
|
(list 'cons* a d)))
|
||||||
(loop (cdr x))))
|
(list 'cons* a d)))
|
||||||
(#t
|
(loop (car x))
|
||||||
;; (let ((a (loop (car x)))
|
(loop (cdr 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)))
|
|
||||||
|
|
||||||
)))
|
|
||||||
(loop x))
|
(loop x))
|
||||||
|
|
|
||||||
|
|
@ -32,4 +32,4 @@
|
||||||
(cond-expand-expander (cdr clauses))))
|
(cond-expand-expander (cdr clauses))))
|
||||||
|
|
||||||
(define-macro (cond-expand . 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 add_unquoters (SCM a){}
|
||||||
SCM eval_quasiquote (SCM e, SCM a){}
|
SCM eval_quasiquote (SCM e, SCM a){}
|
||||||
|
|
||||||
|
SCM unquote (SCM x){}
|
||||||
|
SCM unquote_splicing (SCM x){}
|
||||||
|
SCM vm_eval_quasiquote () {}
|
||||||
|
|
||||||
#endif // QUASIQUOTE
|
#endif // QUASIQUOTE
|
||||||
|
|
||||||
#if QUASISYNTAX
|
#if QUASISYNTAX
|
||||||
|
|
@ -112,7 +116,6 @@ SCM syntax (SCM x){}
|
||||||
SCM unsyntax (SCM x){}
|
SCM unsyntax (SCM x){}
|
||||||
SCM unsyntax_splicing (SCM x){}
|
SCM unsyntax_splicing (SCM x){}
|
||||||
SCM add_unsyntaxers (SCM a){}
|
SCM add_unsyntaxers (SCM a){}
|
||||||
SCM eval_unsyntax (SCM e, SCM a){}
|
|
||||||
SCM eval_quasisyntax (SCM e, SCM a){}
|
SCM eval_quasisyntax (SCM e, SCM a){}
|
||||||
|
|
||||||
#endif // !QUASISYNTAX
|
#endif // !QUASISYNTAX
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue