├── LICENSE.txt ├── README.md ├── attic └── infix.cl ├── cmu-infix-tests.asd ├── cmu-infix.asd ├── src ├── cmu-infix.lisp └── package.lisp └── tests ├── package.lisp └── tests.lisp /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Written by Mark Kantrowitz, School of Computer Science, 2 | Carnegie Mellon University, March 1993. 3 | 4 | Copyright (c) 1993 by Mark Kantrowitz. All rights reserved. 5 | 6 | Use and copying of this software and preparation of derivative works 7 | based upon this software are permitted, so long as the following 8 | conditions are met: 9 | 10 | * no fees or compensation are charged for use, copies, 11 | distribution or access to this software 12 | 13 | * this copyright notice is included intact. 14 | 15 | This software is made available AS IS, and no warranty is made about 16 | the software or its performance. 17 | 18 | In no event will the author(s) or their institutions be liable to you 19 | for damages, including lost profits, lost monies, or other special, 20 | incidental or consequential damages, arising out of or in connection 21 | with the use or inability to use (including but not limited to loss of 22 | data or data being rendered inaccurate or losses sustained by third 23 | parties or a failure of the program to operate as documented) the 24 | program, or for any claim by any other party, whether in an action of 25 | contract, negligence, or other tortious action. 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CMU-INFIX 2 | 3 | A library for writing infix mathematical notation in Common Lisp. 4 | 5 | ## Origin 6 | 7 | This library was originally written by Mark Kantrowitz in 1993 with updates the following few years. The code in this repository was derived from the original [`infix.cl`](https://www.cs.cmu.edu/Groups/AI/lang/lisp/code/syntax/infix/infix.cl) library provided by the CMU AI Repository. For posterity, a copy of this original file—otherwise unused by this library—can be found in [`attic/infix.cl`](attic/infix.cl). 8 | 9 | With minimal changes to the core functionality, the library was modernized by Robert Smith to be in-line with contemporary Common Lisp usage. 10 | 11 | ## Example Use 12 | 13 | This package uses [`named-readtables`](https://common-lisp.net/project/named-readtables) to manage the readtables. If you've loaded `CMU-INFIX` successfully, then you'll have this package loaded as well. 14 | 15 | To use `CMU-INFIX`, simply use the readtable named `cmu-infix:syntax`: 16 | 17 | ```lisp 18 | (named-readtables:in-readtable cmu-infix:syntax) 19 | ``` 20 | 21 | Once you have this, you can use the `#I` syntax for infix syntax. Here are some examples. 22 | 23 | **Example**: Pythagorean Theorem 24 | 25 | ```lisp 26 | (defun hypot (a b) 27 | "Compute the length of the hypotenuse of a right triangle 28 | with sides A and B." 29 | #I( sqrt(a^^2 + b^^2) )) 30 | ``` 31 | 32 | **Example**: Power-of-Two Check 33 | 34 | ```lisp 35 | (defun power-of-two-p (n) 36 | "Check if N is a power of 2." 37 | #I( n != 0 and (n & (n - 1)) == 0 )) 38 | ``` 39 | 40 | 41 | 42 | **Example**: Euclidean Algorithm 43 | 44 | ```lisp 45 | (defun euclid (a b) 46 | "Compute the GCD of A and B using Euclid's algorithm." 47 | (let (temp) 48 | (loop :until #I( b == 0 ) :do 49 | #I( temp := b, 50 | b := a % b, 51 | a := temp 52 | )) 53 | a)) 54 | ``` 55 | 56 | **Example**: Matrix Multiplication 57 | 58 | ```lisp 59 | (defun matmul (A B) 60 | "Compute C = A * B for matrices A and B." 61 | (let* ((m (array-dimension A 0)) 62 | (n (array-dimension A 1)) 63 | (q (array-dimension B 1)) 64 | (C (make-array (list m q) :initial-element 0))) 65 | (loop :for i :below m :do 66 | (loop :for k :below q :do 67 | (loop :for j :below n :do 68 | #I( C[i, k] += A[i, j] * B[j, k] )))) 69 | C)) 70 | 71 | ;; Example: 72 | (let ((A (make-array '(2 2) :initial-contents '((0 1) (1 0)))) 73 | (B (make-array '(2 1) :initial-contents '((2) (3))))) 74 | #I( matmul(A, B) )) 75 | ``` 76 | 77 | A full description of the supported operators is in the package documentation for `CMU-INFIX`: 78 | 79 | ```lisp 80 | (format t "~A" (documentation (find-package :cmu-infix) t)) 81 | ``` 82 | 83 | ## Modernization Updates 84 | 85 | The library has been updated in the following ways: 86 | 87 | * The package of this library has been renamed `CMU-INFIX` so as to not conflict with existing Quicklisp libraries. 88 | 89 | * A system of the same name has been made so it is loadable by ASDF. 90 | 91 | * The tests have been lifted and put into a separate system called `CMU-INFIX-TESTS`. You can run them by doing 92 | 93 | ```lisp 94 | (asdf:test-system :cmu-infix) 95 | ``` 96 | 97 | * The library was modified to use `NAMED-READTABLES` to not eagerly pollute your readtable. 98 | 99 | * Some out-of-date comments have been deleted. 100 | 101 | ## Contributing 102 | 103 | After receiving permission from Mark Kantrowitz, [Rigetti Computing](http://rigetti.com/) has taken stewardship of the library. Questions and issues should be filed on GitHub [here](https://github.com/rigetticomputing/cmu-infix), and pull requests are welcome. The licensing terms are described in [`LICENSE.txt`](LICENSE.txt). -------------------------------------------------------------------------------- /attic/infix.cl: -------------------------------------------------------------------------------- 1 | ;;; Wed Jan 18 13:13:59 1995 by Mark Kantrowitz 2 | ;;; infix.cl -- 40545 bytes 3 | 4 | ;;; ************************************************************************** 5 | ;;; Infix ******************************************************************** 6 | ;;; ************************************************************************** 7 | ;;; 8 | ;;; This is an implementation of an infix reader macro. It should run in any 9 | ;;; valid Common Lisp and has been tested in Allegro CL 4.1, Lucid CL 4.0.1, 10 | ;;; MCL 2.0 and CMU CL. It allows the user to type arithmetic expressions in 11 | ;;; the traditional way (e.g., 1+2) when writing Lisp programs instead of 12 | ;;; using the normal Lisp syntax (e.g., (+ 1 2)). It is not intended to be a 13 | ;;; full replacement for the normal Lisp syntax. If you want a more complete 14 | ;;; alternate syntax for Lisp, get a copy Apple's MLisp or Pratt's CGOL. 15 | ;;; 16 | ;;; Although similar in concept to the Symbolics infix reader (#), 17 | ;;; no real effort has been made to ensure compatibility beyond coverage 18 | ;;; of at least the same set of basic arithmetic operators. There are several 19 | ;;; differences in the syntax beyond just the choice of #I as the macro 20 | ;;; character. (Our syntax is a little bit more C-like than the Symbolics 21 | ;;; macro in addition to some more subtle differences.) 22 | ;;; 23 | ;;; We initially chose $ as a macro character because of its association 24 | ;;; with mathematics in LaTeX, but unfortunately that character is already 25 | ;;; used in MCL. We switched to #I() because it was one of the few options 26 | ;;; remaining. 27 | ;;; 28 | ;;; Written by Mark Kantrowitz, School of Computer Science, 29 | ;;; Carnegie Mellon University, March 1993. 30 | ;;; 31 | ;;; Copyright (c) 1993 by Mark Kantrowitz. All rights reserved. 32 | ;;; 33 | ;;; Use and copying of this software and preparation of derivative works 34 | ;;; based upon this software are permitted, so long as the following 35 | ;;; conditions are met: 36 | ;;; o no fees or compensation are charged for use, copies, 37 | ;;; distribution or access to this software 38 | ;;; o this copyright notice is included intact. 39 | ;;; This software is made available AS IS, and no warranty is made about 40 | ;;; the software or its performance. 41 | ;;; 42 | ;;; In no event will the author(s) or their institutions be liable to you for 43 | ;;; damages, including lost profits, lost monies, or other special, incidental 44 | ;;; or consequential damages, arising out of or in connection with the use or 45 | ;;; inability to use (including but not limited to loss of data or data being 46 | ;;; rendered inaccurate or losses sustained by third parties or a failure of 47 | ;;; the program to operate as documented) the program, or for any claim by 48 | ;;; any other party, whether in an action of contract, negligence, or 49 | ;;; other tortious action. 50 | ;;; 51 | ;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu. 52 | ;;; 53 | ;;; The current version of this software and a variety of related utilities 54 | ;;; may be obtained from the Lisp Repository by anonymous ftp 55 | ;;; from ftp.cs.cmu.edu [128.2.206.173] in the directory 56 | ;;; user/ai/lang/lisp/code/syntax/infix/ 57 | ;;; If your site runs the Andrew File System, you can cd to the AFS directory 58 | ;;; /afs/cs.cmu.edu/project/ai-repository/ai/lang/lisp/code/syntax/infix/ 59 | ;;; 60 | ;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list, 61 | ;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email 62 | ;;; address, and affiliation. This mailing list is primarily for 63 | ;;; notification about major updates, bug fixes, and additions to the Lisp 64 | ;;; Utilities Repository. The mailing list is intended to have low traffic. 65 | ;;; 66 | 67 | ;;; ******************************** 68 | ;;; Documentation ****************** 69 | ;;; ******************************** 70 | ;;; 71 | ;;; Syntax: 72 | ;;; 73 | ;;; Begin the reader macro with #I( and end it with ). For example, 74 | ;;; #I( x^^2 + y^^2 ) 75 | ;;; is equivalent to the Lisp form 76 | ;;; (+ (expt x 2) (expt y 2)) 77 | ;;; but much easier to read according to some folks. 78 | ;;; 79 | ;;; If you want to see the expansion, type a quote before the #I form 80 | ;;; at the Lisp prompt: 81 | ;;; > '#I(if x x-y 92 | ;;; ! lisp escape !(foo bar) --> (foo bar) 93 | ;;; ; comment 94 | ;;; x = y assignment (setf x y) 95 | ;;; x += y increment (incf x y) 96 | ;;; x -= y decrement (decf x y) 97 | ;;; x *= y multiply and store (setf x (* x y)) 98 | ;;; x /= y divide and store (setf x (/ x y)) 99 | ;;; x|y bitwise logical inclusive or (logior x y) 100 | ;;; x^y bitwise logical exclusive or (logxor x y) 101 | ;;; x&y bitwise logical and (logand x y) 102 | ;;; x<>y right shift (ash x (- y)) 104 | ;;; ~x ones complement (unary) (lognot x) 105 | ;;; x and y conjunction (and x y) 106 | ;;; x && y conjunction (and x y) 107 | ;;; x or y disjunction (or x y) 108 | ;;; x || y disjunction (or x y) 109 | ;;; not x negation (not x) 110 | ;;; x^^y exponentiation (expt x y) 111 | ;;; x,y sequence (progn x y) 112 | ;;; (x,y) sequence (progn x y) 113 | ;;; also parenthesis (x+y)/z --> (/ (+ x y) z) 114 | ;;; f(x,y) functions (f x y) 115 | ;;; a[i,j] array reference (aref a i j) 116 | ;;; x+y x*y arithmetic (+ x y) (* x y) 117 | ;;; x-y x/y arithmetic (- x y) (/ x y) 118 | ;;; -y value negation (- y) 119 | ;;; x % y remainder (mod x y) 120 | ;;; xy inequalities (< x y) (> x y) 121 | ;;; x <= y x >= y inequalities (<= x y) (>= x y) 122 | ;;; x == y equality (= x y) 123 | ;;; x != y equality (not (= x y)) 124 | ;;; if p then q conditional (when p q) 125 | ;;; if p then q else r conditional (if p q r) 126 | ;;; 127 | 128 | ;;; Precedence: 129 | ;;; 130 | ;;; The following precedence conventions are obeyed by the infix operators: 131 | ;;; [ ( ! 132 | ;;; ^^ 133 | ;;; ~ 134 | ;;; * / % 135 | ;;; + - 136 | ;;; << >> 137 | ;;; < == > <= != >= 138 | ;;; & 139 | ;;; ^ 140 | ;;; | 141 | ;;; not 142 | ;;; and 143 | ;;; or 144 | ;;; = += -= *= /= 145 | ;;; , 146 | ;;; if 147 | ;;; then else 148 | ;;; ] ) 149 | ;;; 150 | ;;; Note that logical negation has lower precedence than numeric comparison 151 | ;;; so that "not aprefix, support 191 | ;;; for #I"..." in addition to #i(...) which lets one 192 | ;;; type #i"a|b" which doesn't confuse editors that aren't 193 | ;;; |-aware. Also added := as a synonym for =, so that 194 | ;;; '#i"car(a) := b" yields (SETF (CAR A) B). 195 | ;;; 196 | ;;; 1.3: 197 | ;;; 28-JUN-96 mk Modified infix reader to allow whitespace between the #I 198 | ;;; and the start of the expression. 199 | 200 | 201 | 202 | ;;; ******************************** 203 | ;;; Implementation Notes *********** 204 | ;;; ******************************** 205 | ;;; 206 | ;;; Initially we tried implementing everything within the Lisp reader, 207 | ;;; but found this to not be workable. Parameters had to be passed in 208 | ;;; global variables, and some of the processing turned out to be 209 | ;;; indelible, so it wasn't possible to use any kind of lookahead. 210 | ;;; Center-embedded constructions were also a problem, due to the lack 211 | ;;; of an explicit stack. 212 | ;;; 213 | ;;; So we took another tack, that used below. The #I macro binds the 214 | ;;; *readtable* to a special readtable, which is used solely for tokenization 215 | ;;; of the input. Then the problem is how to correctly parenthesize the input. 216 | ;;; We do that with what is essentially a recursive-descent parser. An 217 | ;;; expression is either a prefix operator followed by an expression, or an 218 | ;;; expression followed by an infix operator followed by an expression. When 219 | ;;; the latter expression is complex, the problem becomes a little tricky. 220 | ;;; For example, suppose we have 221 | ;;; exp1 op1 exp2 op2 222 | ;;; We need to know whether to parenthesize it as 223 | ;;; (exp1 op1 exp2) op2 224 | ;;; or as 225 | ;;; exp1 op1 (exp2 op2 ...) 226 | ;;; The second case occurs either when op2 has precedence over op1 (e.g., 227 | ;;; * has precedence over +) or op2 and op1 are the same right-associative 228 | ;;; operator (e.g., exponentiation). Thus the algorithm is as follows: 229 | ;;; When we see op1, we want to gobble up exp2 op2 exp3 op3 ... opn expn+1 230 | ;;; into an expression where op2 through opn all have higher precedence 231 | ;;; than op1 (or are the same right-associative operator), and opn+1 doesn't. 232 | ;;; This algorithm is implemented by the GATHER-SUPERIORS function. 233 | ;;; 234 | ;;; Because + and - are implemented in the infix readtable as terminating 235 | ;;; macro cahracters, the exponentiation version of Lisp number syntax 236 | ;;; 1e-3 == 0.001 237 | ;;; doesn't work correctly -- it parses it as (- 1e 3). So we add a little 238 | ;;; cleverness to GATHER-SUPERIORS to detect when the tokenizer goofed. 239 | ;;; Since this requires the ability to lookahead two tokens, we use a 240 | ;;; stack to implement the lookahead in PEEK-TOKEN and READ-TOKEN. 241 | ;;; 242 | ;;; Finally, the expression returned by GATHER-SUPERIORS sometimes needs to 243 | ;;; be cleaned up a bit. For example, parsing aprefix)) 257 | 258 | (pushnew :infix *features*) 259 | 260 | (eval-when (compile load eval) 261 | (defparameter *version* "1.3 28-JUN-96") 262 | (defparameter *print-infix-copyright* t 263 | "If non-NIL, prints a copyright notice upon loading this file.") 264 | 265 | (defun infix-copyright (&optional (stream *standard-output*)) 266 | "Prints an INFIX copyright notice and header upon startup." 267 | (format stream "~%;;; ~V,,,'*A" 73 "*") 268 | (format stream "~%;;; Infix notation for Common Lisp.") 269 | (format stream "~%;;; Version ~A." *version*) 270 | (format stream "~%;;; Written by Mark Kantrowitz, ~ 271 | CMU School of Computer Science.") 272 | (format stream "~%;;; Copyright (c) 1993-95. All rights reserved.") 273 | (format stream "~%;;; May be freely redistributed, provided this ~ 274 | notice is left intact.") 275 | (format stream "~%;;; This software is made available AS IS, without ~ 276 | any warranty.") 277 | (format stream "~%;;; ~V,,,'*A~%" 73 "*") 278 | (force-output stream)) 279 | 280 | ;; What this means is you can either turn off the copyright notice 281 | ;; by setting the parameter, or you can turn it off by including 282 | ;; (setf (get :infix :dont-print-copyright) t) in your lisp init file. 283 | (when (and *print-infix-copyright* 284 | (not (get :infix :dont-print-copyright))) 285 | (infix-copyright))) 286 | 287 | ;;; ******************************** 288 | ;;; Readtable ********************** 289 | ;;; ******************************** 290 | 291 | (defparameter *infix-readtable* (copy-readtable nil)) 292 | (defparameter *normal-readtable* (copy-readtable nil)) 293 | 294 | (defun infix-reader (stream subchar arg) 295 | ;; Read either #I(...) or #I"..." 296 | (declare (ignore arg subchar)) 297 | (let ((first-char (peek-char nil stream t nil t))) 298 | (cond ((char= first-char #\space) 299 | (read-char stream) ; skip over whitespace 300 | (infix-reader stream nil nil)) 301 | ((char= first-char #\") 302 | ;; Read double-quote-delimited infix expressions. 303 | (string->prefix (read stream t nil t))) 304 | ((char= first-char #\() 305 | (read-char stream) ; get rid of opening left parenthesis 306 | (let ((*readtable* *infix-readtable*) 307 | (*normal-readtable* *readtable*)) 308 | (read-infix stream))) 309 | (t 310 | (infix-error "Infix expression starts with ~A" first-char))))) 311 | 312 | (set-dispatch-macro-character #\# #\I #'infix-reader *readtable*) ; was #\# #\$ 313 | 314 | (defun string->prefix (string) 315 | "Convert a string to a prefix s-expression using the infix reader. 316 | If the argument is not a string, just return it as is." 317 | (if (stringp string) 318 | (with-input-from-string (stream (concatenate 'string "#I(" string ")")) 319 | (read stream)) 320 | string)) 321 | 322 | (defmacro infix-error (format-string &rest args) 323 | `(let ((*readtable* *normal-readtable*)) 324 | (error ,format-string ,@args))) 325 | 326 | (defun read-infix (stream) 327 | (let* ((result (gather-superiors '\) stream)) ; %infix-end-token% 328 | (next-token (read-token stream))) 329 | (unless (same-token-p next-token '\)) ; %infix-end-token% 330 | (infix-error "Infix expression ends with ~A." next-token)) 331 | result)) 332 | 333 | (defun read-regular (stream) 334 | (let ((*readtable* *normal-readtable*)) 335 | (read stream t nil t))) 336 | 337 | 338 | ;;; ******************************** 339 | ;;; Reader Code ******************** 340 | ;;; ******************************** 341 | 342 | (defun same-operator-p (x y) 343 | (same-token-p x y)) 344 | 345 | (defun same-token-p (x y) 346 | (and (symbolp x) 347 | (symbolp y) 348 | (string-equal (symbol-name x) (symbol-name y)))) 349 | 350 | ;;; Peeking Token Reader 351 | 352 | (defvar *peeked-token* nil) 353 | (defun read-token (stream) 354 | (if *peeked-token* 355 | (pop *peeked-token*) 356 | (read stream t nil t))) 357 | (defun peek-token (stream) 358 | (unless *peeked-token* 359 | (push (read stream t nil t) *peeked-token*)) 360 | (car *peeked-token*)) 361 | 362 | ;;; Hack to work around + and - being terminating macro characters, 363 | ;;; so 1e-3 doesn't normally work correctly. 364 | 365 | (defun fancy-number-format-p (left operator stream) 366 | (when (and (symbolp left) 367 | (find operator '(+ -) :test #'same-operator-p)) 368 | (let* ((name (symbol-name left)) 369 | (length (length name))) 370 | (when (and (valid-numberp (subseq name 0 (1- length))) 371 | ;; Exponent, Single, Double, Float, or Long 372 | (find (subseq name (1- length)) 373 | '("e" "s" "d" "f" "l") 374 | :test #'string-equal)) 375 | (read-token stream) 376 | (let ((right (peek-token stream))) 377 | (cond ((integerp right) 378 | ;; it is one of the fancy numbers, so return it 379 | (read-token stream) 380 | (let ((*readtable* *normal-readtable*)) 381 | (read-from-string (format nil "~A~A~A" 382 | left operator right)))) 383 | (t 384 | ;; it isn't one of the fancy numbers, so unread the token 385 | (push operator *peeked-token*) 386 | ;; and return nil 387 | nil))))))) 388 | 389 | (defun valid-numberp (string) 390 | (let ((saw-dot nil)) 391 | (dolist (char (coerce string 'list) t) 392 | (cond ((char= char #\.) 393 | (if saw-dot 394 | (return nil) 395 | (setq saw-dot t))) 396 | ((not (find char "01234567890" :test #'char=)) 397 | (return nil)))))) 398 | 399 | ;;; Gobbles an expression from the stream. 400 | 401 | (defun gather-superiors (previous-operator stream) 402 | "Gathers an expression whose operators all exceed the precedence of 403 | the operator to the left." 404 | (let ((left (get-first-token stream))) 405 | (loop 406 | (setq left (post-process-expression left)) 407 | (let ((peeked-token (peek-token stream))) 408 | (let ((fancy-p (fancy-number-format-p left peeked-token stream))) 409 | (when fancy-p 410 | ;; i.e., we've got a number like 1e-3 or 1e+3 or 1f-1 411 | (setq left fancy-p 412 | peeked-token (peek-token stream)))) 413 | (unless (or (operator-lessp previous-operator peeked-token) 414 | (and (same-operator-p peeked-token previous-operator) 415 | (operator-right-associative-p previous-operator))) 416 | ;; The loop should continue when the peeked operator is 417 | ;; either superior in precedence to the previous operator, 418 | ;; or the same operator and right-associative. 419 | (return left))) 420 | (setq left (get-next-token stream left))))) 421 | 422 | (defun get-first-token (stream) 423 | (let ((token (read-token stream))) 424 | (if (token-operator-p token) 425 | ;; It's an operator in a prefix context. 426 | (apply-token-prefix-operator token stream) 427 | ;; It's a regular token 428 | token))) 429 | 430 | (defun apply-token-prefix-operator (token stream) 431 | (let ((operator (get-token-prefix-operator token))) 432 | (if operator 433 | (funcall operator stream) 434 | (infix-error "~A is not a prefix operator" token)))) 435 | 436 | (defun get-next-token (stream left) 437 | (let ((token (read-token stream))) 438 | (apply-token-infix-operator token left stream))) 439 | 440 | (defun apply-token-infix-operator (token left stream) 441 | (let ((operator (get-token-infix-operator token))) 442 | (if operator 443 | (funcall operator stream left) 444 | (infix-error "~A is not an infix operator" token)))) 445 | 446 | ;;; Fix to read-delimited-list so that it works with tokens, not 447 | ;;; characters. 448 | 449 | (defun infix-read-delimited-list (end-token delimiter-token stream) 450 | (do ((next-token (peek-token stream) (peek-token stream)) 451 | (list nil)) 452 | ((same-token-p next-token end-token) 453 | ;; We've hit the end. Remove the end-token from the stream. 454 | (read-token stream) 455 | ;; and return the list of tokens. 456 | ;; Note that this does the right thing with [] and (). 457 | (nreverse list)) 458 | ;; Ignore the delimiters. 459 | (when (same-token-p next-token delimiter-token) 460 | (read-token stream)) 461 | ;; Gather the expression until the next delimiter. 462 | (push (gather-superiors delimiter-token stream) list))) 463 | 464 | 465 | ;;; ******************************** 466 | ;;; Precedence ********************* 467 | ;;; ******************************** 468 | 469 | (defparameter *operator-ordering* 470 | '(( \[ \( \! ) ; \[ is array reference 471 | ( ^^ ) ; exponentiation 472 | ( ~ ) ; lognot 473 | ( * / % ) ; % is mod 474 | ( + - ) 475 | ( << >> ) 476 | ( < == > <= != >= ) 477 | ( & ) ; logand 478 | ( ^ ) ; logxor 479 | ( \| ) ; logior 480 | ( not ) 481 | ( and ) 482 | ( or ) 483 | ;; Where should setf and friends go in the precedence? 484 | ( = |:=| += -= *= /= ) 485 | ( \, ) ; progn (statement delimiter) 486 | ( if ) 487 | ( then else ) 488 | ( \] \) ) 489 | ( %infix-end-token% )) ; end of infix expression 490 | "Ordered list of operators of equal precedence.") 491 | 492 | (defun operator-lessp (op1 op2) 493 | (dolist (ops *operator-ordering* nil) 494 | (cond ((find op1 ops :test #'same-token-p) 495 | (return nil)) 496 | ((find op2 ops :test #'same-token-p) 497 | (return t))))) 498 | 499 | (defparameter *right-associative-operators* '(^^ =)) 500 | (defun operator-right-associative-p (operator) 501 | (find operator *right-associative-operators*)) 502 | 503 | 504 | ;;; ******************************** 505 | ;;; Define Operators *************** 506 | ;;; ******************************** 507 | 508 | (defvar *token-operators* nil) 509 | (defvar *token-prefix-operator-table* (make-hash-table)) 510 | (defvar *token-infix-operator-table* (make-hash-table)) 511 | (defun token-operator-p (token) 512 | (find token *token-operators*)) 513 | (defun get-token-prefix-operator (token) 514 | (gethash token *token-prefix-operator-table*)) 515 | (defun get-token-infix-operator (token) 516 | (gethash token *token-infix-operator-table*)) 517 | 518 | (eval-when (compile load eval) 519 | (defmacro define-token-operator (operator-name &key 520 | (prefix nil prefix-p) 521 | (infix nil infix-p)) 522 | `(progn 523 | (pushnew ',operator-name *token-operators*) 524 | ,(when prefix-p 525 | `(setf (gethash ',operator-name *token-prefix-operator-table*) 526 | #'(lambda (stream) 527 | ,@(cond ((and (consp prefix) 528 | (eq (car prefix) 'infix-error)) 529 | ;; To avoid ugly compiler warnings. 530 | `((declare (ignore stream)) 531 | ,prefix)) 532 | (t 533 | (list prefix)))))) 534 | ,(when infix-p 535 | `(setf (gethash ',operator-name *token-infix-operator-table*) 536 | #'(lambda (stream left) 537 | ,@(cond ((and (consp infix) 538 | (eq (car infix) 'infix-error)) 539 | ;; To avoid ugly compiler warnings. 540 | `((declare (ignore stream left)) 541 | ,infix)) 542 | (t 543 | (list infix))))))))) 544 | 545 | ;;; Readtable definitions for characters, so that the right token is returned. 546 | (eval-when (compile load eval) 547 | (defmacro define-character-tokenization (char function) 548 | `(set-macro-character ,char ,function nil *infix-readtable*))) 549 | 550 | 551 | ;;; ******************************** 552 | ;;; Operator Definitions *********** 553 | ;;; ******************************** 554 | 555 | (define-token-operator and 556 | :infix `(and ,left ,(gather-superiors 'and stream))) 557 | (define-token-operator or 558 | :infix `(or ,left ,(gather-superiors 'or stream))) 559 | (define-token-operator not 560 | :prefix `(not ,(gather-superiors 'not stream))) 561 | 562 | (define-token-operator if 563 | :prefix (let* ((test (gather-superiors 'if stream)) 564 | (then (cond ((same-token-p (peek-token stream) 'then) 565 | (read-token stream) 566 | (gather-superiors 'then stream)) 567 | (t 568 | (infix-error "Missing THEN clause.")))) 569 | (else (when (same-token-p (peek-token stream) 'else) 570 | (read-token stream) 571 | (gather-superiors 'else stream)))) 572 | (cond ((and test then else) 573 | `(if ,test ,then ,else)) 574 | ((and test then) 575 | ;; no else clause 576 | `(when ,test ,then)) 577 | ((and test else) 578 | ;; no then clause 579 | `(unless ,test ,else)) 580 | (t 581 | ;; no then and else clauses --> always NIL 582 | nil)))) 583 | 584 | (define-token-operator then 585 | :prefix (infix-error "THEN clause without an IF.")) 586 | (define-token-operator else 587 | :prefix (infix-error "ELSE clause without an IF.")) 588 | 589 | (define-character-tokenization #\+ 590 | #'(lambda (stream char) 591 | (declare (ignore char)) 592 | (cond ((char= (peek-char nil stream t nil t) #\=) 593 | (read-char stream t nil t) 594 | '+=) 595 | (t 596 | '+)))) 597 | (define-token-operator + 598 | :infix `(+ ,left ,(gather-superiors '+ stream)) 599 | :prefix (gather-superiors '+ stream)) 600 | (define-token-operator += 601 | :infix `(incf ,left ,(gather-superiors '+= stream))) 602 | 603 | (define-character-tokenization #\- 604 | #'(lambda (stream char) 605 | (declare (ignore char)) 606 | (cond ((char= (peek-char nil stream t nil t) #\=) 607 | (read-char stream t nil t) 608 | '-=) 609 | (t 610 | '-)))) 611 | (define-token-operator - 612 | :infix `(- ,left ,(gather-superiors '- stream)) 613 | :prefix `(- ,(gather-superiors '- stream))) 614 | (define-token-operator -= 615 | :infix `(decf ,left ,(gather-superiors '-= stream))) 616 | 617 | (define-character-tokenization #\* 618 | #'(lambda (stream char) 619 | (declare (ignore char)) 620 | (cond ((char= (peek-char nil stream t nil t) #\=) 621 | (read-char stream t nil t) 622 | '*=) 623 | (t 624 | '*)))) 625 | (define-token-operator * 626 | :infix `(* ,left ,(gather-superiors '* stream))) 627 | (define-token-operator *= 628 | :infix `(,(if (symbolp left) 629 | 'setq 630 | 'setf) 631 | ,left 632 | (* ,left ,(gather-superiors '*= stream)))) 633 | 634 | (define-character-tokenization #\/ 635 | #'(lambda (stream char) 636 | (declare (ignore char)) 637 | (cond ((char= (peek-char nil stream t nil t) #\=) 638 | (read-char stream t nil t) 639 | '/=) 640 | (t 641 | '/)))) 642 | (define-token-operator / 643 | :infix `(/ ,left ,(gather-superiors '/ stream)) 644 | :prefix `(/ ,(gather-superiors '/ stream))) 645 | (define-token-operator /= 646 | :infix `(,(if (symbolp left) 647 | 'setq 648 | 'setf) 649 | ,left 650 | (/ ,left ,(gather-superiors '/= stream)))) 651 | 652 | (define-character-tokenization #\^ 653 | #'(lambda (stream char) 654 | (declare (ignore char)) 655 | (cond ((char= (peek-char nil stream t nil t) #\^) 656 | (read-char stream t nil t) 657 | '^^) 658 | (t 659 | '^)))) 660 | (define-token-operator ^^ 661 | :infix `(expt ,left ,(gather-superiors '^^ stream))) 662 | (define-token-operator ^ 663 | :infix `(logxor ,left ,(gather-superiors '^ stream))) 664 | 665 | (define-character-tokenization #\| 666 | #'(lambda (stream char) 667 | (declare (ignore char)) 668 | (cond ((char= (peek-char nil stream t nil t) #\|) 669 | (read-char stream t nil t) 670 | 'or) 671 | (t 672 | '\|)))) 673 | (define-token-operator \| 674 | :infix `(logior ,left ,(gather-superiors '\| stream))) 675 | 676 | (define-character-tokenization #\& 677 | #'(lambda (stream char) 678 | (declare (ignore char)) 679 | (cond ((char= (peek-char nil stream t nil t) #\&) 680 | (read-char stream t nil t) 681 | 'and) 682 | (t 683 | '\&)))) 684 | (define-token-operator \& 685 | :infix `(logand ,left ,(gather-superiors '\& stream))) 686 | 687 | (define-character-tokenization #\% 688 | #'(lambda (stream char) 689 | (declare (ignore stream char)) 690 | '\%)) 691 | (define-token-operator \% 692 | :infix `(mod ,left ,(gather-superiors '\% stream))) 693 | 694 | (define-character-tokenization #\~ 695 | #'(lambda (stream char) 696 | (declare (ignore stream char)) 697 | '\~)) 698 | (define-token-operator \~ 699 | :prefix `(lognot ,(gather-superiors '\~ stream))) 700 | 701 | (define-character-tokenization #\, 702 | #'(lambda (stream char) 703 | (declare (ignore stream char)) 704 | '\,)) 705 | (define-token-operator \, 706 | :infix `(progn ,left ,(gather-superiors '\, stream))) 707 | 708 | (define-character-tokenization #\= 709 | #'(lambda (stream char) 710 | (declare (ignore char)) 711 | (cond ((char= (peek-char nil stream t nil t) #\=) 712 | (read-char stream t nil t) 713 | '==) 714 | (t 715 | '=)))) 716 | (define-token-operator == 717 | :infix `(= ,left ,(gather-superiors '== stream))) 718 | (define-token-operator = 719 | :infix `(,(if (symbolp left) 720 | 'setq 721 | 'setf) 722 | ,left 723 | ,(gather-superiors '= stream))) 724 | 725 | (define-character-tokenization #\: 726 | #'(lambda (stream char) 727 | (declare (ignore char)) 728 | (cond ((char= (peek-char nil stream t nil t) #\=) 729 | (read-char stream t nil t) 730 | '|:=|) 731 | (t 732 | '|:|)))) 733 | (define-token-operator |:=| 734 | :infix `(,(if (symbolp left) 735 | 'setq 736 | 'setf) 737 | ,left 738 | ,(gather-superiors '|:=| stream))) 739 | 740 | (define-character-tokenization #\< 741 | #'(lambda (stream char) 742 | (declare (ignore char)) 743 | (cond ((char= (peek-char nil stream t nil t) #\=) 744 | (read-char stream t nil t) 745 | '<=) 746 | ((char= (peek-char nil stream t nil t) #\<) 747 | (read-char stream t nil t) 748 | '<<) 749 | (t 750 | '<)))) 751 | (define-token-operator < 752 | :infix `(< ,left ,(gather-superiors '< stream))) 753 | (define-token-operator <= 754 | :infix `(<= ,left ,(gather-superiors '<= stream))) 755 | (define-token-operator << 756 | :infix `(ash ,left ,(gather-superiors '<< stream))) 757 | 758 | (define-character-tokenization #\> 759 | #'(lambda (stream char) 760 | (declare (ignore char)) 761 | (cond ((char= (peek-char nil stream t nil t) #\=) 762 | (read-char stream t nil t) 763 | '>=) 764 | ((char= (peek-char nil stream t nil t) #\>) 765 | (read-char stream t nil t) 766 | '>>) 767 | (t 768 | '>)))) 769 | (define-token-operator > 770 | :infix `(> ,left ,(gather-superiors '> stream))) 771 | (define-token-operator >= 772 | :infix `(>= ,left ,(gather-superiors '>= stream))) 773 | (define-token-operator >> 774 | :infix `(ash ,left (- ,(gather-superiors '>> stream)))) 775 | 776 | (define-character-tokenization #\! 777 | #'(lambda (stream char) 778 | (declare (ignore char)) 779 | (cond ((char= (peek-char nil stream t nil t) #\=) 780 | (read-char stream t nil t) 781 | '!=) 782 | (t 783 | '!)))) 784 | (define-token-operator != 785 | :infix `(not (= ,left ,(gather-superiors '!= stream)))) 786 | (define-token-operator ! 787 | :prefix (read-regular stream)) 788 | 789 | (define-character-tokenization #\[ 790 | #'(lambda (stream char) 791 | (declare (ignore stream char)) 792 | '\[)) 793 | (define-token-operator \[ 794 | :infix (let ((indices (infix-read-delimited-list '\] '\, stream))) 795 | (if (null indices) 796 | (infix-error "No indices found in array reference.") 797 | `(aref ,left ,@indices)))) 798 | 799 | (define-character-tokenization #\( 800 | #'(lambda (stream char) 801 | (declare (ignore stream char)) 802 | '\()) 803 | (define-token-operator \( 804 | :infix `(,left ,@(infix-read-delimited-list '\) '\, stream)) 805 | :prefix (let ((list (infix-read-delimited-list '\) '\, stream))) 806 | (if (null (rest list)) 807 | ;; only one element in list. works correctly if list is NIL 808 | (first list) 809 | ;; several elements in list 810 | `(progn ,@list)))) 811 | 812 | (define-character-tokenization #\] 813 | #'(lambda (stream char) 814 | (declare (ignore stream char)) 815 | '\])) 816 | (define-token-operator \] 817 | :infix (infix-error "Extra close brace \"]\" in infix expression")) 818 | 819 | (define-character-tokenization #\) 820 | #'(lambda (stream char) 821 | (declare (ignore stream char)) 822 | '\))) 823 | (define-token-operator \) 824 | :infix (infix-error "Extra close paren \")\" in infix expression")) 825 | 826 | #| 827 | ;;; Commented out because no longer using $ as the macro character. 828 | (define-character-tokenization #\$ 829 | #'(lambda (stream char) 830 | (declare (ignore stream char)) 831 | '%infix-end-token%)) 832 | (define-token-operator %infix-end-token% 833 | :infix (infix-error "Prematurely terminated infix expression") 834 | :prefix (infix-error "Prematurely terminated infix expression")) 835 | |# 836 | 837 | (define-character-tokenization #\; 838 | #'(lambda (stream char) 839 | (declare (ignore char)) 840 | (do ((char (peek-char nil stream t nil t) 841 | (peek-char nil stream t nil t))) 842 | ((or (char= char #\newline) (char= char #\return) 843 | ;; was #\$ 844 | ; (char= char #\)) 845 | ) 846 | ;; Gobble characters until the end of the line or the 847 | ;; end of the input. 848 | (cond ((or (char= char #\newline) (char= char #\return)) 849 | (read-char stream) 850 | (read stream t nil t)) 851 | (t 852 | ;; i.e., return %infix-end-token% 853 | (read stream t nil t)))) 854 | (read-char stream)))) 855 | 856 | 857 | ;;; ******************************** 858 | ;;; Syntactic Modifications ******** 859 | ;;; ******************************** 860 | 861 | ;;; Post processes the expression to remove some unsightliness caused 862 | ;;; by the way infix processes the input. Note that it is also required 863 | ;;; for correctness in the a <= >= progn) 872 | :test #'same-operator-p)) 873 | ;; Flatten the expression if possible 874 | (cond ((and (eq operator '-) 875 | (= (length left) 2)) 876 | ;; -a-b --> (+ (- a) (- b)). 877 | `(+ ,left (- ,right))) 878 | ((and (eq operator '/) 879 | (= (length left) 2)) 880 | ;; ditto with / 881 | `(/ (* ,(second left) ,right))) 882 | (t 883 | ;; merges a+b+c as (+ a b c). 884 | (append left (list right))))) 885 | ((and (consp left) 886 | (eq operator '-) 887 | (eq (first left) '+)) 888 | ;; merges a+b-c as (+ a b (- c)). 889 | (append left (list `(- ,right)))) 890 | ((and (consp left) 891 | (find operator '(< > <= >=)) 892 | (find (first left) '(< > <= >=))) 893 | ;; a a>b" (ash a (- b))) 1036 | ("~a" (lognot a)) 1037 | ("a&&b" (and a b)) 1038 | ("a||b" (or a b)) 1039 | ("a%b" (mod a b)) 1040 | 1041 | ;; Comment character -- must have carriage return after semicolon. 1042 | ("x^^2 ; the x coordinate 1043 | + y^^2 ; the y coordinate" :error) 1044 | ("x^^2 ; the x coordinate 1045 | + y^^2 ; the y coordinate 1046 | " (+ (expt x 2) (expt y 2))) 1047 | 1048 | ;; Errors 1049 | ("foo(bar,baz" :error) ; premature termination 1050 | ;; The following no longer gives an error 1051 | ("foo(bar,baz))" (foo bar baz)) ; extra close parenthesis 1052 | ("foo[bar,baz]]" :error) ; extra close bracket 1053 | ("[foo,bar]" :error) ; AREF is not a prefix operator 1054 | ("and a" :error) ; AND is not a prefix operator 1055 | ("< a" :error) ; < is not a prefix operator 1056 | ("=bar" :error) ; SETF is not a prefix operator 1057 | ("*bar" :error) ; * is not a prefix operator 1058 | ("a not b" :error) ; NOT is not an infix operator 1059 | ("a if b then c" :error) ; IF is not an infix operator 1060 | ("" :error) ; premature termination (empty clause) 1061 | (")a" :error) ; left parent is not a prefix operator 1062 | ("]a" :error) ; left bracket is not a prefix operator 1063 | )) 1064 | 1065 | (defun test-infix (&optional (tests *test-cases*)) 1066 | (let ((count 0)) 1067 | (dolist (test tests) 1068 | (destructuring-bind (string result) test 1069 | (unless (test-infix-case string result) 1070 | (incf count)))) 1071 | (format t "~&~:(~R~) test~p failed." count count) 1072 | (values))) 1073 | 1074 | (defun test-infix-case (string result) 1075 | (multiple-value-bind (value error) 1076 | (let ((*package* (find-package "INFIX"))) 1077 | (ignore-errors 1078 | (values (read-from-string (concatenate 'string "#I(" string ")") 1079 | t nil)))) 1080 | (cond (error 1081 | (cond ((eq result :error) 1082 | t) 1083 | (t 1084 | (format t "~&Test #I(~A) failed with ERROR." string) 1085 | nil))) 1086 | ((eq result :error) 1087 | (format t "~&Test #I(~A) failed. ~ 1088 | ~& Expected ERROR ~ 1089 | ~& but got ~A." 1090 | string value) 1091 | nil) 1092 | ((not (equal value result)) 1093 | (format t "~&Test #I(~A) failed. ~ 1094 | ~& Expected ~A ~ 1095 | ~& but got ~A." 1096 | string result value) 1097 | nil) 1098 | (t 1099 | t)))) 1100 | 1101 | ;;; *EOF* 1102 | -------------------------------------------------------------------------------- /cmu-infix-tests.asd: -------------------------------------------------------------------------------- 1 | ;;;; cmu-infix-tests.asd 2 | 3 | (asdf:defsystem #:cmu-infix-tests 4 | :description "Tests for the system CMU-INFIX." 5 | :author "Mark Kantrowitz" 6 | :maintainer "Robert Smith " 7 | :license "Custom (See LICENSE.txt)" 8 | :depends-on (#:cmu-infix 9 | #:fiasco 10 | #:uiop) 11 | :perform (asdf:test-op (o s) 12 | (uiop:symbol-call :cmu-infix-tests 13 | '#:run-tests)) 14 | :pathname "tests/" 15 | :serial t 16 | :components ((:file "package") 17 | (:file "tests"))) 18 | 19 | -------------------------------------------------------------------------------- /cmu-infix.asd: -------------------------------------------------------------------------------- 1 | ;;;; cmu-infix.asd 2 | 3 | (asdf:defsystem #:cmu-infix 4 | :description "Mathematical infix notation for Common Lisp." 5 | :author "Mark Kantrowitz" 6 | :maintainer "Robert Smith " 7 | :license "Custom (See LICENSE.txt)" 8 | :in-order-to ((asdf:test-op (asdf:test-op #:cmu-infix-tests))) 9 | :depends-on (#:named-readtables) 10 | :pathname "src/" 11 | :serial t 12 | :components ((:file "package") 13 | (:file "cmu-infix"))) 14 | -------------------------------------------------------------------------------- /src/cmu-infix.lisp: -------------------------------------------------------------------------------- 1 | ;;; src/cmu-infix.lisp 2 | 3 | (in-package #:cmu-infix) 4 | 5 | ;;; This is an implementation of an infix reader macro. It should run 6 | ;;; in any valid Common Lisp. It allows the user to type arithmetic 7 | ;;; expressions in the traditional way (e.g., 1+2) when writing Lisp 8 | ;;; programs instead of using the normal Lisp syntax (e.g., (+ 1 2)). 9 | ;;; It is not intended to be a full replacement for the normal Lisp 10 | ;;; syntax. If you want a more complete alternate syntax for Lisp, get 11 | ;;; a copy Apple's MLisp or Pratt's CGOL. 12 | ;;; 13 | ;;; Although similar in concept to the Symbolics infix reader 14 | ;;; (#), no real effort has been made to ensure compatibility 15 | ;;; beyond coverage of at least the same set of basic arithmetic 16 | ;;; operators. There are several differences in the syntax beyond just 17 | ;;; the choice of #I as the macro character. (Our syntax is a little 18 | ;;; bit more C-like than the Symbolics macro in addition to some more 19 | ;;; subtle differences.) 20 | ;;; 21 | ;;; We initially chose $ as a macro character because of its 22 | ;;; association with mathematics in LaTeX, but unfortunately that 23 | ;;; character is already used in MCL. We switched to #I() because it 24 | ;;; was one of the few options remaining. 25 | 26 | 27 | ;;; ******************************** 28 | ;;; Documentation ****************** 29 | ;;; ******************************** 30 | ;;; 31 | ;;; Syntax: 32 | ;;; 33 | ;;; Begin the reader macro with #I( and end it with ). For example, 34 | ;;; #I( x^^2 + y^^2 ) 35 | ;;; is equivalent to the Lisp form 36 | ;;; (+ (expt x 2) (expt y 2)) 37 | ;;; but much easier to read according to some folks. 38 | ;;; 39 | ;;; If you want to see the expansion, type a quote before the #I form 40 | ;;; at the Lisp prompt: 41 | ;;; > '#I(if xprefix (read stream t nil t))) 149 | ((char= first-char #\() 150 | (read-char stream) ; get rid of opening left parenthesis 151 | (let ((*readtable* *infix-readtable*) 152 | (*normal-readtable* *readtable*)) 153 | (read-infix stream))) 154 | (t 155 | (infix-error "Infix expression starts with ~A" first-char))))) 156 | 157 | (defun string->prefix (string) 158 | "Convert a string to a prefix s-expression using the infix reader. 159 | If the argument is not a string, just return it as is." 160 | (if (stringp string) 161 | (with-input-from-string (stream (concatenate 'string "#I(" string ")")) 162 | (read stream)) 163 | string)) 164 | 165 | (defun read-infix (stream) 166 | (let* ((result (gather-superiors '\) stream)) ; %infix-end-token% 167 | (next-token (read-token stream))) 168 | (unless (same-token-p next-token '\)) ; %infix-end-token% 169 | (infix-error "Infix expression ends with ~A." next-token)) 170 | result)) 171 | 172 | (defun read-regular (stream) 173 | (let ((*readtable* *normal-readtable*)) 174 | (read stream t nil t))) 175 | 176 | 177 | ;;; ******************************** 178 | ;;; Reader Code ******************** 179 | ;;; ******************************** 180 | 181 | (defun same-operator-p (x y) 182 | (same-token-p x y)) 183 | 184 | (defun same-token-p (x y) 185 | (and (symbolp x) 186 | (symbolp y) 187 | (string-equal (symbol-name x) (symbol-name y)))) 188 | 189 | ;;; Peeking Token Reader 190 | 191 | (defvar *peeked-token* nil) 192 | (defun read-token (stream) 193 | (if *peeked-token* 194 | (pop *peeked-token*) 195 | (read stream t nil t))) 196 | (defun peek-token (stream) 197 | (unless *peeked-token* 198 | (push (read stream t nil t) *peeked-token*)) 199 | (car *peeked-token*)) 200 | 201 | ;;; Hack to work around + and - being terminating macro characters, 202 | ;;; so 1e-3 doesn't normally work correctly. 203 | 204 | (defun fancy-number-format-p (left operator stream) 205 | (when (and (symbolp left) 206 | (find operator '(+ -) :test #'same-operator-p)) 207 | (let* ((name (symbol-name left)) 208 | (length (length name))) 209 | (when (and (valid-numberp (subseq name 0 (1- length))) 210 | ;; Exponent, Single, Double, Float, or Long 211 | (find (subseq name (1- length)) 212 | '("e" "s" "d" "f" "l") 213 | :test #'string-equal)) 214 | (read-token stream) 215 | (let ((right (peek-token stream))) 216 | (cond ((integerp right) 217 | ;; it is one of the fancy numbers, so return it 218 | (read-token stream) 219 | (let ((*readtable* *normal-readtable*)) 220 | (read-from-string (format nil "~A~A~A" 221 | left operator right)))) 222 | (t 223 | ;; it isn't one of the fancy numbers, so unread the token 224 | (push operator *peeked-token*) 225 | ;; and return nil 226 | nil))))))) 227 | 228 | (defun valid-numberp (string) 229 | (let ((saw-dot nil)) 230 | (dolist (char (coerce string 'list) t) 231 | (cond ((char= char #\.) 232 | (if saw-dot 233 | (return nil) 234 | (setq saw-dot t))) 235 | ((not (find char "01234567890" :test #'char=)) 236 | (return nil)))))) 237 | 238 | ;;; Gobbles an expression from the stream. 239 | 240 | (defun gather-superiors (previous-operator stream) 241 | "Gathers an expression whose operators all exceed the precedence of 242 | the operator to the left." 243 | (let ((left (get-first-token stream))) 244 | (loop 245 | (setq left (post-process-expression left)) 246 | (let ((peeked-token (peek-token stream))) 247 | (let ((fancy-p (fancy-number-format-p left peeked-token stream))) 248 | (when fancy-p 249 | ;; i.e., we've got a number like 1e-3 or 1e+3 or 1f-1 250 | (setq left fancy-p 251 | peeked-token (peek-token stream)))) 252 | (unless (or (operator-lessp previous-operator peeked-token) 253 | (and (same-operator-p peeked-token previous-operator) 254 | (operator-right-associative-p previous-operator))) 255 | ;; The loop should continue when the peeked operator is 256 | ;; either superior in precedence to the previous operator, 257 | ;; or the same operator and right-associative. 258 | (return left))) 259 | (setq left (get-next-token stream left))))) 260 | 261 | (defun get-first-token (stream) 262 | (let ((token (read-token stream))) 263 | (if (token-operator-p token) 264 | ;; It's an operator in a prefix context. 265 | (apply-token-prefix-operator token stream) 266 | ;; It's a regular token 267 | token))) 268 | 269 | (defun apply-token-prefix-operator (token stream) 270 | (let ((operator (get-token-prefix-operator token))) 271 | (if operator 272 | (funcall operator stream) 273 | (infix-error "~A is not a prefix operator" token)))) 274 | 275 | (defun get-next-token (stream left) 276 | (let ((token (read-token stream))) 277 | (apply-token-infix-operator token left stream))) 278 | 279 | (defun apply-token-infix-operator (token left stream) 280 | (let ((operator (get-token-infix-operator token))) 281 | (if operator 282 | (funcall operator stream left) 283 | (infix-error "~A is not an infix operator" token)))) 284 | 285 | ;;; Fix to read-delimited-list so that it works with tokens, not 286 | ;;; characters. 287 | 288 | (defun infix-read-delimited-list (end-token delimiter-token stream) 289 | (do ((next-token (peek-token stream) (peek-token stream)) 290 | (list nil)) 291 | ((same-token-p next-token end-token) 292 | ;; We've hit the end. Remove the end-token from the stream. 293 | (read-token stream) 294 | ;; and return the list of tokens. 295 | ;; Note that this does the right thing with [] and (). 296 | (nreverse list)) 297 | ;; Ignore the delimiters. 298 | (when (same-token-p next-token delimiter-token) 299 | (read-token stream)) 300 | ;; Gather the expression until the next delimiter. 301 | (push (gather-superiors delimiter-token stream) list))) 302 | 303 | 304 | ;;; ******************************** 305 | ;;; Precedence ********************* 306 | ;;; ******************************** 307 | 308 | (defparameter *operator-ordering* 309 | '(( \[ \( \! ) ; \[ is array reference 310 | ( ^^ ) ; exponentiation 311 | ( ~ ) ; lognot 312 | ( * / % ) ; % is mod 313 | ( + - ) 314 | ( << >> ) 315 | ( < == > <= != >= ) 316 | ( & ) ; logand 317 | ( ^ ) ; logxor 318 | ( \| ) ; logior 319 | ( not ) 320 | ( and ) 321 | ( or ) 322 | ;; Where should setf and friends go in the precedence? 323 | ( = |:=| += -= *= /= ) 324 | ( \, ) ; progn (statement delimiter) 325 | ( if ) 326 | ( then else ) 327 | ( \] \) ) 328 | ( %infix-end-token% )) ; end of infix expression 329 | "Ordered list of operators of equal precedence.") 330 | 331 | (defun operator-lessp (op1 op2) 332 | (dolist (ops *operator-ordering* nil) 333 | (cond ((find op1 ops :test #'same-token-p) 334 | (return nil)) 335 | ((find op2 ops :test #'same-token-p) 336 | (return t))))) 337 | 338 | (defparameter *right-associative-operators* '(^^ =)) 339 | (defun operator-right-associative-p (operator) 340 | (find operator *right-associative-operators*)) 341 | 342 | 343 | ;;; ******************************** 344 | ;;; Define Operators *************** 345 | ;;; ******************************** 346 | 347 | (defvar *token-operators* nil) 348 | (defvar *token-prefix-operator-table* (make-hash-table)) 349 | (defvar *token-infix-operator-table* (make-hash-table)) 350 | (defun token-operator-p (token) 351 | (find token *token-operators*)) 352 | (defun get-token-prefix-operator (token) 353 | (gethash token *token-prefix-operator-table*)) 354 | (defun get-token-infix-operator (token) 355 | (gethash token *token-infix-operator-table*)) 356 | 357 | (eval-when (:compile-toplevel :load-toplevel :execute) 358 | (defmacro define-token-operator (operator-name &key 359 | (prefix nil prefix-p) 360 | (infix nil infix-p)) 361 | `(progn 362 | (pushnew ',operator-name *token-operators*) 363 | ,(when prefix-p 364 | `(setf (gethash ',operator-name *token-prefix-operator-table*) 365 | #'(lambda (stream) 366 | ,@(cond ((and (consp prefix) 367 | (eq (car prefix) 'infix-error)) 368 | ;; To avoid ugly compiler warnings. 369 | `((declare (ignore stream)) 370 | ,prefix)) 371 | (t 372 | (list prefix)))))) 373 | ,(when infix-p 374 | `(setf (gethash ',operator-name *token-infix-operator-table*) 375 | #'(lambda (stream left) 376 | ,@(cond ((and (consp infix) 377 | (eq (car infix) 'infix-error)) 378 | ;; To avoid ugly compiler warnings. 379 | `((declare (ignore stream left)) 380 | ,infix)) 381 | (t 382 | (list infix))))))))) 383 | 384 | ;;; Readtable definitions for characters, so that the right token is returned. 385 | (eval-when (:compile-toplevel :load-toplevel :execute) 386 | (defmacro define-character-tokenization (char function) 387 | `(set-macro-character ,char ,function nil *infix-readtable*))) 388 | 389 | 390 | ;;; ******************************** 391 | ;;; Operator Definitions *********** 392 | ;;; ******************************** 393 | 394 | (define-token-operator and 395 | :infix `(and ,left ,(gather-superiors 'and stream))) 396 | (define-token-operator or 397 | :infix `(or ,left ,(gather-superiors 'or stream))) 398 | (define-token-operator not 399 | :prefix `(not ,(gather-superiors 'not stream))) 400 | 401 | (define-token-operator if 402 | :prefix (let* ((test (gather-superiors 'if stream)) 403 | (then (cond ((same-token-p (peek-token stream) 'then) 404 | (read-token stream) 405 | (gather-superiors 'then stream)) 406 | (t 407 | (infix-error "Missing THEN clause.")))) 408 | (else (when (same-token-p (peek-token stream) 'else) 409 | (read-token stream) 410 | (gather-superiors 'else stream)))) 411 | (cond ((and test then else) 412 | `(if ,test ,then ,else)) 413 | ((and test then) 414 | ;; no else clause 415 | `(when ,test ,then)) 416 | ((and test else) 417 | ;; no then clause 418 | `(unless ,test ,else)) 419 | (t 420 | ;; no then and else clauses --> always NIL 421 | nil)))) 422 | 423 | (define-token-operator then 424 | :prefix (infix-error "THEN clause without an IF.")) 425 | (define-token-operator else 426 | :prefix (infix-error "ELSE clause without an IF.")) 427 | 428 | (define-character-tokenization #\+ 429 | #'(lambda (stream char) 430 | (declare (ignore char)) 431 | (cond ((char= (peek-char nil stream t nil t) #\=) 432 | (read-char stream t nil t) 433 | '+=) 434 | (t 435 | '+)))) 436 | (define-token-operator + 437 | :infix `(+ ,left ,(gather-superiors '+ stream)) 438 | :prefix (gather-superiors '+ stream)) 439 | (define-token-operator += 440 | :infix `(incf ,left ,(gather-superiors '+= stream))) 441 | 442 | (define-character-tokenization #\- 443 | #'(lambda (stream char) 444 | (declare (ignore char)) 445 | (cond ((char= (peek-char nil stream t nil t) #\=) 446 | (read-char stream t nil t) 447 | '-=) 448 | (t 449 | '-)))) 450 | (define-token-operator - 451 | :infix `(- ,left ,(gather-superiors '- stream)) 452 | :prefix `(- ,(gather-superiors '- stream))) 453 | (define-token-operator -= 454 | :infix `(decf ,left ,(gather-superiors '-= stream))) 455 | 456 | (define-character-tokenization #\* 457 | #'(lambda (stream char) 458 | (declare (ignore char)) 459 | (cond ((char= (peek-char nil stream t nil t) #\=) 460 | (read-char stream t nil t) 461 | '*=) 462 | (t 463 | '*)))) 464 | (define-token-operator * 465 | :infix `(* ,left ,(gather-superiors '* stream))) 466 | (define-token-operator *= 467 | :infix `(,(if (symbolp left) 468 | 'setq 469 | 'setf) 470 | ,left 471 | (* ,left ,(gather-superiors '*= stream)))) 472 | 473 | (define-character-tokenization #\/ 474 | #'(lambda (stream char) 475 | (declare (ignore char)) 476 | (cond ((char= (peek-char nil stream t nil t) #\=) 477 | (read-char stream t nil t) 478 | '/=) 479 | (t 480 | '/)))) 481 | (define-token-operator / 482 | :infix `(/ ,left ,(gather-superiors '/ stream)) 483 | :prefix `(/ ,(gather-superiors '/ stream))) 484 | (define-token-operator /= 485 | :infix `(,(if (symbolp left) 486 | 'setq 487 | 'setf) 488 | ,left 489 | (/ ,left ,(gather-superiors '/= stream)))) 490 | 491 | (define-character-tokenization #\^ 492 | #'(lambda (stream char) 493 | (declare (ignore char)) 494 | (cond ((char= (peek-char nil stream t nil t) #\^) 495 | (read-char stream t nil t) 496 | '^^) 497 | (t 498 | '^)))) 499 | (define-token-operator ^^ 500 | :infix `(expt ,left ,(gather-superiors '^^ stream))) 501 | (define-token-operator ^ 502 | :infix `(logxor ,left ,(gather-superiors '^ stream))) 503 | 504 | (define-character-tokenization #\| 505 | #'(lambda (stream char) 506 | (declare (ignore char)) 507 | (cond ((char= (peek-char nil stream t nil t) #\|) 508 | (read-char stream t nil t) 509 | 'or) 510 | (t 511 | '\|)))) 512 | (define-token-operator \| 513 | :infix `(logior ,left ,(gather-superiors '\| stream))) 514 | 515 | (define-character-tokenization #\& 516 | #'(lambda (stream char) 517 | (declare (ignore char)) 518 | (cond ((char= (peek-char nil stream t nil t) #\&) 519 | (read-char stream t nil t) 520 | 'and) 521 | (t 522 | '\&)))) 523 | (define-token-operator \& 524 | :infix `(logand ,left ,(gather-superiors '\& stream))) 525 | 526 | (define-character-tokenization #\% 527 | #'(lambda (stream char) 528 | (declare (ignore stream char)) 529 | '\%)) 530 | (define-token-operator \% 531 | :infix `(mod ,left ,(gather-superiors '\% stream))) 532 | 533 | (define-character-tokenization #\~ 534 | #'(lambda (stream char) 535 | (declare (ignore stream char)) 536 | '\~)) 537 | (define-token-operator \~ 538 | :prefix `(lognot ,(gather-superiors '\~ stream))) 539 | 540 | (define-character-tokenization #\, 541 | #'(lambda (stream char) 542 | (declare (ignore stream char)) 543 | '\,)) 544 | (define-token-operator \, 545 | :infix `(progn ,left ,(gather-superiors '\, stream))) 546 | 547 | (define-character-tokenization #\= 548 | #'(lambda (stream char) 549 | (declare (ignore char)) 550 | (cond ((char= (peek-char nil stream t nil t) #\=) 551 | (read-char stream t nil t) 552 | '==) 553 | (t 554 | '=)))) 555 | (define-token-operator == 556 | :infix `(= ,left ,(gather-superiors '== stream))) 557 | (define-token-operator = 558 | :infix `(,(if (symbolp left) 559 | 'setq 560 | 'setf) 561 | ,left 562 | ,(gather-superiors '= stream))) 563 | 564 | (define-character-tokenization #\: 565 | #'(lambda (stream char) 566 | (declare (ignore char)) 567 | (cond ((char= (peek-char nil stream t nil t) #\=) 568 | (read-char stream t nil t) 569 | '|:=|) 570 | (t 571 | '|:|)))) 572 | (define-token-operator |:=| 573 | :infix `(,(if (symbolp left) 574 | 'setq 575 | 'setf) 576 | ,left 577 | ,(gather-superiors '|:=| stream))) 578 | 579 | (define-character-tokenization #\< 580 | #'(lambda (stream char) 581 | (declare (ignore char)) 582 | (cond ((char= (peek-char nil stream t nil t) #\=) 583 | (read-char stream t nil t) 584 | '<=) 585 | ((char= (peek-char nil stream t nil t) #\<) 586 | (read-char stream t nil t) 587 | '<<) 588 | (t 589 | '<)))) 590 | (define-token-operator < 591 | :infix `(< ,left ,(gather-superiors '< stream))) 592 | (define-token-operator <= 593 | :infix `(<= ,left ,(gather-superiors '<= stream))) 594 | (define-token-operator << 595 | :infix `(ash ,left ,(gather-superiors '<< stream))) 596 | 597 | (define-character-tokenization #\> 598 | #'(lambda (stream char) 599 | (declare (ignore char)) 600 | (cond ((char= (peek-char nil stream t nil t) #\=) 601 | (read-char stream t nil t) 602 | '>=) 603 | ((char= (peek-char nil stream t nil t) #\>) 604 | (read-char stream t nil t) 605 | '>>) 606 | (t 607 | '>)))) 608 | (define-token-operator > 609 | :infix `(> ,left ,(gather-superiors '> stream))) 610 | (define-token-operator >= 611 | :infix `(>= ,left ,(gather-superiors '>= stream))) 612 | (define-token-operator >> 613 | :infix `(ash ,left (- ,(gather-superiors '>> stream)))) 614 | 615 | (define-character-tokenization #\! 616 | #'(lambda (stream char) 617 | (declare (ignore char)) 618 | (cond ((char= (peek-char nil stream t nil t) #\=) 619 | (read-char stream t nil t) 620 | '!=) 621 | (t 622 | '!)))) 623 | (define-token-operator != 624 | :infix `(not (= ,left ,(gather-superiors '!= stream)))) 625 | (define-token-operator ! 626 | :prefix (read-regular stream)) 627 | 628 | (define-character-tokenization #\[ 629 | #'(lambda (stream char) 630 | (declare (ignore stream char)) 631 | '\[)) 632 | (define-token-operator \[ 633 | :infix (let ((indices (infix-read-delimited-list '\] '\, stream))) 634 | (if (null indices) 635 | (infix-error "No indices found in array reference.") 636 | `(aref ,left ,@indices)))) 637 | 638 | (define-character-tokenization #\( 639 | #'(lambda (stream char) 640 | (declare (ignore stream char)) 641 | '\()) 642 | (define-token-operator \( 643 | :infix `(,left ,@(infix-read-delimited-list '\) '\, stream)) 644 | :prefix (let ((list (infix-read-delimited-list '\) '\, stream))) 645 | (if (null (rest list)) 646 | ;; only one element in list. works correctly if list is NIL 647 | (first list) 648 | ;; several elements in list 649 | `(progn ,@list)))) 650 | 651 | (define-character-tokenization #\] 652 | #'(lambda (stream char) 653 | (declare (ignore stream char)) 654 | '\])) 655 | (define-token-operator \] 656 | :infix (infix-error "Extra close brace \"]\" in infix expression")) 657 | 658 | (define-character-tokenization #\) 659 | #'(lambda (stream char) 660 | (declare (ignore stream char)) 661 | '\))) 662 | (define-token-operator \) 663 | :infix (infix-error "Extra close paren \")\" in infix expression")) 664 | 665 | #| 666 | ;;; Commented out because no longer using $ as the macro character. 667 | (define-character-tokenization #\$ 668 | #'(lambda (stream char) 669 | (declare (ignore stream char)) 670 | '%infix-end-token%)) 671 | (define-token-operator %infix-end-token% 672 | :infix (infix-error "Prematurely terminated infix expression") 673 | :prefix (infix-error "Prematurely terminated infix expression")) 674 | |# 675 | 676 | (define-character-tokenization #\; 677 | #'(lambda (stream char) 678 | (declare (ignore char)) 679 | (do ((char (peek-char nil stream t nil t) 680 | (peek-char nil stream t nil t))) 681 | ((or (char= char #\newline) (char= char #\return) 682 | ;; was #\$ 683 | ;; (char= char #\)) 684 | ) 685 | ;; Gobble characters until the end of the line or the 686 | ;; end of the input. 687 | (cond ((or (char= char #\newline) (char= char #\return)) 688 | (read-char stream) 689 | (read stream t nil t)) 690 | (t 691 | ;; i.e., return %infix-end-token% 692 | (read stream t nil t)))) 693 | (read-char stream)))) 694 | 695 | 696 | ;;; ******************************** 697 | ;;; Syntactic Modifications ******** 698 | ;;; ******************************** 699 | 700 | ;;; Post processes the expression to remove some unsightliness caused 701 | ;;; by the way infix processes the input. Note that it is also required 702 | ;;; for correctness in the a <= >= progn) 711 | :test #'same-operator-p)) 712 | ;; Flatten the expression if possible 713 | (cond ((and (eq operator '-) 714 | (= (length left) 2)) 715 | ;; -a-b --> (+ (- a) (- b)). 716 | `(+ ,left (- ,right))) 717 | ((and (eq operator '/) 718 | (= (length left) 2)) 719 | ;; ditto with / 720 | `(/ (* ,(second left) ,right))) 721 | (t 722 | ;; merges a+b+c as (+ a b c). 723 | (append left (list right))))) 724 | ((and (consp left) 725 | (eq operator '-) 726 | (eq (first left) '+)) 727 | ;; merges a+b-c as (+ a b (- c)). 728 | (append left (list `(- ,right)))) 729 | ((and (consp left) 730 | (find operator '(< > <= >=)) 731 | (find (first left) '(< > <= >=))) 732 | ;; a aprefix ; FUNCTION 9 | ) 10 | (:documentation 11 | "Package holding the readtable designator for mathematical infix notation. 12 | 13 | The following two tables enumerate the supported operators along with 14 | their precedence. 15 | 16 | Operators: 17 | 18 | NOTE: == is equality, = is assignment (C-style). 19 | 20 | \\ quoting character: x\\-y --> x-y 21 | ! lisp escape !(foo bar) --> (foo bar) 22 | ; comment 23 | x = y assignment (setf x y) 24 | x += y increment (incf x y) 25 | x -= y decrement (decf x y) 26 | x *= y multiply and store (setf x (* x y)) 27 | x /= y divide and store (setf x (/ x y)) 28 | x|y bitwise logical inclusive or (logior x y) 29 | x^y bitwise logical exclusive or (logxor x y) 30 | x&y bitwise logical and (logand x y) 31 | x<>y right shift (ash x (- y)) 33 | ~x ones complement (unary) (lognot x) 34 | x and y conjunction (and x y) 35 | x && y conjunction (and x y) 36 | x or y disjunction (or x y) 37 | x || y disjunction (or x y) 38 | not x negation (not x) 39 | x^^y exponentiation (expt x y) 40 | x,y sequence (progn x y) 41 | (x,y) sequence (progn x y) 42 | also parenthesis (x+y)/z --> (/ (+ x y) z) 43 | f(x,y) functions (f x y) 44 | a[i,j] array reference (aref a i j) 45 | x+y x*y arithmetic (+ x y) (* x y) 46 | x-y x/y arithmetic (- x y) (/ x y) 47 | -y value negation (- y) 48 | x % y remainder (mod x y) 49 | xy inequalities (< x y) (> x y) 50 | x <= y x >= y inequalities (<= x y) (>= x y) 51 | x == y equality (= x y) 52 | x != y equality (not (= x y)) 53 | if p then q conditional (when p q) 54 | if p then q else r conditional (if p q r) 55 | 56 | 57 | Precedence: 58 | 59 | The following precedence conventions are obeyed by the infix operators: 60 | [ ( ! 61 | ^^ 62 | ~ 63 | * / % 64 | + - 65 | << >> 66 | < == > <= != >= 67 | & 68 | ^ 69 | | 70 | not 71 | and 72 | or 73 | = += -= *= /= 74 | , 75 | if 76 | then else 77 | ] ) 78 | 79 | Note that logical negation has lower precedence than numeric comparison 80 | so that \"not a>b" (ash a (- b))) 147 | ("~a" (lognot a)) 148 | ("a&&b" (and a b)) 149 | ("a||b" (or a b)) 150 | ("a%b" (mod a b)) 151 | 152 | ;; Comment character -- must have carriage return after semicolon. 153 | ("x^^2 ; the x coordinate 154 | + y^^2 ; the y coordinate" :error) 155 | ("x^^2 ; the x coordinate 156 | + y^^2 ; the y coordinate 157 | " (+ (expt x 2) (expt y 2))) 158 | 159 | ;; Errors 160 | ("foo(bar,baz" :error) ; premature termination 161 | ;; The following no longer gives an error 162 | ("foo(bar,baz))" (foo bar baz)) ; extra close parenthesis 163 | ("foo[bar,baz]]" :error) ; extra close bracket 164 | ("[foo,bar]" :error) ; AREF is not a prefix operator 165 | ("and a" :error) ; AND is not a prefix operator 166 | ("< a" :error) ; < is not a prefix operator 167 | ("=bar" :error) ; SETF is not a prefix operator 168 | ("*bar" :error) ; * is not a prefix operator 169 | ("a not b" :error) ; NOT is not an infix operator 170 | ("a if b then c" :error) ; IF is not an infix operator 171 | ("" :error) ; premature termination (empty clause) 172 | (")a" :error) ; left parent is not a prefix operator 173 | ("]a" :error) ; left bracket is not a prefix operator 174 | )) 175 | 176 | (deftest test-infix (&optional (tests *test-cases*)) 177 | (let ((count 0)) 178 | (dolist (test tests) 179 | (destructuring-bind (string result) test 180 | (unless (test-infix-case string result) 181 | (incf count)))) 182 | (format t "~&~:(~R~) test~p failed." count count) 183 | (values))) 184 | 185 | (defun test-infix-case (string result) 186 | (let ((specimen (concatenate 'string "#I(" string ")")) 187 | (*readtable* (named-readtables:find-readtable 'cmu-infix:syntax))) 188 | (if (eql result ':error) 189 | (signals error (read-from-string specimen)) 190 | (is (equal result (read-from-string specimen)))))) 191 | --------------------------------------------------------------------------------