From: Toshihiro Matsui
Subject: A read-macro for C to Lisp formula translation
Date:
Message-ID: <19080@etlcom.etl.JUNET>
Some Lisp programers who have experienced FORTRAN or C programming
often complain that Lisp is weak at mathematical formula expression.
Here is a read macro program which accepts C-like infix formulae
and translates them into prefixed lisp forms.
I used '%' for the macro character.
%(1 + 2 * 3 / 4.0) is expanded to something like
(+ 1 (/ (* 2 3) 4.0) and 2.5 is resulted.
Fuction call and array reference are also handled.
%(sin(x) + a[1]) --> (+ (sin x) (aref a 1))
Also, a simple optimization to reduce function call and array
reference is performed.
%((sin(x) + cos(x)) / (sin(x) - cos(x)))
--> (let* ((t1 (sin x)) (t2 (cos x))) (/ (+ t1 t2) (- t1 t2)))
For this optimization, all the expressions are assumed to have
no side-effect.
Assignment and relative operator are also available.
%(a != b) --> (/= a b)
%(a = x + 1) --> (setf a (+ x 1))
%(a[0] = (x + y + z) ) --> (setf (aref a 0) (+ x y z))
Note that every factor or operator needs to be delimited by spaces,
since terms like '2*a' and 'a+pi' are valid symbols for Lisp although they
are recognized three different symbols by C.
This program was developed on euslisp, which is a subset of CommonLisp
and has lots of extended features for three-dimensional solid modeling,
especially for robot programming. However, I have confirmed this program
correctly works in KCL environments both on our sun3 and sun4.
Not very short, about 120 lines.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; mathtran.l
;;;; convert C-like arithmethic expressions into lisp notation.
;;;; 1987-Sep
;;;; Copyright (c) 1987,
;;;; Toshihiro MATSUI, Electrotechnical Laboratory
;;;; Tsukuba-city, Ibaraki, 305 JAPAN
;;;; ·············@relay.cs.net
(defmacro while (cond &rest body)
`(do ()
((not ,cond))
. ,body))
(defun memq (x l) (member x l :test #'eq))
(defun expression (exp &optional (lhs nil) &aux result letvar-alist)
(labels
(
(letvar (form)
(let ((v (assoc form letvar-alist :test #'equal)))
(cond (v (incf (third v)) (second v))
(t (setf v (gensym))
(push (list form v 1) letvar-alist)
v))))
(factor1 (exp)
(let* ((sy (pop exp)) (arglist) form)
(cond
((consp sy)
(multiple-value-setq (sy form) (expr sy))
(if form (error "illegal math expression for % macro"))
(values sy exp))
((consp (first exp)) ;function call or array ref.
(setf arglist (pop exp))
(cond ((eq (first arglist) 'aref)
(setf arglist (expr-list (rest arglist)))
(setf form (cons 'aref (cons sy arglist)))
(unless lhs (setf form (letvar form)))
(values form exp))
(t
(values (letvar (cons sy (expr-list arglist))) exp) )) )
(t (values sy exp)))))
(factor (exp)
(let* ((left) (right) (form))
(multiple-value-setq (left exp) (factor1 exp))
(cond
((memq (first exp) '(** ^ ))
(multiple-value-setq (right exp) (factor1 (rest exp)))
(cond
((and (integerp right) (< right 10))
(setf form (list '*))
(cond ((atom left)
(dotimes (i right) (nconc form (list left)))
(values (letvar form) exp))
(t
(dotimes (i right) (nconc form (list 'temp)))
(values `(let ((temp ,left)) ,form) exp))))
(t (values (list 'expt left right) exp))))
((numberp left) (values left exp))
(t (values left exp) ))) )
(term (exp)
(let* ((left) (op) (right))
(multiple-value-setq (left exp) (factor exp))
(setf op (first exp))
(cond
((memq op '(* /))
(while (memq op '(* /))
(setf left (list op left))
(while (eq (first exp) op)
(multiple-value-setq (right exp) (factor (rest exp)))
(nconc left (list right)) )
(setf op (first exp)))
(values left exp))
(t (values left exp)))))
(expr (exp)
(let* ((op (first exp)) (left) (right))
(if (memq op '(+ -)) ;+- as unary operator
(setf exp (rest exp)))
(multiple-value-setq (left exp) (term exp))
(if (eq op '-)
(setf left (list op left)))
(when (memq (first exp) '(+ -))
(setf left (list '+ left))
(while (memq (setf op (first exp)) '(+ -))
(multiple-value-setq (right exp) (term (rest exp)))
(if (eq op '-) (setf right (list '- right)))
(nconc left (list right))))
(values left exp)))
(expr-list (exp)
(let (temp result)
(while exp
(multiple-value-setq (temp exp) (expr exp))
(push temp result))
(nreverse result)))
(rel-expr (exp)
(let ((left) (op) (right))
(multiple-value-setq (left exp) (expr exp))
(setf op (pop exp))
(when (memq op '(== != /= < > <= >=))
(multiple-value-setq (right exp) (expr exp))
(setf left
(list (second (assoc op '((== =) (!= /=) (/= /=) (< <)
(<= <=) (> >) (>= >=))))
left right)))
(values left exp)))
(reconstruct-form (exp)
(setf exp (list exp))
(let ((letpairs))
(dolist (lv letvar-alist)
(if (> (third lv) 1) ;referenced more than once
(push (list (second lv) (first lv)) letpairs)
(nsubst (first lv) (second lv) exp)))
(if letpairs
`(let* ,letpairs . ,exp)
(first exp)))))
(multiple-value-setq (result exp) (rel-expr exp))
(if exp (error "illegal expression in % macro"))
(reconstruct-form result) ))
(defun infix2prefix (file &optional char)
(let ((exp (read file)))
(cond
((symbolp exp) ;probably a left-hand-side array ref.
(expression (list exp (read file)) t))
((eq (second exp) '=)
(list 'setq (car exp) (expression (cddr exp) nil)))
((eq (third exp) '=)
(list 'setf (expression (list (first exp) (second exp)) t)
(expression (cdddr exp) nil)))
(t (expression exp nil)))) ) )
(defun read-aref (file &optional char)
(cons 'aref (read-delimited-list #\] file)))
(set-macro-character #\% 'infix2prefix)
(set-macro-character #\[ 'read-aref)
(set-syntax-from-char #\] #\))
--
----- Toshihiro MATSUI, Electrotechnical Laboratory ······@7,21,28,50,144MHz
······@etl.junet (domestic), ·············@relay.cs.net (overseas)
From: Mike Deem
Subject: XLisp (or any others) for OS/2
Date:
Message-ID: <576@interlan.UUCP>
I hear XLisp has been ported to OS/2. Could someone tell me where I can
get a copy? Please mail me at ····@interlan.UUCP or sun!interlan!deem.
Thanks,
Mike Deem
PS. Im new to this news group so if this is a repeat, please forgive.