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@ 4204

Last change on this file since 4204 was 1330, checked in by Marek Rychlik, 10 years ago

* empty log message *

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