close Warning: Can't synchronize with repository "(default)" (The repository directory has changed, you should resynchronize the repository with: trac-admin $ENV repository resync '(default)'). Look in the Trac log for more information.

source: branches/f4grobner/infix.lisp@ 1324

Last change on this file since 1324 was 677, checked in by Marek Rychlik, 9 years ago

* empty log message *

File size: 40.3 KB
Line 
1;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: Grobner; Base: 10 -*-
2;;; ****************************************************************
3;;; CHANGE LOG:
4;;; * (1997/12/6) Fixed code for valid-numberp, so that "" is no longer
5;;; recognized as valid number
6;;; * (1997/11/29) Modified by M. Rychlik(rychlik@math.arizona.edu):
7;;; The role of operators ^^ (exponentiation) and ^ (logxior)
8;;; of the original version was reversed
9;;; ****************************************************************
10;;;
11
12;;; Wed Jan 18 13:13:59 1995 by Mark Kantrowitz <mkant@FLATHEAD.OZ.CS.CMU.EDU>
13;;; infix.cl -- 40545 bytes
14
15;;; **************************************************************************
16;;; Infix ********************************************************************
17;;; **************************************************************************
18;;;
19;;; This is an implementation of an infix reader macro. It should run in any
20;;; valid Common Lisp and has been tested in Allegro CL 4.1, Lucid CL 4.0.1,
21;;; MCL 2.0 and CMU CL. It allows the user to type arithmetic expressions in
22;;; the traditional way (e.g., 1+2) when writing Lisp programs instead of
23;;; using the normal Lisp syntax (e.g., (+ 1 2)). It is not intended to be a
24;;; full replacement for the normal Lisp syntax. If you want a more complete
25;;; alternate syntax for Lisp, get a copy Apple's MLisp or Pratt's CGOL.
26;;;
27;;; Although similar in concept to the Symbolics infix reader (#<DIAMOND>),
28;;; no real effort has been made to ensure compatibility beyond coverage
29;;; of at least the same set of basic arithmetic operators. There are several
30;;; differences in the syntax beyond just the choice of #I as the macro
31;;; character. (Our syntax is a little bit more C-like than the Symbolics
32;;; macro in addition to some more subtle differences.)
33;;;
34;;; We initially chose $ as a macro character because of its association
35;;; with mathematics in LaTeX, but unfortunately that character is already
36;;; used in MCL. We switched to #I() because it was one of the few options
37;;; remaining.
38;;;
39;;; Written by Mark Kantrowitz, School of Computer Science,
40;;; Carnegie Mellon University, March 1993.
41;;;
42;;; Copyright (c) 1993 by Mark Kantrowitz. All rights reserved.
43;;;
44;;; Use and copying of this software and preparation of derivative works
45;;; based upon this software are permitted, so long as the following
46;;; conditions are met:
47;;; o no fees or compensation are charged for use, copies,
48;;; distribution or access to this software
49;;; o this copyright notice is included intact.
50;;; This software is made available AS IS, and no warranty is made about
51;;; the software or its performance.
52;;;
53;;; In no event will the author(s) or their institutions be liable to you for
54;;; damages, including lost profits, lost monies, or other special, incidental
55;;; or consequential damages, arising out of or in connection with the use or
56;;; inability to use (including but not limited to loss of data or data being
57;;; rendered inaccurate or losses sustained by third parties or a failure of
58;;; the program to operate as documented) the program, or for any claim by
59;;; any other party, whether in an action of contract, negligence, or
60;;; other tortious action.
61;;;
62;;; Please send bug reports, comments and suggestions to mkant@cs.cmu.edu.
63;;;
64;;; The current version of this software and a variety of related utilities
65;;; may be obtained from the Lisp Repository by anonymous ftp
66;;; from ftp.cs.cmu.edu [128.2.206.173] in the directory
67;;; user/ai/lang/lisp/code/syntax/infix/
68;;; If your site runs the Andrew File System, you can cd to the AFS directory
69;;; /afs/cs.cmu.edu/project/ai-repository/ai/lang/lisp/code/syntax/infix/
70;;;
71;;; If you wish to be added to the Lisp-Utilities@cs.cmu.edu mailing list,
72;;; send email to Lisp-Utilities-Request@cs.cmu.edu with your name, email
73;;; address, and affiliation. This mailing list is primarily for
74;;; notification about major updates, bug fixes, and additions to the Lisp
75;;; Utilities Repository. The mailing list is intended to have low traffic.
76;;;
77
78
79;;; ********************************
80;;; Documentation ******************
81;;; ********************************
82;;;
83;;; Syntax:
84;;;
85;;; Begin the reader macro with #I( and end it with ). For example,
86;;; #I( x^2 + y^2 )
87;;; is equivalent to the Lisp form
88;;; (+ (expt x 2) (expt y 2))
89;;; but much easier to read according to some folks.
90;;;
91;;; If you want to see the expansion, type a quote before the #I form
92;;; at the Lisp prompt:
93;;; > '#I(if x<y<=z then f(x)=x^2+y^2 else f(x)=x^2-y^2)
94;;; (IF (AND (< X Y) (<= Y Z))
95;;; (SETF (F X) (+ (EXPT X 2) (EXPT Y 2)))
96;;; (SETF (F X) (- (EXPT X 2) (EXPT Y 2))))
97;;;
98;;;
99;;; Operators:
100;;;
101;;; NOTE: == is equality, = is assignment (C-style).
102;;;
103;;; \ quoting character: x\-y --> x-y
104;;; ! lisp escape !(foo bar) --> (foo bar)
105;;; ; comment
106;;; x = y assignment (setf x y)
107;;; x += y increment (incf x y)
108;;; x -= y decrement (decf x y)
109;;; x *= y multiply and store (setf x (* x y))
110;;; x /= y divide and store (setf x (/ x y))
111;;; x|y bitwise logical inclusive or (logior x y)
112;;; x^^y bitwise logical exclusive or (logxor x y)
113;;; x&y bitwise logical and (logand x y)
114;;; x<<y left shift (ash x y)
115;;; x>>y right shift (ash x (- y))
116;;; ~x ones complement (unary) (lognot x)
117;;; x and y conjunction (and x y)
118;;; x && y conjunction (and x y)
119;;; x or y disjunction (or x y)
120;;; x || y disjunction (or x y)
121;;; not x negation (not x)
122;;; x^y exponentiation (expt x y)
123;;; x,y sequence (progn x y)
124;;; (x,y) sequence (progn x y)
125;;; also parenthesis (x+y)/z --> (/ (+ x y) z)
126;;; f(x,y) functions (f x y)
127;;; a[i,j] array reference (aref a i j)
128;;; x+y x*y arithmetic (+ x y) (* x y)
129;;; x-y x/y arithmetic (- x y) (/ x y)
130;;; -y value negation (- y)
131;;; x % y remainder (mod x y)
132;;; x<y x>y inequalities (< x y) (> x y)
133;;; x <= y x >= y inequalities (<= x y) (>= x y)
134;;; x == y equality (= x y)
135;;; x != y equality (not (= x y))
136;;; if p then q conditional (when p q)
137;;; if p then q else r conditional (if p q r)
138;;;
139
140
141;;; Precedence:
142;;;
143;;; The following precedence conventions are obeyed by the infix operators:
144;;; [ ( !
145;;; ^
146;;; ~
147;;; * / %
148;;; + -
149;;; << >>
150;;; < == > <= != >=
151;;; &
152;;; ^^
153;;; |
154;;; not
155;;; and
156;;; or
157;;; = += -= *= /=
158;;; ,
159;;; if
160;;; then else
161;;; ] )
162;;;
163;;; Note that logical negation has lower precedence than numeric comparison
164;;; so that "not a<b" becomes (not (< a b)), which is different from the
165;;; C precedence conventions. You can change the precedence conventions by
166;;; modifying the value of the variable *operator-ordering*.
167;;;
168
169
170;;; ********************************
171;;; To Do **************************
172;;; ********************************
173;;;
174;;; Write some more test cases.
175;;; Write some more syntactic optimizations.
176;;; Would really like ~x to be (not x), but need it for (lognot x).
177;;; Support for multiple languages, such as a Prolog parser, a
178;;; strictly C compatible parser, etc.
179
180;;; Create a more declarative format, where there is one big table of
181;;; operators with all the info on them, and also NOT have the list of
182;;; operators in the comment, where they are likely to become wrong when
183;;; changes are made to the code. For example, something like:
184#|
185(define-infix-operators
186 ([ 30 :matchfix aref :end ])
187 (* 20 :infix * )
188 (+ 10 :infix + :prefix + )
189 (& 10 :infix and )
190 (+= 10 :infix #'+=-operator )
191 ...)
192|#
193
194;;; ********************************
195;;; Change Log *********************
196;;; ********************************
197;;;
198;;; 9-MAR-93 mk Created
199;;; 12-MAR-93 mk Fixed defpackage form for Lucid.
200;;; 1.1:
201;;; 14-OCT-93 mk Changed macro character from #$ to #I(). Suggested by
202;;; Scott McKay.
203;;; 1.2:
204;;; 18-JAN-95 norvig Added *print-infix-copyright*, string->prefix, support
205;;; for #I"..." in addition to #i(...) which lets one
206;;; type #i"a|b" which doesn't confuse editors that aren't
207;;; |-aware. Also added := as a synonym for =, so that
208;;; '#i"car(a) := b" yields (SETF (CAR A) B).
209;;;
210;;; 1.3:
211;;; 28-JUN-96 mk Modified infix reader to allow whitespace between the #I
212;;; and the start of the expression.
213
214
215
216
217;;; ********************************
218;;; Implementation Notes ***********
219;;; ********************************
220;;;
221;;; Initially we tried implementing everything within the Lisp reader,
222;;; but found this to not be workable. Parameters had to be passed in
223;;; global variables, and some of the processing turned out to be
224;;; indelible, so it wasn't possible to use any kind of lookahead.
225;;; Center-embedded constructions were also a problem, due to the lack
226;;; of an explicit stack.
227;;;
228;;; So we took another tack, that used below. The #I macro binds the
229;;; *readtable* to a special readtable, which is used solely for tokenization
230;;; of the input. Then the problem is how to correctly parenthesize the input.
231;;; We do that with what is essentially a recursive-descent parser. An
232;;; expression is either a prefix operator followed by an expression, or an
233;;; expression followed by an infix operator followed by an expression. When
234;;; the latter expression is complex, the problem becomes a little tricky.
235;;; For example, suppose we have
236;;; exp1 op1 exp2 op2
237;;; We need to know whether to parenthesize it as
238;;; (exp1 op1 exp2) op2
239;;; or as
240;;; exp1 op1 (exp2 op2 ...)
241;;; The second case occurs either when op2 has precedence over op1 (e.g.,
242;;; * has precedence over +) or op2 and op1 are the same right-associative
243;;; operator (e.g., exponentiation). Thus the algorithm is as follows:
244;;; When we see op1, we want to gobble up exp2 op2 exp3 op3 ... opn expn+1
245;;; into an expression where op2 through opn all have higher precedence
246;;; than op1 (or are the same right-associative operator), and opn+1 doesn't.
247;;; This algorithm is implemented by the GATHER-SUPERIORS function.
248;;;
249;;; Because + and - are implemented in the infix readtable as terminating
250;;; macro cahracters, the exponentiation version of Lisp number syntax
251;;; 1e-3 == 0.001
252;;; doesn't work correctly -- it parses it as (- 1e 3). So we add a little
253;;; cleverness to GATHER-SUPERIORS to detect when the tokenizer goofed.
254;;; Since this requires the ability to lookahead two tokens, we use a
255;;; stack to implement the lookahead in PEEK-TOKEN and READ-TOKEN.
256;;;
257;;; Finally, the expression returned by GATHER-SUPERIORS sometimes needs to
258;;; be cleaned up a bit. For example, parsing a<b<c would normally return
259;;; (< (< a b) c), which obviously isn't correct. So POST-PROCESS-EXPRESSION
260;;; detects this and similar cases, replacing the expression with (< a b c).
261;;; For cases like a<b<=c, it replaces it with (and (< a b) (<= b c)).
262;;;
263
264
265;;; ********************************
266;;; Package Cruft ******************
267;;; ********************************
268
269(defpackage "INFIX"
270 (:use #-:lucid "COMMON-LISP"
271 #+:lucid "LISP" #+:lucid "LUCID-COMMON-LISP")
272 (:export test-infix string->prefix operator-lessp))
273
274(in-package "INFIX")
275
276(pushnew :infix *features*)
277
278(proclaim '(optimize (speed 0) (space 0) (safety 3) (debug 3)))
279
280(eval-when (:compile-toplevel :load-toplevel :execute)
281 (defparameter *version* "1.3 28-JUN-96")
282 (defparameter *print-infix-copyright* t
283 "If non-NIL, prints a copyright notice upon loading this file.")
284
285 (defun infix-copyright (&optional (stream *standard-output*))
286 "Prints an INFIX copyright notice and header upon startup."
287 (format stream "~%;;; ~V,,,'*A" 73 "*")
288 (format stream "~%;;; Infix notation for Common Lisp.")
289 (format stream "~%;;; Version ~A." *version*)
290 (format stream "~%;;; Written by Mark Kantrowitz, ~
291 CMU School of Computer Science.")
292 (format stream "~%;;; Copyright (c) 1993-95. All rights reserved.")
293 (format stream "~%;;; May be freely redistributed, provided this ~
294 notice is left intact.")
295 (format stream "~%;;; This software is made available AS IS, without ~
296 any warranty.")
297 (format stream "~%;;; ~V,,,'*A~%" 73 "*")
298 (force-output stream))
299
300 ;; What this means is you can either turn off the copyright notice
301 ;; by setting the parameter, or you can turn it off by including
302 ;; (setf (get :infix :dont-print-copyright) t) in your lisp init file.
303 (when (and *print-infix-copyright*
304 (not (get :infix :dont-print-copyright)))
305 (infix-copyright)))
306
307;;; ********************************
308;;; Readtable **********************
309;;; ********************************
310
311(defparameter *infix-readtable* (copy-readtable nil))
312(defparameter *normal-readtable* (copy-readtable nil))
313
314(defmacro infix-error (format-string &rest args)
315 `(let ((*readtable* *normal-readtable*))
316 (error ,format-string ,@args)))
317
318(defun infix-reader (stream subchar arg)
319 ;; Read either #I(...) or #I"..."
320 (declare (ignore arg subchar))
321 (let ((first-char (peek-char nil stream t nil t)))
322 (cond ((char= first-char #\space)
323 (read-char stream) ; skip over whitespace
324 (infix-reader stream nil nil))
325 ((char= first-char #\")
326 ;; Read double-quote-delimited infix expressions.
327 (string->prefix (read stream t nil t)))
328 ((char= first-char #\()
329 (read-char stream) ; get rid of opening left parenthesis
330 (let ((*readtable* *infix-readtable*)
331 (*normal-readtable* *readtable*))
332 (read-infix stream)))
333 (t
334 (infix-error "Infix expression starts with ~A" first-char)))))
335
336(set-dispatch-macro-character #\# #\I #'infix-reader *readtable*) ; was #\# #\$
337
338(defun string->prefix (string)
339 "Convert a string to a prefix s-expression using the infix reader.
340 If the argument is not a string, just return it as is."
341 (if (stringp string)
342 (with-input-from-string (stream (concatenate 'string "#I(" string ")"))
343 (read stream))
344 string))
345
346
347(defun read-infix (stream)
348 (let* ((result (gather-superiors '\) stream)) ; %infix-end-token%
349 (next-token (read-token stream)))
350 (unless (same-token-p next-token '\)) ; %infix-end-token%
351 (infix-error "Infix expression ends with ~A." next-token))
352 result))
353
354(defun read-regular (stream)
355 (let ((*readtable* *normal-readtable*))
356 (read stream t nil t)))
357
358
359
360;;; ********************************
361;;; Reader Code ********************
362;;; ********************************
363
364(defun same-operator-p (x y)
365 (same-token-p x y))
366
367(defun same-token-p (x y)
368 (and (symbolp x)
369 (symbolp y)
370 (string-equal (symbol-name x) (symbol-name y))))
371
372;;; Peeking Token Reader
373
374(defvar *peeked-token* nil)
375(defun read-token (stream)
376 (if *peeked-token*
377 (pop *peeked-token*)
378 (read stream t nil t)))
379(defun peek-token (stream)
380 (unless *peeked-token*
381 (push (read stream t nil t) *peeked-token*))
382 (car *peeked-token*))
383
384;;; Hack to work around + and - being terminating macro characters,
385;;; so 1e-3 doesn't normally work correctly.
386
387(defun fancy-number-format-p (left operator stream)
388 (when (and (symbolp left)
389 (find operator '(+ -) :test #'same-operator-p))
390 (let* ((name (symbol-name left))
391 (length (length name)))
392 (when (and (valid-numberp (subseq name 0 (1- length)))
393 ;; Exponent, Single, Double, Float, or Long
394 (find (subseq name (1- length))
395 '("e" "s" "d" "f" "l")
396 :test #'string-equal))
397 (read-token stream)
398 (let ((right (peek-token stream)))
399 (cond ((integerp right)
400 ;; it is one of the fancy numbers, so return it
401 (read-token stream)
402 (let ((*readtable* *normal-readtable*))
403 (read-from-string (format nil "~A~A~A"
404 left operator right))))
405 (t
406 ;; it isn't one of the fancy numbers, so unread the token
407 (push operator *peeked-token*)
408 ;; and return nil
409 nil)))))))
410
411(defun valid-numberp (string)
412 (let ((saw-dot nil)
413 (char-list (coerce string 'list)))
414 (unless char-list (return-from valid-numberp nil))
415 (dolist (char char-list t)
416 (cond ((char= char #\.)
417 (if saw-dot
418 (return nil)
419 (setq saw-dot t)))
420 ((not (find char "01234567890" :test #'char=))
421 (return nil))))))
422
423;;; Gobbles an expression from the stream.
424
425(defun gather-superiors (previous-operator stream)
426 "Gathers an expression whose operators all exceed the precedence of
427 the operator to the left."
428 (let ((left (get-first-token stream)))
429 (loop
430 (setq left (post-process-expression left))
431 (let ((peeked-token (peek-token stream)))
432 (let ((fancy-p (fancy-number-format-p left peeked-token stream)))
433 (when fancy-p
434 ;; i.e., we've got a number like 1e-3 or 1e+3 or 1f-1
435 (setq left fancy-p
436 peeked-token (peek-token stream))))
437 (unless (or (operator-lessp previous-operator peeked-token)
438 (and (same-operator-p peeked-token previous-operator)
439 (operator-right-associative-p previous-operator)))
440 ;; The loop should continue when the peeked operator is
441 ;; either superior in precedence to the previous operator,
442 ;; or the same operator and right-associative.
443 (return left)))
444 (setq left (get-next-token stream left)))))
445
446(defun get-first-token (stream)
447 (let ((token (read-token stream)))
448 (if (token-operator-p token)
449 ;; It's an operator in a prefix context.
450 (apply-token-prefix-operator token stream)
451 ;; It's a regular token
452 token)))
453
454(defun apply-token-prefix-operator (token stream)
455 (let ((operator (get-token-prefix-operator token)))
456 (if operator
457 (funcall operator stream)
458 (infix-error "~A is not a prefix operator" token))))
459
460(defun get-next-token (stream left)
461 (let ((token (read-token stream)))
462 (apply-token-infix-operator token left stream)))
463
464(defun apply-token-infix-operator (token left stream)
465 (let ((operator (get-token-infix-operator token)))
466 (if operator
467 (funcall operator stream left)
468 (infix-error "~A is not an infix operator" token))))
469
470;;; Fix to read-delimited-list so that it works with tokens, not
471;;; characters.
472
473(defun infix-read-delimited-list (end-token delimiter-token stream)
474 (do ((next-token (peek-token stream) (peek-token stream))
475 (list nil))
476 ((same-token-p next-token end-token)
477 ;; We've hit the end. Remove the end-token from the stream.
478 (read-token stream)
479 ;; and return the list of tokens.
480 ;; Note that this does the right thing with [] and ().
481 (nreverse list))
482 ;; Ignore the delimiters.
483 (when (same-token-p next-token delimiter-token)
484 (read-token stream))
485 ;; Gather the expression until the next delimiter.
486 (push (gather-superiors delimiter-token stream) list)))
487
488
489
490;;; ********************************
491;;; Precedence *********************
492;;; ********************************
493
494(defparameter *operator-ordering*
495 '(( \[ \( \! ) ; \[ is array reference
496 ( ^ ) ; exponentiation
497 ( ~ ) ; lognot
498 ( * / % ) ; % is mod
499 ( + - )
500 ( << >> )
501 ( < == > <= != >= )
502 ( & ) ; logand
503 ( ^^ ) ; logxor
504 ( \| ) ; logior
505 ( not )
506 ( and )
507 ( or )
508 ;; Where should setf and friends go in the precedence?
509 ( = |:=| += -= *= /= )
510 ( \, ) ; progn (statement delimiter)
511 ( if )
512 ( then else )
513 ( \] \) )
514 ( %infix-end-token% )) ; end of infix expression
515 "Ordered list of operators of equal precedence.")
516
517(defun operator-lessp (op1 op2)
518 (dolist (ops *operator-ordering* nil)
519 (cond ((find op1 ops :test #'same-token-p)
520 (return nil))
521 ((find op2 ops :test #'same-token-p)
522 (return t)))))
523
524(defparameter *right-associative-operators* '(^ =))
525(defun operator-right-associative-p (operator)
526 (find operator *right-associative-operators*))
527
528
529
530;;; ********************************
531;;; Define Operators ***************
532;;; ********************************
533
534(defvar *token-operators* nil)
535(defvar *token-prefix-operator-table* (make-hash-table))
536(defvar *token-infix-operator-table* (make-hash-table))
537(defun token-operator-p (token)
538 (find token *token-operators*))
539(defun get-token-prefix-operator (token)
540 (gethash token *token-prefix-operator-table*))
541(defun get-token-infix-operator (token)
542 (gethash token *token-infix-operator-table*))
543
544(eval-when (:compile-toplevel :load-toplevel :execute)
545 (defmacro define-token-operator (operator-name &key
546 (prefix nil prefix-p)
547 (infix nil infix-p))
548 `(progn
549 (pushnew ',operator-name *token-operators*)
550 ,(when prefix-p
551 `(setf (gethash ',operator-name *token-prefix-operator-table*)
552 #'(lambda (stream)
553 ,@(cond ((and (consp prefix)
554 (eq (car prefix) 'infix-error))
555 ;; To avoid ugly compiler warnings.
556 `((declare (ignore stream))
557 ,prefix))
558 (t
559 (list prefix))))))
560 ,(when infix-p
561 `(setf (gethash ',operator-name *token-infix-operator-table*)
562 #'(lambda (stream left)
563 ,@(cond ((and (consp infix)
564 (eq (car infix) 'infix-error))
565 ;; To avoid ugly compiler warnings.
566 `((declare (ignore stream left))
567 ,infix))
568 (t
569 (list infix)))))))))
570
571;;; Readtable definitions for characters, so that the right token is returned.
572(eval-when (:compile-toplevel :load-toplevel :execute)
573 (defmacro define-character-tokenization (char function)
574 `(set-macro-character ,char ,function nil *infix-readtable*)))
575
576
577
578;;; ********************************
579;;; Operator Definitions ***********
580;;; ********************************
581
582(define-token-operator and
583 :infix `(and ,left ,(gather-superiors 'and stream)))
584(define-token-operator or
585 :infix `(or ,left ,(gather-superiors 'or stream)))
586(define-token-operator not
587 :prefix `(not ,(gather-superiors 'not stream)))
588
589(define-token-operator if
590 :prefix (let* ((test (gather-superiors 'if stream))
591 (then (cond ((same-token-p (peek-token stream) 'then)
592 (read-token stream)
593 (gather-superiors 'then stream))
594 (t
595 (infix-error "Missing THEN clause."))))
596 (else (when (same-token-p (peek-token stream) 'else)
597 (read-token stream)
598 (gather-superiors 'else stream))))
599 (cond ((and test then else)
600 `(if ,test ,then ,else))
601 ((and test then)
602 ;; no else clause
603 `(when ,test ,then))
604 ((and test else)
605 ;; no then clause
606 `(unless ,test ,else))
607 (t
608 ;; no then and else clauses --> always NIL
609 nil))))
610
611(define-token-operator then
612 :prefix (infix-error "THEN clause without an IF."))
613(define-token-operator else
614 :prefix (infix-error "ELSE clause without an IF."))
615
616(define-character-tokenization #\+
617 #'(lambda (stream char)
618 (declare (ignore char))
619 (cond ((char= (peek-char nil stream t nil t) #\=)
620 (read-char stream t nil t)
621 '+=)
622 (t
623 '+))))
624(define-token-operator +
625 :infix `(+ ,left ,(gather-superiors '+ stream))
626 :prefix (gather-superiors '+ stream))
627(define-token-operator +=
628 :infix `(incf ,left ,(gather-superiors '+= stream)))
629
630(define-character-tokenization #\-
631 #'(lambda (stream char)
632 (declare (ignore char))
633 (cond ((char= (peek-char nil stream t nil t) #\=)
634 (read-char stream t nil t)
635 '-=)
636 (t
637 '-))))
638(define-token-operator -
639 :infix `(- ,left ,(gather-superiors '- stream))
640 :prefix `(- ,(gather-superiors '- stream)))
641(define-token-operator -=
642 :infix `(decf ,left ,(gather-superiors '-= stream)))
643
644(define-character-tokenization #\*
645 #'(lambda (stream char)
646 (declare (ignore char))
647 (cond ((char= (peek-char nil stream t nil t) #\=)
648 (read-char stream t nil t)
649 '*=)
650 (t
651 '*))))
652(define-token-operator *
653 :infix `(* ,left ,(gather-superiors '* stream)))
654(define-token-operator *=
655 :infix `(,(if (symbolp left)
656 'setq
657 'setf)
658 ,left
659 (* ,left ,(gather-superiors '*= stream))))
660
661(define-character-tokenization #\/
662 #'(lambda (stream char)
663 (declare (ignore char))
664 (cond ((char= (peek-char nil stream t nil t) #\=)
665 (read-char stream t nil t)
666 '/=)
667 (t
668 '/))))
669(define-token-operator /
670 :infix `(/ ,left ,(gather-superiors '/ stream))
671 :prefix `(/ ,(gather-superiors '/ stream)))
672(define-token-operator /=
673 :infix `(,(if (symbolp left)
674 'setq
675 'setf)
676 ,left
677 (/ ,left ,(gather-superiors '/= stream))))
678
679(define-character-tokenization #\^
680 #'(lambda (stream char)
681 (declare (ignore char))
682 (cond ((char= (peek-char nil stream t nil t) #\^)
683 (read-char stream t nil t)
684 '^^)
685 (t
686 '^))))
687(define-token-operator ^
688 :infix `(expt ,left ,(gather-superiors '^ stream)))
689(define-token-operator ^^
690 :infix `(logxor ,left ,(gather-superiors '^^ stream)))
691
692(define-character-tokenization #\|
693 #'(lambda (stream char)
694 (declare (ignore char))
695 (cond ((char= (peek-char nil stream t nil t) #\|)
696 (read-char stream t nil t)
697 'or)
698 (t
699 '\|))))
700(define-token-operator \|
701 :infix `(logior ,left ,(gather-superiors '\| stream)))
702
703(define-character-tokenization #\&
704 #'(lambda (stream char)
705 (declare (ignore char))
706 (cond ((char= (peek-char nil stream t nil t) #\&)
707 (read-char stream t nil t)
708 'and)
709 (t
710 '\&))))
711(define-token-operator \&
712 :infix `(logand ,left ,(gather-superiors '\& stream)))
713
714(define-character-tokenization #\%
715 #'(lambda (stream char)
716 (declare (ignore stream char))
717 '\%))
718(define-token-operator \%
719 :infix `(mod ,left ,(gather-superiors '\% stream)))
720
721(define-character-tokenization #\~
722 #'(lambda (stream char)
723 (declare (ignore stream char))
724 '\~))
725(define-token-operator \~
726 :prefix `(lognot ,(gather-superiors '\~ stream)))
727
728(define-character-tokenization #\,
729 #'(lambda (stream char)
730 (declare (ignore stream char))
731 '\,))
732(define-token-operator \,
733 :infix `(progn ,left ,(gather-superiors '\, stream)))
734
735(define-character-tokenization #\=
736 #'(lambda (stream char)
737 (declare (ignore char))
738 (cond ((char= (peek-char nil stream t nil t) #\=)
739 (read-char stream t nil t)
740 '==)
741 (t
742 '=))))
743(define-token-operator ==
744 :infix `(= ,left ,(gather-superiors '== stream)))
745(define-token-operator =
746 :infix `(,(if (symbolp left)
747 'setq
748 'setf)
749 ,left
750 ,(gather-superiors '= stream)))
751
752(define-character-tokenization #\:
753 #'(lambda (stream char)
754 (declare (ignore char))
755 (cond ((char= (peek-char nil stream t nil t) #\=)
756 (read-char stream t nil t)
757 '|:=|)
758 (t
759 '|:|))))
760(define-token-operator |:=|
761 :infix `(,(if (symbolp left)
762 'setq
763 'setf)
764 ,left
765 ,(gather-superiors '|:=| stream)))
766
767(define-character-tokenization #\<
768 #'(lambda (stream char)
769 (declare (ignore char))
770 (cond ((char= (peek-char nil stream t nil t) #\=)
771 (read-char stream t nil t)
772 '<=)
773 ((char= (peek-char nil stream t nil t) #\<)
774 (read-char stream t nil t)
775 '<<)
776 (t
777 '<))))
778(define-token-operator <
779 :infix `(< ,left ,(gather-superiors '< stream)))
780(define-token-operator <=
781 :infix `(<= ,left ,(gather-superiors '<= stream)))
782(define-token-operator <<
783 :infix `(ash ,left ,(gather-superiors '<< stream)))
784
785(define-character-tokenization #\>
786 #'(lambda (stream char)
787 (declare (ignore char))
788 (cond ((char= (peek-char nil stream t nil t) #\=)
789 (read-char stream t nil t)
790 '>=)
791 ((char= (peek-char nil stream t nil t) #\>)
792 (read-char stream t nil t)
793 '>>)
794 (t
795 '>))))
796(define-token-operator >
797 :infix `(> ,left ,(gather-superiors '> stream)))
798(define-token-operator >=
799 :infix `(>= ,left ,(gather-superiors '>= stream)))
800(define-token-operator >>
801 :infix `(ash ,left (- ,(gather-superiors '>> stream))))
802
803(define-character-tokenization #\!
804 #'(lambda (stream char)
805 (declare (ignore char))
806 (cond ((char= (peek-char nil stream t nil t) #\=)
807 (read-char stream t nil t)
808 '!=)
809 (t
810 '!))))
811(define-token-operator !=
812 :infix `(not (= ,left ,(gather-superiors '!= stream))))
813(define-token-operator !
814 :prefix (read-regular stream))
815
816(define-character-tokenization #\[
817 #'(lambda (stream char)
818 (declare (ignore stream char))
819 '\[))
820(define-token-operator \[
821 :infix (let ((indices (infix-read-delimited-list '\] '\, stream)))
822 (if (null indices)
823 (infix-error "No indices found in array reference.")
824 `(aref ,left ,@indices)))
825 :prefix (let ((list-members (infix-read-delimited-list '\] '\, stream)))
826 `(:[ ,@list-members)))
827
828(define-character-tokenization #\(
829 #'(lambda (stream char)
830 (declare (ignore stream char))
831 '\())
832(define-token-operator \(
833 :infix `(,left ,@(infix-read-delimited-list '\) '\, stream))
834 :prefix (let ((list (infix-read-delimited-list '\) '\, stream)))
835 (if (null (rest list))
836 ;; only one element in list. works correctly if list is NIL
837 (first list)
838 ;; several elements in list
839 `(progn ,@list))))
840
841(define-character-tokenization #\]
842 #'(lambda (stream char)
843 (declare (ignore stream char))
844 '\]))
845(define-token-operator \]
846 :infix (infix-error "Extra close brace \"]\" in infix expression"))
847
848(define-character-tokenization #\)
849 #'(lambda (stream char)
850 (declare (ignore stream char))
851 '\)))
852(define-token-operator \)
853 :infix (infix-error "Extra close paren \")\" in infix expression"))
854
855#|
856;;; Commented out because no longer using $ as the macro character.
857(define-character-tokenization #\$
858 #'(lambda (stream char)
859 (declare (ignore stream char))
860 '%infix-end-token%))
861(define-token-operator %infix-end-token%
862 :infix (infix-error "Prematurely terminated infix expression")
863 :prefix (infix-error "Prematurely terminated infix expression"))
864|#
865
866(define-character-tokenization #\;
867 #'(lambda (stream char)
868 (declare (ignore char))
869 (do ((char (peek-char nil stream t nil t)
870 (peek-char nil stream t nil t)))
871 ((or (char= char #\newline) (char= char #\return)
872 ;; was #\$
873; (char= char #\))
874 )
875 ;; Gobble characters until the end of the line or the
876 ;; end of the input.
877 (cond ((or (char= char #\newline) (char= char #\return))
878 (read-char stream)
879 (read stream t nil t))
880 (t
881 ;; i.e., return %infix-end-token%
882 (read stream t nil t))))
883 (read-char stream))))
884
885
886
887;;; ********************************
888;;; Syntactic Modifications ********
889;;; ********************************
890
891;;; Post processes the expression to remove some unsightliness caused
892;;; by the way infix processes the input. Note that it is also required
893;;; for correctness in the a<b<=c case.
894
895(defun post-process-expression (expression)
896 (if (and (consp expression)
897 (= (length expression) 3))
898 (destructuring-bind (operator left right) expression
899 (cond ((and (consp left)
900 (same-operator-p (first left) operator)
901 (find operator '(+ * / - and or < > <= >= progn)
902 :test #'same-operator-p))
903 ;; Flatten the expression if possible
904 (cond ((and (eq operator '-)
905 (= (length left) 2))
906 ;; -a-b --> (+ (- a) (- b)).
907 `(+ ,left (- ,right)))
908 ((and (eq operator '/)
909 (= (length left) 2))
910 ;; ditto with /
911 `(/ (* ,(second left) ,right)))
912 (t
913 ;; merges a+b+c as (+ a b c).
914 (append left (list right)))))
915 ((and (consp left)
916 (eq operator '-)
917 (eq (first left) '+))
918 ;; merges a+b-c as (+ a b (- c)).
919 (append left (list `(- ,right))))
920 ((and (consp left)
921 (find operator '(< > <= >=))
922 (find (first left) '(< > <= >=)))
923 ;; a<b<c --> a<b and b<c
924 `(and ,left
925 (,operator ,(first (last left))
926 ,right)))
927 (t
928 expression)))
929 expression))
930
931
932
933;;; ********************************
934;;; Test Infix *********************
935;;; ********************************
936
937;;; Invoke with (infix:test-infix).
938;;; Prints out all the tests that fail and a count of the number of failures.
939
940(defparameter *test-cases*
941 ;; Note that in strings, we have to slashify \ as \\.
942 '(("1 * +2" (* 1 2))
943 ("1 * -2" (* 1 (- 2)))
944 ("1 * /2" (* 1 (/ 2)))
945 ("/2" (/ 2))
946 ("not true" (not true))
947 ("foo\\-bar" foo-bar)
948 ("a + b-c" (+ a b (- c)))
949 ("a + b\\-c" (+ a b-c))
950 ("f\\oo" |FoO|)
951 ("!foo-bar * 2" (* foo-bar 2))
952 ("!(foo bar baz)" (foo bar baz))
953 ("!foo-bar " foo-bar)
954 ;; The following now longer gives an eof error, since the close
955 ;; parenthesis terminates the token.
956 ("!foo-bar" foo-bar) ; eof error -- ! eats the close $
957 ("a+-b" (+ a (- b)))
958 ("a+b" (+ a b))
959 ("a+b*c" (+ a (* b c)))
960 ("a+b+c" (+ a b c))
961 ("a+b-c" (+ a b (- c)))
962 ("a+b-c+d" (+ a b (- c) d))
963 ("a+b-c-d" (+ a b (- c) (- d)))
964 ("a-b" (- a b))
965 ("a*b" (* a b))
966 ("a*b*c" (* a b c))
967 ("a*b+c" (+ (* a b) c))
968 ("a/b" (/ a b))
969 ("a^b" (expt a b))
970 ("foo/-bar" (/ foo (- bar)))
971 ("1+2*3^4" (+ 1 (* 2 (expt 3 4))))
972 ("1+2*3^4+5" (+ 1 (* 2 (expt 3 4)) 5))
973 ("2*3^4+1" (+ (* 2 (expt 3 4)) 1))
974 ("2+3^4*5" (+ 2 (* (expt 3 4) 5)))
975 ("2^3^4" (expt 2 (expt 3 4)))
976 ("x^2 + y^2" (+ (expt x 2) (expt y 2)))
977 ("(1+2)/3" (/ (+ 1 2) 3))
978 ("(a=b)" (setq a b))
979 ("(a=b,b=c)" (progn (setq a b) (setq b c)))
980 ("1*(2+3)" (* 1 (+ 2 3)))
981 ("1+2/3" (+ 1 (/ 2 3)))
982 ("a,b" (progn a b))
983 ("a,b,c" (progn a b c))
984 ("foo(a,b,(c,d))" (foo a b (progn c d)))
985 ("foo(a,b,c)" (foo a b c))
986 ("(a+b,c)" (progn (+ a b) c))
987 ("1" 1)
988 ("-1" (- 1))
989 ("+1" 1)
990 ("1." 1)
991 ("1.1" 1.1)
992 ("1e3" 1000.0)
993 ("1e-3" 0.001)
994 ("1f-3" 1f-3)
995 ("1e-3e" (- 1e 3e))
996 ("!1e-3 " 0.001)
997 ("a and b and c" (and a b c))
998 ("a and b or c" (or (and a b) c))
999 ("a and b" (and a b))
1000 ("a or b and c" (or a (and b c)))
1001 ("a or b" (or a b))
1002 ("a<b and b<c" (and (< a b) (< b c)))
1003 ("if (if a then b else c) then e" (when (if a b c) e))
1004 ("if 1 then 2 else 3+4" (if 1 2 (+ 3 4)))
1005 ("(if 1 then 2 else 3)+4" (+ (if 1 2 3) 4))
1006 ("if a < b then b else a" (if (< a b) b a))
1007 ("if a and b then c and d else e and f"
1008 (if (and a b) (and c d) (and e f)))
1009 ("if a or b then c or d else e or f" (if (or a b) (or c d) (or e f)))
1010 ("if a then (if b then c else d) else e" (if a (if b c d) e))
1011 ("if a then (if b then c) else d" (if a (when b c) d))
1012 ("if a then b else c" (if a b c))
1013 ("if a then b" (when a b))
1014 ("if a then if b then c else d else e" (if a (if b c d) e))
1015 ("if a then if b then c else d" (when a (if b c d)))
1016 ("if if a then b else c then e" (when (if a b c) e))
1017 ("if not a and not b then c" (when (and (not a) (not b)) c))
1018 ("if not a then not b else not c and d"
1019 (if (not a) (not b) (and (not c) d)))
1020 ("not a and not b" (and (not a) (not b)))
1021 ("not a or not b" (or (not a) (not b)))
1022 ("not a<b and not b<c" (and (not (< a b)) (not (< b c))))
1023 ("not a<b" (not (< a b)))
1024 ("a[i,k]*b[j,k]" (* (aref a i k) (aref b j k)))
1025 ("foo(bar)=foo[bar,baz]" (setf (foo bar) (aref foo bar baz)))
1026 ("foo(bar,baz)" (foo bar baz))
1027 ("foo[bar,baz]" (aref foo bar baz))
1028 ("foo[bar,baz]=barf" (setf (aref foo bar baz) barf))
1029 ("max = if a < b then b else a" (setq max (if (< a b) b a)))
1030 ("a < b < c" (< A B C))
1031 ("a < b <= c" (and (< a b) (<= b c)))
1032 ("a <= b <= c" (<= A B C))
1033 ("a <= b <= c" (<= A B C))
1034 ("a!=b and b<c" (and (not (= a b)) (< b c)))
1035 ("a!=b" (not (= a b)))
1036 ("a<b" (< a b))
1037 ("a==b" (= a b))
1038 ("a*b(c)+d" (+ (* a (b c)) d))
1039 ("a+b(c)*d" (+ a (* (b c) d)))
1040 ("a+b(c)+d" (+ a (b c) d))
1041 ("d+a*b(c)" (+ d (* a (b c))))
1042 ("+a+b" (+ a b))
1043 ("-a+b" (+ (- a) b))
1044 ("-a-b" (+ (- a) (- b)))
1045 ("-a-b-c" (+ (- a) (- b) (- c)))
1046 ("a*b/c" (/ (* a b) c))
1047 ("a+b-c" (+ a b (- c)))
1048 ("a-b-c" (- a b c))
1049 ("a/b*c" (* (/ a b) c))
1050 ("a/b/c" (/ a b c))
1051 ("/a/b" (/ (* a b)))
1052 ("a^b^c" (expt a (expt b c)))
1053 ("a(d)^b^c" (expt (a d) (expt b c)))
1054 ("a<b+c<d" (< a (+ b c) d))
1055 ("1*~2+3" (+ (* 1 (lognot 2)) 3))
1056 ("1+~2*3" (+ 1 (* (lognot 2) 3)))
1057 ("1+~2+3" (+ 1 (lognot 2) 3))
1058 ("f(a)*=g(b)" (setf (f a) (* (f a) (g b))))
1059 ("f(a)+=g(b)" (incf (f a) (g b)))
1060 ("f(a)-=g(b)" (decf (f a) (g b)))
1061 ("f(a)/=g(b)" (setf (f a) (/ (f a) (g b))))
1062 ("a&b" (logand a b))
1063 ("a^^b" (logxor a b))
1064 ("a|b" (logior a b))
1065 ("a<<b" (ash a b))
1066 ("a>>b" (ash a (- b)))
1067 ("~a" (lognot a))
1068 ("a&&b" (and a b))
1069 ("a||b" (or a b))
1070 ("a%b" (mod a b))
1071
1072 ;; Comment character -- must have carriage return after semicolon.
1073 ("x^2 ; the x coordinate
1074 + y^2 ; the y coordinate" :error)
1075 ("x^2 ; the x coordinate
1076 + y^2 ; the y coordinate
1077 " (+ (expt x 2) (expt y 2)))
1078
1079 ;; Errors
1080 ("foo(bar,baz" :error) ; premature termination
1081 ;; The following no longer gives an error
1082 ("foo(bar,baz))" (foo bar baz)) ; extra close parenthesis
1083 ("foo[bar,baz]]" :error) ; extra close bracket
1084 ("[foo,bar]" (:[ foo bar)) ; Maxima-style list
1085 ("and a" :error) ; AND is not a prefix operator
1086 ("< a" :error) ; < is not a prefix operator
1087 ("=bar" :error) ; SETF is not a prefix operator
1088 ("*bar" :error) ; * is not a prefix operator
1089 ("a not b" :error) ; NOT is not an infix operator
1090 ("a if b then c" :error) ; IF is not an infix operator
1091 ("" :error) ; premature termination (empty clause)
1092 (")a" :error) ; left parent is not a prefix operator
1093 ("]a" :error) ; left bracket is not a prefix operator
1094 ))
1095
1096(defun test-infix (&optional (tests *test-cases*))
1097 (let ((count 0))
1098 (dolist (test tests)
1099 (destructuring-bind (string result) test
1100 (unless (test-infix-case string result)
1101 (incf count))))
1102 (format t "~&~:(~R~) test~p failed." count count)
1103 (values)))
1104
1105(defun test-infix-case (string result)
1106 (multiple-value-bind (value error)
1107 (let ((*package* (find-package "INFIX")))
1108 (ignore-errors
1109 (values (read-from-string (concatenate 'string "#I(" string ")")
1110 t nil))))
1111 (cond (error
1112 (cond ((eq result :error)
1113 t)
1114 (t
1115 (format t "~&Test #I(~A) failed with ERROR." string)
1116 nil)))
1117 ((eq result :error)
1118 (format t "~&Test #I(~A) failed. ~
1119 ~& Expected ERROR ~
1120 ~& but got ~A."
1121 string value)
1122 nil)
1123 ((not (equal value result))
1124 (format t "~&Test #I(~A) failed. ~
1125 ~& Expected ~A ~
1126 ~& but got ~A."
1127 string result value)
1128 nil)
1129 (t
1130 t))))
1131
1132;;; *EOF*
Note: See TracBrowser for help on using the repository browser.