andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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 2016-12-11 18:40:42 +01:00
parent 2b577eaee0
commit 3a72f1f186
5 changed files with 52 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
mes.c
View File

@ -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?

46
module/mes/base-0.mes
View File

@ -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))

83
module/mes/quasiquote.mes
View File

@ -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))

2
module/srfi/srfi-0.mes
View File

@ -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)))

5
quasiquote.c
View File

@ -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