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

implement unquote-splicing, cleanup some macros

This commit is contained in:
Jan Nieuwenhuizen 2016-07-16 17:18:11 +02:00
parent 02dc00d11c
commit dc8325ded3
4 changed files with 104 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
mes.c
View File

@ -92,6 +92,7 @@ scm scm_symbol_quote = {SYMBOL, "quote"};
#if QUASIQUOTE
scm scm_symbol_quasiquote = {SYMBOL, "quasiquote"};
scm scm_symbol_unquote = {SYMBOL, "unquote"};
scm scm_symbol_unquote_splicing = {SYMBOL, "unquote-splicing"};
#endif
#if MACROS
scm scm_macro = {SYMBOL, "*macro*"};
@ -200,6 +201,12 @@ quote (scm *x)
}
#if QUASIQUOTE
scm *
quasiquote (scm *x)
{
return cons (&scm_symbol_quasiquote, x);
}
scm *
unquote (scm *x)
{
@ -207,9 +214,9 @@ unquote (scm *x)
}
scm *
quasiquote (scm *x)
unquote_splicing (scm *x)
{
return cons (&scm_symbol_quasiquote, x);
return cons (&scm_symbol_unquote_splicing, x);
}
#endif
@ -674,9 +681,11 @@ lookup (char *x, scm *a)
#if QUASIQUOTE
if (*x == '`') return &scm_symbol_quasiquote;
if (*x == ',') return &scm_symbol_unquote;
if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
if (*x == ',' && *(x+1) == '@') return &scm_symbol_unquote_splicing;
if (*x == ',') return &scm_symbol_unquote;
if (!strcmp (x, scm_symbol_quasiquote.name)) return &scm_symbol_quasiquote;
if (!strcmp (x, scm_symbol_unquote.name)) return &scm_symbol_unquote;
if (!strcmp (x, scm_symbol_unquote_splicing.name)) return &scm_symbol_unquote_splicing;
#endif
return make_symbol (x);
@ -798,6 +807,10 @@ display_helper (scm *x, bool cont, char *sep, bool quote)
printf (",");
return display_helper (car (cdr (x)), cont, "", true);
}
if (car (x) == &scm_unquote_splicing) {
printf (",@");
return display_helper (car (cdr (x)), cont, "", true);
}
#endif
#endif
if (!cont) printf ("(");
@ -885,6 +898,9 @@ readword (int c, char* w, scm *a)
if (c == '(') {ungetchar (c); return lookup (w, a);}
if (c == ')' && !w) {ungetchar (c); return &scm_nil;}
if (c == ')') {ungetchar (c); return lookup (w, a);}
if (c == ',' && peekchar () == '@') {getchar (); return cons (lookup (",@", a),
cons (readword (getchar (), w, a),
&scm_nil));}
if ((c == '\''
#if QUASIQUOTE
|| c == '`'
@ -976,7 +992,15 @@ readlist (scm *a)
scm *
readenv (scm *a)
{
#if DEBUG
scm *e = readword (getchar (), 0, a);
printf ("readenv: ");
display (e);
puts ("");
return e;
#else
return readword (getchar (), 0, a);
#endif
}
// Extras to make interesting program
@ -1086,15 +1110,17 @@ eval_quasiquote (scm *e, scm *a)
#endif
if (e == &scm_nil) return e;
else if (atom_p (e) == &scm_t) return e;
else if (eq_p (car (e), &scm_symbol_quote) == &scm_t)
return e;
else if (eq_p (car (e), &scm_symbol_quasiquote) == &scm_t)
return cons (e, eval_quasiquote (cdr (e), a));
else if (eq_p (car (e), &scm_symbol_unquote) == &scm_t)
return eval (cadr (e), a);
else if (atom_p (car (e)) == &scm_t)
return cons (car (e), eval_quasiquote (cdr (e), a));
else if (eq_p (caar (e), &scm_symbol_unquote) == &scm_t)
return cons (eval (cadar (e), a), &scm_nil);
else if (eq_p (caar (e), &scm_symbol_quote) == &scm_t)
return cons (cadar (e), &scm_nil);
else if (eq_p (caar (e), &scm_symbol_quasiquote) == &scm_t)
return cdar (e);
return cons (car (e), eval_quasiquote (cdr (e), a));
else if (eq_p (caar (e), &scm_symbol_unquote_splicing) == &scm_t)
return append2 (eval_ (cadar (e), a), eval_quasiquote (cdr (e), a));
return cons (eval_quasiquote (car (e), a), eval_quasiquote (cdr (e), a));
}
#endif

40
scm.mes
View File

@ -21,6 +21,16 @@
;; The Maxwell Equations of Software -- John McCarthy page 13
;; http://www.softwarepreservation.org/projects/LISP/book/LISP%201.5%20Programmers%20Manual.pdf
(define (list . rest) rest)
(define-macro (begin . rest)
`((lambda () ,@rest)))
(define (vector . rest) (list->vector rest))
(define (apply f args)
(c:eval (cons f args) (current-module)))
(define (defined? x)
(assq x (current-module)))
@ -29,8 +39,6 @@
((pair? p) (eq? (car p) 'lambda))
(#t #f)))
(define (list . rest) rest)
(define (vector . rest) (list->vector rest))
(define assv assq)
(define (memq x lst)
(cond ((null? lst) #f)
@ -39,10 +47,10 @@
(define memv memq)
(define-macro (or x y)
(list 'cond (list x x) (list #t y)))
`(cond (,x ,x) (#t ,y)))
(define-macro (and x y)
(list 'cond (list x y) (list #t #f)))
`(cond (,x ,y) (#t #f)))
(define (split-params bindings params)
(cond ((null? bindings) params)
@ -80,19 +88,14 @@
(cond (x #f)
(#t #t)))
(define-macro (if expr then else)
(list 'cond
(list expr then)
(list #t else)))
(define-macro (if expr then . else)
`(cond
(,expr ,then)
(#t (cond (,(pair? else) ((lambda () ,@else)))))))
;;TODO
(define-macro (iif expr then . else)
(list 'cond
(list expr then)
(list #t
(list 'cond
(list (list 'pair? else) (list 'car else))
(list #t '*unspecified*)))))
(define-macro (when expr . body)
`(if ,expr
((lambda () ,@body))))
(define (unspecified-bindings bindings params)
(cond ((null? bindings) params)
@ -111,8 +114,3 @@
(append (letrec-setters bindings '())
body))) )
(define (begin . rest)
(let () rest))
(define (apply f args)
(c:eval (cons f args) (current-module)))

83
syntax.mes
View File

@ -1,18 +1,18 @@
(display "define-syntax...")
;; (display "define-syntax...")
(define-macro define-syntax
(lambda (form expander)
(expander `(define-macro ,(cadr form)
(let ((transformer ,(caddr form)))
(lambda (form expander)
(expander (transformer form
(lambda (x) x)
eq?)
expander))))
expander)))
;; (define-macro define-syntax
;; (lambda (form expander)
;; (expander `(define-macro ,(cadr form)
;; (let ((transformer ,(caddr form)))
;; (lambda (form expander)
;; (expander (transformer form
;; (lambda (x) x)
;; eq?)
;; expander))))
;; expander)))
(newline)
;; (newline)
(display "define-syntax when...")
@ -27,68 +27,29 @@
;; (begin ,exp . ,rest)))
(define-macro (when clause . rest)
(cond
((not (eq? clause #f)) (cons 'let (cons '() rest)))))
(define-macro (ifwhen clause . rest)
(if (not (eq? clause #f)) (cons 'let (cons '() rest))))
(define-macro my-when
(lambda (test . branch)
(list 'if test (cons 'begin branch))))
;; (define-macro (q-when test . branch)
;; `(if ,test
;; (begin ,@branch)))
;; (define-macro (when clause exp . rest)
;; (display "all=")
;; (display (cons exp rest))
;; (newline)
;; `(if ,clause
;; (begin ,(cons exp rest))))
;; (define-macro (when clause . rest)
;; (cond
;; ((not (eq? clause #f)) (cons 'let (cons '() rest)))))
;; (list 'cond (list clause (list 'let '() rest))))
(define-macro (when expr . body)
`(if ,expr
((lambda () ,@body))
'bah))
(newline)
(ifwhen #t
(when #t
(display "true")
(newline))
(ifwhen #f
(display "false")
(when #t
(display "q-when")
(newline)
'())
(my-when #t
(display "my-when")
(newline)
'())
;; (q-when #t
;; (display "q-when")
;; (newline)
;; '())
(define *gensym* 0)
(define (gensym)
(set! *gensym* (+ *gensym* 1))
(string->symbol (string-append "g" (number->string *gensym*))))
(define-macro bla (gensym))
(display bla) (newline)
(display bla) (newline)
(display bla) (newline)
(newline)
'()
;;EOF
EOF2

27
test.mes
View File

@ -137,7 +137,7 @@
(display (= 3 '3))
(newline)
(display (if #t 'true 'FIXME))
(display (if #t 'true))
(newline)
(display (if (eq? 0 '0) 'true 'false))
(newline)
@ -280,4 +280,29 @@
(display (gensym))
(newline)
(display "unquote:")
(display `,(list 1 2 3 4))
(newline)
(display `('boo ,@'(bah baz) 1 2))
(newline)
(display "splice:")
(display `(1 ,@(list 2 3) 4))
(newline)
(define s-r '(2 3))
(display "splice:")
(display `(1 ,@s-r 4))
(newline)
(display "when:")
(when #t
(display "true")
(newline))
(when #f
(display "must not see")
(newline))
'()