;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*- ;;; **************************************************************** ;;; CHANGE LOG: ;; * (2016/06/11 Set *print-infix-copyright* to nil by default. ;;; * (1997/12/6) Fixed code for valid-numberp, so that "" is no longer ;;; recognized as valid number ;;; * (1997/11/29) Modified by M. Rychlik(rychlik@math.arizona.edu): ;;; The role of operators ^^ (exponentiation) and ^ (logxior) ;;; of the original version was reversed ;;; **************************************************************** ;;; ;;; Wed Jan 18 13:13:59 1995 by Mark Kantrowitz ;;; infix.cl -- 40545 bytes ;;; ************************************************************************** ;;; Infix ******************************************************************** ;;; ************************************************************************** ;;; ;;; This is an implementation of an infix reader macro. It should run in any ;;; valid Common Lisp and has been tested in Allegro CL 4.1, Lucid CL 4.0.1, ;;; MCL 2.0 and CMU CL. It allows the user to type arithmetic expressions in ;;; the traditional way (e.g., 1+2) when writing Lisp programs instead of ;;; using the normal Lisp syntax (e.g., (+ 1 2)). It is not intended to be a ;;; full replacement for the normal Lisp syntax. If you want a more complete ;;; alternate syntax for Lisp, get a copy Apple's MLisp or Pratt's CGOL. ;;; ;;; Although similar in concept to the Symbolics infix reader (#), ;;; no real effort has been made to ensure compatibility beyond coverage ;;; of at least the same set of basic arithmetic operators. There are several ;;; differences in the syntax beyond just the choice of #I as the macro ;;; character. (Our syntax is a little bit more C-like than the Symbolics ;;; macro in addition to some more subtle differences.) ;;; ;;; We initially chose $ as a macro character because of its association ;;; with mathematics in LaTeX, but unfortunately that character is already ;;; used in MCL. We switched to #I() because it was one of the few options ;;; remaining. ;;; ;;; Written by Mark Kantrowitz, School of Computer Science, ;;; Carnegie Mellon University, March 1993. ;;; ;;; Copyright (c) 1993 by Mark Kantrowitz. All rights reserved. ;;; ;;; Use and copying of this software and preparation of derivative works ;;; based upon this software are permitted, so long as the following ;;; conditions are met: ;;; o no fees or compensation are charged for use, copies, ;;; distribution or access to this software ;;; o this copyright notice is included intact. ;;; This software is made available AS IS, and no warranty is made about ;;; the software or its performance. ;;; ;;; In no event will the author(s) or their institutions be liable to you for ;;; damages, including lost profits, lost monies, or other special, incidental ;;; or consequential damages, arising out of or in connection with the use or ;;; inability to use (including but not limited to loss of data or data being ;;; rendered inaccurate or losses sustained by third parties or a failure of ;;; the program to operate as documented) the program, or for any claim by ;;; any other party, whether in an action of contract, negligence, or ;;; other tortious action. ;;; ;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. ;;; ;;; The current version of this software and a variety of related utilities ;;; may be obtained from the Lisp Repository by anonymous ftp ;;; from ftp.cs.cmu.edu [128.2.206.173] in the directory ;;; user/ai/lang/lisp/code/syntax/infix/ ;;; If your site runs the Andrew File System, you can cd to the AFS directory ;;; /afs/cs.cmu.edu/project/ai-repository/ai/lang/lisp/code/syntax/infix/ ;;; ;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, ;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email ;;; address, and affiliation. This mailing list is primarily for ;;; notification about major updates, bug fixes, and additions to the Lisp ;;; Utilities Repository. The mailing list is intended to have low traffic. ;;; ;;; ******************************** ;;; Documentation ****************** ;;; ******************************** ;;; ;;; Syntax: ;;; ;;; Begin the reader macro with #I( and end it with ). For example, ;;; #I( x^2 + y^2 ) ;;; is equivalent to the Lisp form ;;; (+ (expt x 2) (expt y 2)) ;;; but much easier to read according to some folks. ;;; ;;; If you want to see the expansion, type a quote before the #I form ;;; at the Lisp prompt: ;;; > '#I(if x x-y ;;; ! lisp escape !(foo bar) --> (foo bar) ;;; ; comment ;;; x = y assignment (setf x y) ;;; x += y increment (incf x y) ;;; x -= y decrement (decf x y) ;;; x *= y multiply and store (setf x (* x y)) ;;; x /= y divide and store (setf x (/ x y)) ;;; x|y bitwise logical inclusive or (logior x y) ;;; x^^y bitwise logical exclusive or (logxor x y) ;;; x&y bitwise logical and (logand x y) ;;; x<>y right shift (ash x (- y)) ;;; ~x ones complement (unary) (lognot x) ;;; x and y conjunction (and x y) ;;; x && y conjunction (and x y) ;;; x or y disjunction (or x y) ;;; x || y disjunction (or x y) ;;; not x negation (not x) ;;; x^y exponentiation (expt x y) ;;; x,y sequence (progn x y) ;;; (x,y) sequence (progn x y) ;;; also parenthesis (x+y)/z --> (/ (+ x y) z) ;;; f(x,y) functions (f x y) ;;; a[i,j] array reference (aref a i j) ;;; x+y x*y arithmetic (+ x y) (* x y) ;;; x-y x/y arithmetic (- x y) (/ x y) ;;; -y value negation (- y) ;;; x % y remainder (mod x y) ;;; xy inequalities (< x y) (> x y) ;;; x <= y x >= y inequalities (<= x y) (>= x y) ;;; x == y equality (= x y) ;;; x != y equality (not (= x y)) ;;; if p then q conditional (when p q) ;;; if p then q else r conditional (if p q r) ;;; ;;; Precedence: ;;; ;;; The following precedence conventions are obeyed by the infix operators: ;;; [ ( ! ;;; ^ ;;; ~ ;;; * / % ;;; + - ;;; << >> ;;; < == > <= != >= ;;; & ;;; ^^ ;;; | ;;; not ;;; and ;;; or ;;; = += -= *= /= ;;; , ;;; if ;;; then else ;;; ] ) ;;; ;;; Note that logical negation has lower precedence than numeric comparison ;;; so that "not aprefix, support ;;; for #I"..." in addition to #i(...) which lets one ;;; type #i"a|b" which doesn't confuse editors that aren't ;;; |-aware. Also added := as a synonym for =, so that ;;; '#i"car(a) := b" yields (SETF (CAR A) B). ;;; ;;; 1.3: ;;; 28-JUN-96 mk Modified infix reader to allow whitespace between the #I ;;; and the start of the expression. ;;; ******************************** ;;; Implementation Notes *********** ;;; ******************************** ;;; ;;; Initially we tried implementing everything within the Lisp reader, ;;; but found this to not be workable. Parameters had to be passed in ;;; global variables, and some of the processing turned out to be ;;; indelible, so it wasn't possible to use any kind of lookahead. ;;; Center-embedded constructions were also a problem, due to the lack ;;; of an explicit stack. ;;; ;;; So we took another tack, that used below. The #I macro binds the ;;; *readtable* to a special readtable, which is used solely for tokenization ;;; of the input. Then the problem is how to correctly parenthesize the input. ;;; We do that with what is essentially a recursive-descent parser. An ;;; expression is either a prefix operator followed by an expression, or an ;;; expression followed by an infix operator followed by an expression. When ;;; the latter expression is complex, the problem becomes a little tricky. ;;; For example, suppose we have ;;; exp1 op1 exp2 op2 ;;; We need to know whether to parenthesize it as ;;; (exp1 op1 exp2) op2 ;;; or as ;;; exp1 op1 (exp2 op2 ...) ;;; The second case occurs either when op2 has precedence over op1 (e.g., ;;; * has precedence over +) or op2 and op1 are the same right-associative ;;; operator (e.g., exponentiation). Thus the algorithm is as follows: ;;; When we see op1, we want to gobble up exp2 op2 exp3 op3 ... opn expn+1 ;;; into an expression where op2 through opn all have higher precedence ;;; than op1 (or are the same right-associative operator), and opn+1 doesn't. ;;; This algorithm is implemented by the GATHER-SUPERIORS function. ;;; ;;; Because + and - are implemented in the infix readtable as terminating ;;; macro cahracters, the exponentiation version of Lisp number syntax ;;; 1e-3 == 0.001 ;;; doesn't work correctly -- it parses it as (- 1e 3). So we add a little ;;; cleverness to GATHER-SUPERIORS to detect when the tokenizer goofed. ;;; Since this requires the ability to lookahead two tokens, we use a ;;; stack to implement the lookahead in PEEK-TOKEN and READ-TOKEN. ;;; ;;; Finally, the expression returned by GATHER-SUPERIORS sometimes needs to ;;; be cleaned up a bit. For example, parsing aprefix operator-lessp)) (in-package "INFIX") (pushnew :infix *features*) (proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *version* "1.3 28-JUN-96") (defparameter *print-infix-copyright* nil "If non-NIL, prints a copyright notice upon loading this file.") (defun infix-copyright (&optional (stream *standard-output*)) "Prints an INFIX copyright notice and header upon startup." (format stream "~%;;; ~V,,,'*A" 73 "*") (format stream "~%;;; Infix notation for Common Lisp.") (format stream "~%;;; Version ~A." *version*) (format stream "~%;;; Written by Mark Kantrowitz, ~ CMU School of Computer Science.") (format stream "~%;;; Copyright (c) 1993-95. All rights reserved.") (format stream "~%;;; May be freely redistributed, provided this ~ notice is left intact.") (format stream "~%;;; This software is made available AS IS, without ~ any warranty.") (format stream "~%;;; ~V,,,'*A~%" 73 "*") (force-output stream)) ;; What this means is you can either turn off the copyright notice ;; by setting the parameter, or you can turn it off by including ;; (setf (get :infix :dont-print-copyright) t) in your lisp init file. (when (and *print-infix-copyright* (not (get :infix :dont-print-copyright))) (infix-copyright))) ;;; ******************************** ;;; Readtable ********************** ;;; ******************************** (defparameter *infix-readtable* (copy-readtable nil)) (defparameter *normal-readtable* (copy-readtable nil)) (defmacro infix-error (format-string &rest args) `(let ((*readtable* *normal-readtable*)) (error ,format-string ,@args))) (defun infix-reader (stream subchar arg) ;; Read either #I(...) or #I"..." (declare (ignore arg subchar)) (let ((first-char (peek-char nil stream t nil t))) (cond ((char= first-char #\space) (read-char stream) ; skip over whitespace (infix-reader stream nil nil)) ((char= first-char #\") ;; Read double-quote-delimited infix expressions. (string->prefix (read stream t nil t))) ((char= first-char #\() (read-char stream) ; get rid of opening left parenthesis (let ((*readtable* *infix-readtable*) (*normal-readtable* *readtable*)) (read-infix stream))) (t (infix-error "Infix expression starts with ~A" first-char))))) (set-dispatch-macro-character #\# #\I #'infix-reader *readtable*) ; was #\# #\$ (defun string->prefix (string) "Convert a string to a prefix s-expression using the infix reader. If the argument is not a string, just return it as is." (if (stringp string) (with-input-from-string (stream (concatenate 'string "#I(" string ")")) (read stream)) string)) (defun read-infix (stream) (let* ((result (gather-superiors '\) stream)) ; %infix-end-token% (next-token (read-token stream))) (unless (same-token-p next-token '\)) ; %infix-end-token% (infix-error "Infix expression ends with ~A." next-token)) result)) (defun read-regular (stream) (let ((*readtable* *normal-readtable*)) (read stream t nil t))) ;;; ******************************** ;;; Reader Code ******************** ;;; ******************************** (defun same-operator-p (x y) (same-token-p x y)) (defun same-token-p (x y) (and (symbolp x) (symbolp y) (string-equal (symbol-name x) (symbol-name y)))) ;;; Peeking Token Reader (defvar *peeked-token* nil) (defun read-token (stream) (if *peeked-token* (pop *peeked-token*) (read stream t nil t))) (defun peek-token (stream) (unless *peeked-token* (push (read stream t nil t) *peeked-token*)) (car *peeked-token*)) ;;; Hack to work around + and - being terminating macro characters, ;;; so 1e-3 doesn't normally work correctly. (defun fancy-number-format-p (left operator stream) (when (and (symbolp left) (find operator '(+ -) :test #'same-operator-p)) (let* ((name (symbol-name left)) (length (length name))) (when (and (valid-numberp (subseq name 0 (1- length))) ;; Exponent, Single, Double, Float, or Long (find (subseq name (1- length)) '("e" "s" "d" "f" "l") :test #'string-equal)) (read-token stream) (let ((right (peek-token stream))) (cond ((integerp right) ;; it is one of the fancy numbers, so return it (read-token stream) (let ((*readtable* *normal-readtable*)) (read-from-string (format nil "~A~A~A" left operator right)))) (t ;; it isn't one of the fancy numbers, so unread the token (push operator *peeked-token*) ;; and return nil nil))))))) (defun valid-numberp (string) (let ((saw-dot nil) (char-list (coerce string 'list))) (unless char-list (return-from valid-numberp nil)) (dolist (char char-list t) (cond ((char= char #\.) (if saw-dot (return nil) (setq saw-dot t))) ((not (find char "01234567890" :test #'char=)) (return nil)))))) ;;; Gobbles an expression from the stream. (defun gather-superiors (previous-operator stream) "Gathers an expression whose operators all exceed the precedence of the operator to the left." (let ((left (get-first-token stream))) (loop (setq left (post-process-expression left)) (let ((peeked-token (peek-token stream))) (let ((fancy-p (fancy-number-format-p left peeked-token stream))) (when fancy-p ;; i.e., we've got a number like 1e-3 or 1e+3 or 1f-1 (setq left fancy-p peeked-token (peek-token stream)))) (unless (or (operator-lessp previous-operator peeked-token) (and (same-operator-p peeked-token previous-operator) (operator-right-associative-p previous-operator))) ;; The loop should continue when the peeked operator is ;; either superior in precedence to the previous operator, ;; or the same operator and right-associative. (return left))) (setq left (get-next-token stream left))))) (defun get-first-token (stream) (let ((token (read-token stream))) (if (token-operator-p token) ;; It's an operator in a prefix context. (apply-token-prefix-operator token stream) ;; It's a regular token token))) (defun apply-token-prefix-operator (token stream) (let ((operator (get-token-prefix-operator token))) (if operator (funcall operator stream) (infix-error "~A is not a prefix operator" token)))) (defun get-next-token (stream left) (let ((token (read-token stream))) (apply-token-infix-operator token left stream))) (defun apply-token-infix-operator (token left stream) (let ((operator (get-token-infix-operator token))) (if operator (funcall operator stream left) (infix-error "~A is not an infix operator" token)))) ;;; Fix to read-delimited-list so that it works with tokens, not ;;; characters. (defun infix-read-delimited-list (end-token delimiter-token stream) (do ((next-token (peek-token stream) (peek-token stream)) (list nil)) ((same-token-p next-token end-token) ;; We've hit the end. Remove the end-token from the stream. (read-token stream) ;; and return the list of tokens. ;; Note that this does the right thing with [] and (). (nreverse list)) ;; Ignore the delimiters. (when (same-token-p next-token delimiter-token) (read-token stream)) ;; Gather the expression until the next delimiter. (push (gather-superiors delimiter-token stream) list))) ;;; ******************************** ;;; Precedence ********************* ;;; ******************************** (defparameter *operator-ordering* '(( \[ \( \! ) ; \[ is array reference ( ^ ) ; exponentiation ( ~ ) ; lognot ( * / % ) ; % is mod ( + - ) ( << >> ) ( < == > <= != >= ) ( & ) ; logand ( ^^ ) ; logxor ( \| ) ; logior ( not ) ( and ) ( or ) ;; Where should setf and friends go in the precedence? ( = |:=| += -= *= /= ) ( \, ) ; progn (statement delimiter) ( if ) ( then else ) ( \] \) ) ( %infix-end-token% )) ; end of infix expression "Ordered list of operators of equal precedence.") (defun operator-lessp (op1 op2) (dolist (ops *operator-ordering* nil) (cond ((find op1 ops :test #'same-token-p) (return nil)) ((find op2 ops :test #'same-token-p) (return t))))) (defparameter *right-associative-operators* '(^ =)) (defun operator-right-associative-p (operator) (find operator *right-associative-operators*)) ;;; ******************************** ;;; Define Operators *************** ;;; ******************************** (defvar *token-operators* nil) (defvar *token-prefix-operator-table* (make-hash-table)) (defvar *token-infix-operator-table* (make-hash-table)) (defun token-operator-p (token) (find token *token-operators*)) (defun get-token-prefix-operator (token) (gethash token *token-prefix-operator-table*)) (defun get-token-infix-operator (token) (gethash token *token-infix-operator-table*)) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro define-token-operator (operator-name &key (prefix nil prefix-p) (infix nil infix-p)) `(progn (pushnew ',operator-name *token-operators*) ,(when prefix-p `(setf (gethash ',operator-name *token-prefix-operator-table*) #'(lambda (stream) ,@(cond ((and (consp prefix) (eq (car prefix) 'infix-error)) ;; To avoid ugly compiler warnings. `((declare (ignore stream)) ,prefix)) (t (list prefix)))))) ,(when infix-p `(setf (gethash ',operator-name *token-infix-operator-table*) #'(lambda (stream left) ,@(cond ((and (consp infix) (eq (car infix) 'infix-error)) ;; To avoid ugly compiler warnings. `((declare (ignore stream left)) ,infix)) (t (list infix))))))))) ;;; Readtable definitions for characters, so that the right token is returned. (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro define-character-tokenization (char function) `(set-macro-character ,char ,function nil *infix-readtable*))) ;;; ******************************** ;;; Operator Definitions *********** ;;; ******************************** (define-token-operator and :infix `(and ,left ,(gather-superiors 'and stream))) (define-token-operator or :infix `(or ,left ,(gather-superiors 'or stream))) (define-token-operator not :prefix `(not ,(gather-superiors 'not stream))) (define-token-operator if :prefix (let* ((test (gather-superiors 'if stream)) (then (cond ((same-token-p (peek-token stream) 'then) (read-token stream) (gather-superiors 'then stream)) (t (infix-error "Missing THEN clause.")))) (else (when (same-token-p (peek-token stream) 'else) (read-token stream) (gather-superiors 'else stream)))) (cond ((and test then else) `(if ,test ,then ,else)) ((and test then) ;; no else clause `(when ,test ,then)) ((and test else) ;; no then clause `(unless ,test ,else)) (t ;; no then and else clauses --> always NIL nil)))) (define-token-operator then :prefix (infix-error "THEN clause without an IF.")) (define-token-operator else :prefix (infix-error "ELSE clause without an IF.")) (define-character-tokenization #\+ #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\=) (read-char stream t nil t) '+=) (t '+)))) (define-token-operator + :infix `(+ ,left ,(gather-superiors '+ stream)) :prefix (gather-superiors '+ stream)) (define-token-operator += :infix `(incf ,left ,(gather-superiors '+= stream))) (define-character-tokenization #\- #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\=) (read-char stream t nil t) '-=) (t '-)))) (define-token-operator - :infix `(- ,left ,(gather-superiors '- stream)) :prefix `(- ,(gather-superiors '- stream))) (define-token-operator -= :infix `(decf ,left ,(gather-superiors '-= stream))) (define-character-tokenization #\* #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\=) (read-char stream t nil t) '*=) (t '*)))) (define-token-operator * :infix `(* ,left ,(gather-superiors '* stream))) (define-token-operator *= :infix `(,(if (symbolp left) 'setq 'setf) ,left (* ,left ,(gather-superiors '*= stream)))) (define-character-tokenization #\/ #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\=) (read-char stream t nil t) '/=) (t '/)))) (define-token-operator / :infix `(/ ,left ,(gather-superiors '/ stream)) :prefix `(/ ,(gather-superiors '/ stream))) (define-token-operator /= :infix `(,(if (symbolp left) 'setq 'setf) ,left (/ ,left ,(gather-superiors '/= stream)))) (define-character-tokenization #\^ #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\^) (read-char stream t nil t) '^^) (t '^)))) (define-token-operator ^ :infix `(expt ,left ,(gather-superiors '^ stream))) (define-token-operator ^^ :infix `(logxor ,left ,(gather-superiors '^^ stream))) (define-character-tokenization #\| #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\|) (read-char stream t nil t) 'or) (t '\|)))) (define-token-operator \| :infix `(logior ,left ,(gather-superiors '\| stream))) (define-character-tokenization #\& #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\&) (read-char stream t nil t) 'and) (t '\&)))) (define-token-operator \& :infix `(logand ,left ,(gather-superiors '\& stream))) (define-character-tokenization #\% #'(lambda (stream char) (declare (ignore stream char)) '\%)) (define-token-operator \% :infix `(mod ,left ,(gather-superiors '\% stream))) (define-character-tokenization #\~ #'(lambda (stream char) (declare (ignore stream char)) '\~)) (define-token-operator \~ :prefix `(lognot ,(gather-superiors '\~ stream))) (define-character-tokenization #\, #'(lambda (stream char) (declare (ignore stream char)) '\,)) (define-token-operator \, :infix `(progn ,left ,(gather-superiors '\, stream))) (define-character-tokenization #\= #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\=) (read-char stream t nil t) '==) (t '=)))) (define-token-operator == :infix `(= ,left ,(gather-superiors '== stream))) (define-token-operator = :infix `(,(if (symbolp left) 'setq 'setf) ,left ,(gather-superiors '= stream))) (define-character-tokenization #\: #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\=) (read-char stream t nil t) '|:=|) (t '|:|)))) (define-token-operator |:=| :infix `(,(if (symbolp left) 'setq 'setf) ,left ,(gather-superiors '|:=| stream))) (define-character-tokenization #\< #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\=) (read-char stream t nil t) '<=) ((char= (peek-char nil stream t nil t) #\<) (read-char stream t nil t) '<<) (t '<)))) (define-token-operator < :infix `(< ,left ,(gather-superiors '< stream))) (define-token-operator <= :infix `(<= ,left ,(gather-superiors '<= stream))) (define-token-operator << :infix `(ash ,left ,(gather-superiors '<< stream))) (define-character-tokenization #\> #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\=) (read-char stream t nil t) '>=) ((char= (peek-char nil stream t nil t) #\>) (read-char stream t nil t) '>>) (t '>)))) (define-token-operator > :infix `(> ,left ,(gather-superiors '> stream))) (define-token-operator >= :infix `(>= ,left ,(gather-superiors '>= stream))) (define-token-operator >> :infix `(ash ,left (- ,(gather-superiors '>> stream)))) (define-character-tokenization #\! #'(lambda (stream char) (declare (ignore char)) (cond ((char= (peek-char nil stream t nil t) #\=) (read-char stream t nil t) '!=) (t '!)))) (define-token-operator != :infix `(not (= ,left ,(gather-superiors '!= stream)))) (define-token-operator ! :prefix (read-regular stream)) (define-character-tokenization #\[ #'(lambda (stream char) (declare (ignore stream char)) '\[)) (define-token-operator \[ :infix (let ((indices (infix-read-delimited-list '\] '\, stream))) (if (null indices) (infix-error "No indices found in array reference.") `(aref ,left ,@indices))) :prefix (let ((list-members (infix-read-delimited-list '\] '\, stream))) `(:[ ,@list-members))) (define-character-tokenization #\( #'(lambda (stream char) (declare (ignore stream char)) '\()) (define-token-operator \( :infix `(,left ,@(infix-read-delimited-list '\) '\, stream)) :prefix (let ((list (infix-read-delimited-list '\) '\, stream))) (if (null (rest list)) ;; only one element in list. works correctly if list is NIL (first list) ;; several elements in list `(progn ,@list)))) (define-character-tokenization #\] #'(lambda (stream char) (declare (ignore stream char)) '\])) (define-token-operator \] :infix (infix-error "Extra close brace \"]\" in infix expression")) (define-character-tokenization #\) #'(lambda (stream char) (declare (ignore stream char)) '\))) (define-token-operator \) :infix (infix-error "Extra close paren \")\" in infix expression")) #| ;;; Commented out because no longer using $ as the macro character. (define-character-tokenization #\$ #'(lambda (stream char) (declare (ignore stream char)) '%infix-end-token%)) (define-token-operator %infix-end-token% :infix (infix-error "Prematurely terminated infix expression") :prefix (infix-error "Prematurely terminated infix expression")) |# (define-character-tokenization #\; #'(lambda (stream char) (declare (ignore char)) (do ((char (peek-char nil stream t nil t) (peek-char nil stream t nil t))) ((or (char= char #\newline) (char= char #\return) ;; was #\$ ; (char= char #\)) ) ;; Gobble characters until the end of the line or the ;; end of the input. (cond ((or (char= char #\newline) (char= char #\return)) (read-char stream) (read stream t nil t)) (t ;; i.e., return %infix-end-token% (read stream t nil t)))) (read-char stream)))) ;;; ******************************** ;;; Syntactic Modifications ******** ;;; ******************************** ;;; Post processes the expression to remove some unsightliness caused ;;; by the way infix processes the input. Note that it is also required ;;; for correctness in the a <= >= progn) :test #'same-operator-p)) ;; Flatten the expression if possible (cond ((and (eq operator '-) (= (length left) 2)) ;; -a-b --> (+ (- a) (- b)). `(+ ,left (- ,right))) ((and (eq operator '/) (= (length left) 2)) ;; ditto with / `(/ (* ,(second left) ,right))) (t ;; merges a+b+c as (+ a b c). (append left (list right))))) ((and (consp left) (eq operator '-) (eq (first left) '+)) ;; merges a+b-c as (+ a b (- c)). (append left (list `(- ,right)))) ((and (consp left) (find operator '(< > <= >=)) (find (first left) '(< > <= >=))) ;; a a>b" (ash a (- b))) ("~a" (lognot a)) ("a&&b" (and a b)) ("a||b" (or a b)) ("a%b" (mod a b)) ;; Comment character -- must have carriage return after semicolon. ("x^2 ; the x coordinate + y^2 ; the y coordinate" :error) ("x^2 ; the x coordinate + y^2 ; the y coordinate " (+ (expt x 2) (expt y 2))) ;; Errors ("foo(bar,baz" :error) ; premature termination ;; The following no longer gives an error ("foo(bar,baz))" (foo bar baz)) ; extra close parenthesis ("foo[bar,baz]]" :error) ; extra close bracket ("[foo,bar]" (:[ foo bar)) ; Maxima-style list ("and a" :error) ; AND is not a prefix operator ("< a" :error) ; < is not a prefix operator ("=bar" :error) ; SETF is not a prefix operator ("*bar" :error) ; * is not a prefix operator ("a not b" :error) ; NOT is not an infix operator ("a if b then c" :error) ; IF is not an infix operator ("" :error) ; premature termination (empty clause) (")a" :error) ; left parent is not a prefix operator ("]a" :error) ; left bracket is not a prefix operator )) (defun test-infix (&optional (tests *test-cases*)) (let ((count 0)) (dolist (test tests) (destructuring-bind (string result) test (unless (test-infix-case string result) (incf count)))) (format t "~&~:(~R~) test~p failed." count count) (values))) (defun test-infix-case (string result) (multiple-value-bind (value error) (let ((*package* (find-package "INFIX"))) (ignore-errors (values (read-from-string (concatenate 'string "#I(" string ")") t nil)))) (cond (error (cond ((eq result :error) t) (t (format t "~&Test #I(~A) failed with ERROR." string) nil))) ((eq result :error) (format t "~&Test #I(~A) failed. ~ ~& Expected ERROR ~ ~& but got ~A." string value) nil) ((not (equal value result)) (format t "~&Test #I(~A) failed. ~ ~& Expected ~A ~ ~& but got ~A." string result value) nil) (t t)))) ;;; *EOF*