Name: Anonymous 2013-07-13 18:27
Just found a snippet from early Symta. It was implemented as a reader macro back then and mixed concatenative with prefix
#d(
fac {n (eql 0)} + 1
fac {n integer} [n 1 - fac n *]
some-variable (fac 10)
)
And some even earlier code I used to experiment with postfix macros.
(defun get-description (obj)
(with-output-to-string (s)
(describe-object obj s)
s))
(defun extract-regex (regex string)
(car (all-matches-as-strings regex string)))
(defun get-function-lambda-list (fun)
(read-from-string
(extract-regex
"\\(.*"
(extract-regex
"The function's arguments are: .*"
(substitute #\Space #\Newline (get-description fun))))))
(defun get-required-args-number (fun)
(let ((ll (get-function-lambda-list fun)))
(loop with num-args = 0
as i in ll
when (and (symbolp i) (eql (aref (symbol-name i) 0) #\&)) do (return num-args)
finally (return num-args)
do (incf num-args))))
(defun get-symbol-nargs (sym)
(case sym
((+ - * / = eq eql setf equal string= and or logand logior logxor apply aref)
2)
((if) 3)
(otherwise
(if (fboundp sym)
(get-required-args-number (symbol-function sym))
0))))
(defun enclosed-in? (delim string)
(let* ((n (symbol-name string))
(l (length n)))
(and (> l 2)
(char= (aref n 0 ) delim)
(char= (aref n (- l 1)) delim))))
(defmacro lexically-bound-p (variable &environment env)
(eq :lexical (sb-cltl2:variable-information variable env)))
(defmacro symbol-macro-bound-p (variable &environment env)
(eq :symbol-macro (sb-cltl2:variable-information variable env)))
(defun get-env-vars (env)
(mapcar #'car (sb-c::lexenv-vars env)))
(defun env-boundp (sym env)
(find sym (get-env-vars env)))
;;(eql (type-of (sb-kernel:make-null-lexenv)) env)
;;(defmacro lexixally-bound-p (sym &environment env)
;; `(identity ',(find sym (mapcar #'car (sb-c::lexenv-vars env)))))
(defmacro lazy-sexp (sexp)
`(let ((evaled nil) value)
(lambda ()
(unless evaled
(setf value ,sexp))
value)))
(defun standard-constant (word)
(case word
((t nil pi) t)))
(defun process-word (word env extern-env)
(destructuring-bind (stack closures) env
(cond
((or (standard-constant word)
(not (symbolp word))
(enclosed-in? #\* word)
(enclosed-in? #\+ word))
(let ((sym (gensym)))
(push `(,sym (lazy-sexp ,word)) closures)
(push sym stack)))
(t
(case word
(dup (push (car stack) stack))
(rot (let* ((a (pop stack)) (b (pop stack)))
(push a stack)
(push b stack)))
(rot3 (let* ((a (pop stack)) (b (pop stack)) (c (pop stack)))
(push b stack)
(push a stack)
(push c stack)))
(t (let ((sym (gensym)) (args nil) (nargs))
(case (aref (string word) 0)
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(setf nargs (read-from-string (subseq (string word) 0 1)))
(setf word (intern (subseq (string word) 1))))
(t (setf nargs (get-symbol-nargs word))))
(loop repeat nargs
do (push (pop stack) args))
(setf args (mapcar (lambda (x) (list 'funcall x)) args))
(push `(,sym ,(if (or (env-boundp word extern-env) #|(symbol-macro-bound-p ,word)|#)
`(lazy-sexp ,word)
`(lazy-sexp (,word ,@args))))
closures)
(push sym stack))))))
(list stack closures)))
(defun conc-rec (words extern-env)
(if words
(process-word (car words) (conc-rec (cdr words) extern-env) extern-env)
'(nil nil)))
(defmacro conc (words &environment extern-env)
(destructuring-bind (stack closures) (conc-rec (reverse words) extern-env)
`(let ()
(let* ,(reverse closures)
(funcall ,(car stack))))))
(set-macro-character #[
(lambda (stream char)
(declare (ignore char))
(let* ((lst (read-delimited-list #\] stream t)))
`(conc ,lst))))
(set-macro-character #\]
(get-macro-character #\)))
;;(defmacro test (&environment env)
;; (get-env-vars env))
;;(let ((a 1) (b 2)) (conc (a b +)))
(print (let ((a 1) (b 2)) [a b +]))
(conc (a b +))
(defun id (v) v)
(defun add (a b)
(+ a b))
(conc (3 *x* +))
(conc (3 2 + 5 *))
(conc (123 print))
(conc (3 dup +))
(conc (#'+ (loop as i from 0 to 100 collect i) apply dup * 3 + 2 * 3 / sqrt))
#d(
fac {n (eql 0)} + 1
fac {n integer} [n 1 - fac n *]
some-variable (fac 10)
)
And some even earlier code I used to experiment with postfix macros.
(defun get-description (obj)
(with-output-to-string (s)
(describe-object obj s)
s))
(defun extract-regex (regex string)
(car (all-matches-as-strings regex string)))
(defun get-function-lambda-list (fun)
(read-from-string
(extract-regex
"\\(.*"
(extract-regex
"The function's arguments are: .*"
(substitute #\Space #\Newline (get-description fun))))))
(defun get-required-args-number (fun)
(let ((ll (get-function-lambda-list fun)))
(loop with num-args = 0
as i in ll
when (and (symbolp i) (eql (aref (symbol-name i) 0) #\&)) do (return num-args)
finally (return num-args)
do (incf num-args))))
(defun get-symbol-nargs (sym)
(case sym
((+ - * / = eq eql setf equal string= and or logand logior logxor apply aref)
2)
((if) 3)
(otherwise
(if (fboundp sym)
(get-required-args-number (symbol-function sym))
0))))
(defun enclosed-in? (delim string)
(let* ((n (symbol-name string))
(l (length n)))
(and (> l 2)
(char= (aref n 0 ) delim)
(char= (aref n (- l 1)) delim))))
(defmacro lexically-bound-p (variable &environment env)
(eq :lexical (sb-cltl2:variable-information variable env)))
(defmacro symbol-macro-bound-p (variable &environment env)
(eq :symbol-macro (sb-cltl2:variable-information variable env)))
(defun get-env-vars (env)
(mapcar #'car (sb-c::lexenv-vars env)))
(defun env-boundp (sym env)
(find sym (get-env-vars env)))
;;(eql (type-of (sb-kernel:make-null-lexenv)) env)
;;(defmacro lexixally-bound-p (sym &environment env)
;; `(identity ',(find sym (mapcar #'car (sb-c::lexenv-vars env)))))
(defmacro lazy-sexp (sexp)
`(let ((evaled nil) value)
(lambda ()
(unless evaled
(setf value ,sexp))
value)))
(defun standard-constant (word)
(case word
((t nil pi) t)))
(defun process-word (word env extern-env)
(destructuring-bind (stack closures) env
(cond
((or (standard-constant word)
(not (symbolp word))
(enclosed-in? #\* word)
(enclosed-in? #\+ word))
(let ((sym (gensym)))
(push `(,sym (lazy-sexp ,word)) closures)
(push sym stack)))
(t
(case word
(dup (push (car stack) stack))
(rot (let* ((a (pop stack)) (b (pop stack)))
(push a stack)
(push b stack)))
(rot3 (let* ((a (pop stack)) (b (pop stack)) (c (pop stack)))
(push b stack)
(push a stack)
(push c stack)))
(t (let ((sym (gensym)) (args nil) (nargs))
(case (aref (string word) 0)
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(setf nargs (read-from-string (subseq (string word) 0 1)))
(setf word (intern (subseq (string word) 1))))
(t (setf nargs (get-symbol-nargs word))))
(loop repeat nargs
do (push (pop stack) args))
(setf args (mapcar (lambda (x) (list 'funcall x)) args))
(push `(,sym ,(if (or (env-boundp word extern-env) #|(symbol-macro-bound-p ,word)|#)
`(lazy-sexp ,word)
`(lazy-sexp (,word ,@args))))
closures)
(push sym stack))))))
(list stack closures)))
(defun conc-rec (words extern-env)
(if words
(process-word (car words) (conc-rec (cdr words) extern-env) extern-env)
'(nil nil)))
(defmacro conc (words &environment extern-env)
(destructuring-bind (stack closures) (conc-rec (reverse words) extern-env)
`(let ()
(let* ,(reverse closures)
(funcall ,(car stack))))))
(set-macro-character #[
(lambda (stream char)
(declare (ignore char))
(let* ((lst (read-delimited-list #\] stream t)))
`(conc ,lst))))
(set-macro-character #\]
(get-macro-character #\)))
;;(defmacro test (&environment env)
;; (get-env-vars env))
;;(let ((a 1) (b 2)) (conc (a b +)))
(print (let ((a 1) (b 2)) [a b +]))
(conc (a b +))
(defun id (v) v)
(defun add (a b)
(+ a b))
(conc (3 *x* +))
(conc (3 2 + 5 *))
(conc (123 print))
(conc (3 dup +))
(conc (#'+ (loop as i from 0 to 100 collect i) apply dup * 3 + 2 * 3 / sqrt))