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.