From: John Thingstad
Subject: prefix parser
Date: 
Message-ID: <opr5mnfmsmxfnb1n@news.chello.no>
I am trying to refactor my algebra package.

How would you concert somthing like:

(defun pls-op (line)
   (let* ((result (min-op line))
          (token (peek-token line)))
     (cond
      ((= (op token) #.+pls+)
       (next-token line)
       `(,(sym->op (op token)) ,result ,(pls-op line)))
      (t result))))

into a macro with interface:

(aritmetric-macro pls-op :follow min-op :sym +pls+)


(here is the complete code)

;;;; ------------------------------------------------------------
;;;;
;;;; Algebra.lisp - parse infix math
;;;;
;;;; Author: John Thingstad
;;;; Created: 26/3-2004
;;;;
;;;; ------------------------------------------------------------

(defpackage algebra
   (:use common-lisp)
   (:export prefix))

(in-package algebra)

(defconstant +val+ 0)
(defconstant +lpar+ 1)
(defconstant +rpar+ 2)
(defconstant +mul+ 3)
(defconstant +div+ 4)
(defconstant +pls+ 5)
(defconstant +min+ 6)
(defconstant +eol+ 7)

(defconstant +ascii-0+ 48)

(defclass line ()
   ((string :reader str :initarg :str)
    (index :accessor ind :initform 0)))

(defclass token ()
   ((operator :reader op :initarg :op)
    (value :reader val :initarg :val :initform nil)))

(define-condition token-error (error)
   ((ch :reader ch :initarg :ch))
   (:report (lambda (condition stream)
	     (format stream "'~C' is not a valid character" (ch condition)))))

(define-condition parse-error (error)
   ((message :reader message :initarg :message))
   (:report (lambda (condition stream)
	    (format stream "~A" (message condition)))))

(declaim (inline char->digit))
(defun char->digit (char)
   (- (char-code char) #.+ascii-0+))

(declaim (inline white-space-p))
(defun white-space-p (char)
   (or (char= char #\space) (char= char #\tab) (char= char #\return)))

(defun line->number (line)
   (let* ((string (str line)) (ind (ind line)) (len (length string)) 
(number 0))
     (loop while (and (< ind len) (digit-char-p (schar string ind))) do
	  (setf number (+ (* 10 number) (char->digit (schar string ind))))
	  (incf ind))
     (setf (ind line) ind)
     number))

(defun next-token (line)
   (when (>= (ind line) (length (str line)))
     (return-from next-token (make-instance 'token :op +eol+ :val nil)))
   (loop while (white-space-p (aref (str line) (ind line))) do
	(incf (ind line)))
   (let* ((ch (aref (str line) (ind line))) (val nil)
	 (op (case ch
	       (#\( #.+lpar+)
	       (#\) #.+rpar+)
	       (#\* #.+mul+)
	       (#\/ #.+div+)
	       (#\+ #.+pls+)
	       (#\- #.+min+)
	       (otherwise
		(cond
		 ((digit-char-p ch) (setf val (line->number line)) #.+val+)
		 (t (error 'token-error :ch ch)))))))
     (when (/= op +val+) (incf (ind line)))
     (make-instance 'token :op op :val val)))

(defun peek-token (line)
   (let* ((old-ind (ind line)) (token (next-token line)))
     (setf (ind line) old-ind)
     token))

(defun sym->op (op)
   (case op
     (#.+mul+ '*)
     (#.+div+ '/)
     (#.+min+ '-)
     (#.+pls+ '+)
     (otherwise
      (error "Internal error."))))

;;; Grammar
;;;
;;; par --> +val+ | +lpar+ mpe +rpar+
;;; div --> par (+div+ div)?
;;; mul --> div (+mul+ mul)?
;;; min --> mul (+min+ min)?
;;; pls --> pls (+pls+ mpe)?
;;; start --> mpe +eol+

(defun par-op (line)
   (let ((token (next-token line)))
     (cond
      ((= (op token) #.+val+) (val token))
      ((= (op token) #.+lpar+)
       (let ((result (pls-op line)))
	(cond
	 ((= (op (next-token line)) #.+rpar+) result)
	 (t (error 'parse-error :message "Expected ')'")))))
      (t (error 'parse-error :message "Expected number or '('")))))

(defun div-op (line)
   (let* ((result (par-op line))
	 (token (peek-token line)))
     (cond
      ((= (op token) #.+div+)
       (next-token line)
       `(,(sym->op (op token)) ,result ,(div-op line)))
      (t result))))

(defun mul-op (line)
   (let* ((result (div-op line))
	 (token (peek-token line)))
     (cond
      ((= (op token) #.+mul+)
       (next-token line)
       `(,(sym->op (op token)) ,result ,(mul-op line)))
      (t result))))

(defun min-op (line)
   (let* ((result (mul-op line))
	 (token (peek-token line)))
     (cond
      ((= (op token) #.+min+)
       (next-token line)
       `(,(sym->op (op token)) ,result ,(min-op line)))
      (t result))))

(defun pls-op (line)
   (let* ((result (min-op line))
          (token (peek-token line)))
     (cond
      ((= (op token) #.+pls+)
       (next-token line)
       `(,(sym->op (op token)) ,result ,(pls-op line)))
      (t result))))

(defun start (string)
   (check-type string string)
   (let* ((line (make-instance 'line :str string))
	 (result (pls-op line)))
     (when (/= (op (next-token line)) #.+eol+)
       (error 'parse-error :message "Garbage after line end."))
     result))

(defun prefix (string)
   (multiple-value-bind (result error)
       (ignore-errors (start string))
     (if result
	result
       (error error))))

-- 
Using M2, Opera's revolutionary e-mail client: http://www.opera.com/m2/

From: Pascal Bourguignon
Subject: Re: prefix parser
Date: 
Message-ID: <87brmfzpeb.fsf@thalassa.informatimago.com>
John Thingstad <··············@chello.no> writes:

> How would you concert somthing like:
> (defun pls-op (line)
> ...
> into a macro with interface:

> I am trying to refactor my algebra package.

> (defconstant +val+ 0)
> (defconstant +lpar+ 1)
> (defconstant +rpar+ 2)
> (defconstant +mul+ 3)
> (defconstant +div+ 4)
> (defconstant +pls+ 5)
> (defconstant +min+ 6)
> (defconstant +eol+ 7)

I fail to see a valid reason why defining such a bunch of constants.
Are you programming in C perhaps?

There's a legend saying that LISP means LISt Processing, but
obviously, this is only that, a legend. 
LISP is actually List, Integer and Symbol Processing.

SYMBOLS!


> (defclass line ()
>    ((string :reader str :initarg :str)
>     (index :accessor ind :initform 0)))

That would be a major impediment to use it within a macro.


There are valid reasons why one would want to parse string sources in
Lisp.  But if your purpose is to send the data to a macro, you'd
better let the lisp reader do the lexing job for you!
 

 
> (defun div-op (line)
>    (let* ((result (par-op line))
> 	 (token (peek-token line)))
>      (cond
>       ((= (op token) #.+div+)
>        (next-token line)
>        `(,(sym->op (op token)) ,result ,(div-op line)))
>       (t result))))
> 
> (defun mul-op (line)
>    (let* ((result (div-op line))
> 	 (token (peek-token line)))
>      (cond
>       ((= (op token) #.+mul+)
>        (next-token line)
>        `(,(sym->op (op token)) ,result ,(mul-op line)))
>       (t result))))

Doesn't it feel like "deja-vue"?  That's because they're hacking the matrix!



;;; Just to fix the ideas 
;;; (but see at the end, where the exact grammar is defined).
;;;
;;; expr : term { [+|-] expr } .
;;; term : fact { [*|/] term } .
;;; fact : neg { ^ fact } .
;;; neg  : simp | - simp .
;;; simp : ident | number | ( expr ) .


(defun parse-simp (simp)
  "
DO:         Parses a simple expression:
            simp ::= number | symbol | ( expr ) .
RETURN:     A parse tree or :ERROR ; a cdr of simp.
"
  (cond
   ((numberp (car simp)) (values (car simp) (cdr simp)))
   ((symbolp (car simp)) (values (car simp) (cdr simp)))
   ((listp (car simp))
    (multiple-value-bind (expr rest) (parse-expr (car simp))
      (when rest (error "INVALID TOKENS IN SUB-EXPRESSION ~S." rest))
      (values expr (cdr simp))))
   (t (error "INVALID TOKEN IN EXPRESSION ~S." (car simp))))
  );;parse-simp


(defun parse-neg (neg)
  "
DO:         Parses a simple logical expression:
            neg ::= simp | - simp .
RETURN:     A parse tree or :ERROR ; a cdr of expr.
"
  (cond
   ((eq (car neg) '|-|)
    (multiple-value-bind (expr rest) (parse-simp (cdr neg))
      (if (eq :error expr)
        (values expr rest)
        (values (list '|-| expr) rest))))
   (t (parse-simp neg))));;parse-neg


(defmacro make-parse-level (name operators next)
  "
DO:         Generate a function named PARSE-{name} that parses the
            following rule:  name ::= next { operators next } .
            That functions will return a parse tree or :ERROR ; a cdr of expr.
"
  (let ((parse-level-name (intern (format nil "PARSE-~A" name)))
        (parse-next-name  (intern (format nil "PARSE-~A" next))))
    `(defun ,parse-level-name (expr)
       (let ((result))
         (multiple-value-bind (term rest) (,parse-next-name expr)
           (setq result term expr rest))
         (do () ((or (eq :error result)
                     (null expr)
                     (not (member (car expr) ',operators
                                  :test (function eq)))))
           (multiple-value-bind (term rest) (,parse-next-name (cdr expr))
             (if (eq :error term)
               (setq result :error)
               (setq result (list (car expr) result term)
                     expr   rest))))
         (values result expr))))
  );;make-parse-level


(make-parse-level fact (^)       neg)
(make-parse-level term (* / mod) fact)
(make-parse-level expr (+ -)     term)
(make-parse-level comp (< <= > >= = /=) expr)

(parse-comp '(  a + 2 * ( - x ^ -(3 * pi / 2) - c + d / e ) < 0 ))
--> (< (+ A (* 2 (+ (- (^ (- X) (- (/ (* 3 PI) 2))) C) (/ D E)))) 0) ;
    NIL


Oh Oh... I'd like another unary operator...


(defmacro make-parse-unary (name operators next)
  "
DO:         Generate a function named PARSE-{name} that parses the
            following rule:  name ::= next | operators next .
            That functions will return a parse tree or :ERROR ; a cdr of expr.
"
  (let ((parse-level-name (intern (format nil "PARSE-~A" name)))
        (parse-next-name  (intern (format nil "PARSE-~A" next))))
    `(defun ,parse-level-name (expr)
       (let ((result))
         (if (member (car expr) ',operators :test (function eq))
           (multiple-value-bind (next rest) (,parse-next-name (cdr expr))
             (if (eq :error next)
               (values next rest)
               (values (list (car expr) next) rest)))
           (,parse-next-name  expr))))));;make-parse-unary

(make-parse-unary unary (sin cos atan -) simp)
(make-parse-level fact  (^)              unary)
;; I should rename make-parse-level to make-parse-binary...


(parse-comp '( sin x ^ 2 + cos x ^ 2 = 1))
--> (= (+ (^ (SIN X) 2) (^ (COS X) 2)) 1) ;
    NIL


What is lacking, is simplification of expressions:

(parse-comp '( a + b + c + d ))
--> (+ (+ (+ A B) C) D) ;
    NIL

But the lisp compiler can do that, if you're doing a macro...


-- 
__Pascal_Bourguignon__                     http://www.informatimago.com/
There is no worse tyranny than to force a man to pay for what he doesn't
want merely because you think it would be good for him.--Robert Heinlein
http://www.theadvocates.org/
From: John Thingstad
Subject: Re: prefix parser
Date: 
Message-ID: <opr5mt51smxfnb1n@news.chello.no>
Yes. I think I see the light!
I'll take it from here.
(have a python proc flatten which converted should do the trick)

thanks

On 29 Mar 2004 16:41:48 +0200, Pascal Bourguignon 
<····@thalassa.informatimago.com> wrote:

> But the lisp compiler can do that, if you're doing a macro...
>
>



-- 
Using M2, Opera's revolutionary e-mail client: http://www.opera.com/m2/