prefix parser
John Thingstad
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/
Pascal Bourguignon
> 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/
John Thingstad
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
<sp...@thalassa.informatimago.com> wrote:
> But the lisp compiler can do that, if you're doing a macro...
>
>
--