├── infix-math.asd ├── symbols.lisp ├── calc.lisp ├── data.lisp ├── README.md └── infix-math.lisp /infix-math.asd: -------------------------------------------------------------------------------- 1 | ;;;; math.asd 2 | 3 | (asdf:defsystem :infix-math 4 | :author "Paul M. Rodriguez " 5 | :description "An extensible infix syntax for math in Common Lisp." 6 | :license "MIT" 7 | :class :package-inferred-system 8 | :defsystem-depends-on (:asdf-package-system) 9 | :depends-on (:infix-math/infix-math)) 10 | -------------------------------------------------------------------------------- /symbols.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :infix-math/symbols 2 | (:use :cl) 3 | (:export 4 | :^ 5 | :√ 6 | :× :% :÷ 7 | :<< :>> 8 | :& 9 | :over 10 | :π)) 11 | 12 | ;;; ASDF won't allow :lock in the defpackage form. 13 | #+sbcl (sb-ext:lock-package :infix-math/symbols) 14 | 15 | (in-package :infix-math/symbols) 16 | 17 | (define-symbol-macro π pi) 18 | 19 | (define-symbol-macro e (exp 1d0)) 20 | 21 | (define-symbol-macro i (sqrt -1)) 22 | 23 | (defmacro unary-operator (new old) 24 | `(progn 25 | (declaim (inline ,new)) 26 | (defun ,new (a) 27 | (,old a)) 28 | (define-compiler-macro ,new (a) 29 | (list ',old a)))) 30 | 31 | (defmacro binary-operator (new old) 32 | `(progn 33 | (declaim (inline ,new)) 34 | (defun ,new (a b) 35 | (,old a b)) 36 | (define-compiler-macro ,new (a b) 37 | (list ',old a b)))) 38 | 39 | (defmacro unary-operators (&body body) 40 | `(progn 41 | ,@(loop for (new old . nil) on body by #'cddr 42 | collect `(unary-operator ,new ,old)))) 43 | 44 | (defmacro binary-operators (&body body) 45 | `(progn 46 | ,@(loop for (new old . nil) on body by #'cddr 47 | collect `(binary-operator ,new ,old)))) 48 | 49 | 50 | 51 | (declaim (inline ash-)) 52 | (defun ash- (i c) 53 | (ash i (- c))) 54 | 55 | 56 | 57 | (unary-operators 58 | ;; ! factorial 59 | √ sqrt) 60 | 61 | (binary-operators 62 | ^ expt 63 | × * 64 | ÷ rem 65 | % rem 66 | << ash 67 | >> ash- 68 | & logand 69 | over /) 70 | -------------------------------------------------------------------------------- /calc.lisp: -------------------------------------------------------------------------------- 1 | (cl:defpackage :infix-math/calc 2 | (:use :cl :infix-math :alexandria :serapeum) 3 | (:export :calc)) 4 | 5 | (defpackage :infix-math/calc-user 6 | (:use :cl :infix-math/symbols) 7 | (:export :<-)) 8 | 9 | (cl:in-package :infix-math/calc) 10 | 11 | (defconst eof "eof") 12 | 13 | (defmacro infix-math/calc-user:<- (var expr) 14 | `(setq ,var ,expr)) 15 | 16 | (declare-binary-operator infix-math/calc-user:<- 17 | ;; TODO Should be lower. 18 | :from over 19 | :right-associative t) 20 | 21 | (defconst user-pkg :infix-math/calc-user) 22 | 23 | (defconst var-names 24 | (set-difference 25 | (append 26 | (loop for code from (char-code #\a) to (char-code #\z) 27 | collect (code-char code)) 28 | (loop for code from (char-code #\α) to (char-code #\ω) 29 | collect (code-char code))) 30 | '(#\e #\t #\π #\ε #\ς))) 31 | 32 | (defconst vars 33 | (mapcar (op (intern (string-upcase _) user-pkg)) 34 | var-names)) 35 | 36 | (defconst vars/earmuffs 37 | (mapcar (op (intern (string+ "*" (string-upcase _) "*") 38 | user-pkg)) 39 | var-names)) 40 | 41 | (defmacro define-dynamic-vars () 42 | `(progn 43 | ,@(loop for var in vars 44 | for var/earmuffs in vars/earmuffs 45 | collect `(progn 46 | (defvar ,var/earmuffs) 47 | (define-symbol-macro ,var ,var/earmuffs))))) 48 | 49 | (define-dynamic-vars) 50 | 51 | (defun eval-quiet (expr) 52 | (handler-bind ((warning #'muffle-warning)) 53 | (eval expr))) 54 | 55 | (defun calc () 56 | (let ((*package* (find-package user-pkg))) 57 | (progv vars/earmuffs () 58 | (with-simple-restart (abort "Return to Lisp") 59 | (loop 60 | (with-simple-restart (abort "Return to calculator") 61 | (local 62 | (format t "~&$> ") 63 | (def string (read-line)) 64 | 65 | (def forms 66 | (with-input-from-string (s string) 67 | (loop for form = (read s nil eof) 68 | until (eq form eof) 69 | collect form))) 70 | 71 | (def expr 72 | (cond ((null forms) nil) 73 | ((single forms) 74 | (let ((form (first forms))) 75 | (cond 76 | ((eql form :q) 77 | (return-from calc *)) 78 | ((eql form :v) 79 | (list 'quote vars)) 80 | (t form)))) 81 | (t `($ ,@forms)))) 82 | 83 | (shiftf +++ ++ + expr) 84 | 85 | (def value 86 | (handler-case 87 | (eval-quiet expr) 88 | (error (e) 89 | (format t "~a" e)))) 90 | 91 | (shiftf *** ** * value) 92 | 93 | (when value 94 | (format t "~&~s~%" value))))))))) 95 | -------------------------------------------------------------------------------- /data.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :infix-math/data 2 | (:use 3 | :cl 4 | :alexandria 5 | :serapeum 6 | :infix-math/symbols) 7 | (:export 8 | :unary 9 | :operator? 10 | :trim-dotted-operator 11 | :precedence 12 | :unary? 13 | :right-associative? 14 | :declare-unary-operator 15 | :declare-binary-operator)) 16 | 17 | (in-package :infix-math/data) 18 | 19 | (deftype operator () 20 | 'symbol) 21 | 22 | (deftype precedence () 23 | '(or (real 0 *) null)) 24 | 25 | (defmacro unary (op arg) 26 | "Pretend unary operators are binary operators." 27 | `(,op ,arg)) 28 | 29 | (defparameter *order-of-operations* 30 | '((unary) 31 | (expt ^ log) 32 | (* × / % ÷ rem mod 33 | floor ffloor 34 | ceiling fceiling 35 | truncate ftruncate 36 | round fround 37 | scale-float 38 | gcd lcm atan) 39 | (+ -) 40 | (ash << >>) 41 | (logand & logandc1 logandc2 lognand) 42 | (logxor logeqv) 43 | (logior logorc1 logorc2 lognor) 44 | (min max) 45 | (over)) 46 | "Basic C-style operator precedence, with some differences. 47 | 48 | The use of MIN, MAX, GCD and LCM as infix operators is after 49 | Dijkstra (see EWD 1300). Perl 6 is also supposed to use them this 50 | way, and I have adopted its precedence levels.") 51 | 52 | (defparameter *right-associative* 53 | '(expt ^ $$)) 54 | 55 | (defparameter *precedence* 56 | (alexandria:alist-hash-table 57 | (loop for i from 0 58 | for level in *order-of-operations* 59 | append (loop for op in level 60 | collect (cons op i)))) 61 | "Table of operator precedence.") 62 | 63 | (defun operator-char? (c) 64 | (nor (alpha-char-p c) 65 | (whitespacep c) 66 | (find c "-_"))) 67 | 68 | (defun dotted-operator? (sym) 69 | (let ((s (string sym))) 70 | (and (> (length s) 2) 71 | (let ((first-char (aref s 0)) 72 | (last-char (aref s (1- (length s))))) 73 | (and (eql #\. first-char) 74 | (eql #\. last-char)))))) 75 | 76 | (defun looks-like-operator? (sym) 77 | "Does SYM start and end with an operator char?" 78 | (let ((s (string sym))) 79 | (or (and (> (length s) 0) 80 | (every #'operator-char? s)) 81 | (dotted-operator? sym)))) 82 | 83 | (defun operator? (operator) 84 | (and (symbolp operator) 85 | (or (precedence operator) 86 | (unary? operator)))) 87 | 88 | (defun trim-dotted-operator (operator) 89 | (unless (operator? operator) 90 | (error "Not an operator: ~a." operator)) 91 | (if (dotted-operator? operator) 92 | (intern (slice (string operator) 1 -1) 93 | (symbol-package operator)) 94 | operator)) 95 | 96 | (defun precedence (operator) 97 | (or (gethash (assure operator operator) *precedence*) 98 | (and (looks-like-operator? operator) 99 | (1+ (precedence 'unary))))) 100 | 101 | (defun (setf precedence) (value operator) 102 | (setf (gethash (assure operator operator) *precedence*) 103 | (assure precedence value))) 104 | 105 | (defun save-operator (&key 106 | (name (required-argument 'name)) 107 | (from (required-argument 'from)) 108 | (right-associative 109 | (right-associative? from))) 110 | (setf (precedence name) (precedence from) 111 | (right-associative? name) right-associative)) 112 | 113 | (defun save-unary-operator (name) 114 | (setf (precedence name) 0 115 | (unary? name) t)) 116 | 117 | (defmacro declare-unary-operator (name) 118 | `(eval-when (:compile-toplevel :load-toplevel :execute) 119 | (save-unary-operator ',name))) 120 | 121 | (defmacro declare-binary-operator (new &body 122 | (&key 123 | (from (required-argument 'from)) 124 | (right-associative `(right-associative? ',from)))) 125 | `(eval-when (:compile-toplevel :load-toplevel :execute) 126 | ,(once-only (right-associative) 127 | `(save-operator 128 | :name ',new 129 | :from ',from 130 | :right-associative ,right-associative)))) 131 | 132 | (defun right-associative? (operator) 133 | (member operator *right-associative*)) 134 | 135 | (defun (setf right-associative?) (value operator) 136 | (if value 137 | (pushnew (assure operator operator) *right-associative*) 138 | (removef *right-associative* operator))) 139 | 140 | (defparameter *unary* 141 | '(- sqrt √)) 142 | 143 | (defun unary? (operator) 144 | (member operator *unary*)) 145 | 146 | (defun (setf unary?) (value operator) 147 | (if value 148 | (pushnew operator *unary*) 149 | (removef *unary* operator))) 150 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Infix-Math 2 | 3 | Infix-Math is a library that provides a special-purpose syntax for 4 | transcribing mathematical formulas into Lisp. 5 | 6 | Bitter experience has taught me that the more the formula on screen 7 | resembles the formula on paper, the better. The more the formula on 8 | screen resembles the formula on paper, the easier it is to prevent 9 | bugs from transcription errors. The easier it is to prevent 10 | transcription errors, the easier it is to trace the source of any bugs 11 | that do occur – because sometimes the formula is wrong. 12 | 13 | (Having to transcribe formulas from crooked, blurry scans of ancient 14 | pre-LaTeX typescripts is bad enough without having to parse operator 15 | precedence in your head.) 16 | 17 | Even if you end up rewriting the formula for speed or numerical 18 | stability, having the specification in an executable form is 19 | invaluable for reference and testing. 20 | 21 | ## Examples 22 | 23 | The macro `$` is the entry point into Infix-Math. 24 | 25 | ($ 2 + 2) => 4 26 | ($ 1 + 2 * 3) => 7 27 | 28 | Operator precedence parsing in Infix-Math is reliable – it uses 29 | Dijkstra’s [shunting yard][] algorithm. 30 | 31 | The parser automatically descends into function argument lists, which 32 | means that the total number of parentheses is never greater than it 33 | would be in a purely infix language. 34 | 35 | ($ (tan pi * (p - 1/2))) 36 | ≡ (tan (* pi (- p 1/2))) 37 | ≅ tan(pi*(p-0.5)) 38 | 39 | Common subexpression elimination is automatic and aggressive. All 40 | forms are assumed to be pure. Math does not have side effects. 41 | 42 | (macroexpand '($ 2 ^ 2x * 2 ^ 2x) 43 | => ‘(let ((#:subexp11325 (^ 2 (* 2 x)))) 44 | (* #:subexp11325 #:subexp11325)) 45 | 46 | Infix-Math knows about the following arithmetic and bitwise operators, 47 | in descending order of precedence. 48 | 49 | - unary -, sqrt 50 | - expt, log 51 | - *, /, rem, mod, floor, ffloor, ceiling, fceiling, truncate, 52 | ftruncate, round, fround, scale-float, gcd, lcm, atan 53 | - +, - 54 | - ash 55 | - logand, logandc1, logandc2, lognand 56 | - logxor, logeqv 57 | - logior, logorc1, logorc2, lognor 58 | - min, max 59 | - over 60 | 61 | Operations at the same level of precedence are always evaluated 62 | left-to-right. 63 | 64 | (+ 0.1d0 (+ 0.2d0 0.3d0)) => 0.6d0 65 | (+ (+ 0.1d0 0.2d0) 0.3d0) => 0.6000000000000001D0 66 | ($ 0.1d0 + 0.2d0 + 0.3d0) => 0.6000000000000001D0 67 | 68 | Parentheses can be used for grouping. 69 | 70 | ($ 0.1d0 + (0.2d0 + 0.3d0)) => 0.6d0 71 | 72 | Variables can be written with literal numbers as coefficients. 73 | 74 | ($ 2x) => 10 75 | ($ -2x) => 10 76 | 77 | Literal coefficients have very high priority. 78 | 79 | ($ 2 ^ 2 * x) ≡ (* (expt 2 2) x) => 20 80 | ($ 2 ^ 2x) ≡ (expt 2 (* 2 x)) => 1024 81 | 82 | A literal coefficient of 1 can be omitted. 83 | 84 | ($ -x) ≡ ($ -1x) ≡ (* -1 x) 85 | 86 | Literal coefficients are parsed as decimals, rather than floats. 87 | 88 | ($ 1.5x) ≡ (* 3/2 x) 89 | 90 | You can also use fractions as literal coefficients. 91 | 92 | ($ 1/3x) ≡ (* 1/3 x) 93 | 94 | Among other things, literal coefficients are very convenient for units 95 | of measurement. 96 | 97 | (The idea for literal coefficients comes from Julia.) 98 | 99 | ## Symbols 100 | 101 | Infix-Math exports only five symbols: `$`, `^`, `over`, and two macros 102 | for declaring operators: `declare-unary-operator` and 103 | `declare-binary-operator`. 104 | 105 | The symbol `^` is just a shorthand for `expt`. 106 | 107 | ($ 1 + 2 * 3 ^ 4) => 163 108 | 109 | (`^` is from Dylan.) 110 | 111 | The symbol `over` represents the same operation as `/`, but at a much 112 | lower priority. Using `over` lets you avoid introducing parentheses 113 | for grouping when transcribing fractions. 114 | 115 | (setf x 5) 116 | ($ x * 2 / x * 3) ≡ (* (/ (* x 2) x) 3) => 6 117 | ($ (x * 2) / (x * 3)) ≡ (/ (* x 2) (* x 3)) => 2/3 118 | ($ x * 2 over x * 3) ≡ (/ (* x 2) (* x 3)) => 2/3 119 | 120 | You can also spell `over` with a series of dashes or underscores. 121 | 122 | ($ x * 2 123 | ----- 124 | x * 3) 125 | => 2/3 126 | 127 | If you want more math symbols, the package `infix-math/symbols` 128 | provides a few more. 129 | 130 | ## Calculator 131 | 132 | You can use Infix-Math to turn your REPL into a calculator. 133 | 134 | First, load the `infix-math/calc` system: 135 | 136 | (asdf:load-system "infix-math/calc") 137 | 138 | Then, at the REPL, start the calculator: 139 | 140 | (infix-math/calc:calc) 141 | 142 | This will put you at a calculator prompt. You can type in mathematical expressions directly: 143 | 144 | $> 2 + 2 145 | 4 146 | 147 | A single form entered at the REPL is interpreted as ordinary CL. 148 | 149 | $> *package* 150 | :infix-math/calc-user 151 | 152 | You can assign to variables using the `<-` operator. 153 | 154 | $> x <- 2 + 2 155 | 4 156 | $> x 157 | 4 158 | 159 | Certain one-letter variables are provided for you to assign to, such as `x`, `y`, and `z`. You can see the full list by evaluating `:v` at the calculator prompt. 160 | 161 | To quit, use `:q`. The value of the last expression evaluated will be returned. 162 | 163 | $> 2 + 2 164 | 4 165 | $> :q 166 | 4 167 | CL-USER> * 168 | 4 169 | 170 | ## Extending 171 | 172 | Infix-Math is easily to extend. In fact, you may not even need to 173 | extend it. 174 | 175 | Any symbol that consists entirely of operator characters is 176 | interpreted as an infix operator, with the highest non-unary priority. 177 | Operator characters are anything but dashes, underscores, whitespace 178 | or alphanumeric characters. 179 | 180 | (defun <*> (x y) 181 | "Matrix multiplication, maybe." 182 | ...) 183 | 184 | (macroexpand '($ x * y <*> z)) => (* x (<*> y z)) 185 | 186 | (This approach is taken from Haskell.) 187 | 188 | You can use any function as an infix operator by surrounding its name 189 | with dots. 190 | 191 | (defun choose (n k) 192 | "Binomial coefficient, maybe." 193 | ...) 194 | 195 | (macroexpand '($ n .choose. k)) => '(choose n k) 196 | 197 | Again, the operator has the highest non-unary priority. 198 | 199 | (This approach is taken from Haskell and Fortran.) 200 | 201 | If you need more flexibility, declare the operators using 202 | `declare-binary-operator` or `declare-unary-operator`. 203 | 204 | To declare a unary operator: 205 | 206 | (declare-unary-operator √) 207 | 208 | To copy the precedence of another operator: 209 | 210 | (declare-binary-operator <*> :from *) 211 | 212 | To declare an operator right-associative: 213 | 214 | (declare-binary-operator ? 215 | :from * 216 | :right-associative t) 217 | 218 | [FMA]: https://en.wikipedia.org/wiki/Fused_multiply%E2%80%93add 219 | [Julia]: http://julialang.org 220 | [shunting yard]: https://en.wikipedia.org/wiki/Shunting-yard_algorithm 221 | -------------------------------------------------------------------------------- /infix-math.lisp: -------------------------------------------------------------------------------- 1 | ;;;; infix-math.lisp 2 | 3 | (defpackage #:infix-math/infix-math 4 | (:nicknames :infix-math) 5 | (:use #:cl 6 | :alexandria 7 | :serapeum 8 | :infix-math/symbols 9 | :infix-math/data) 10 | (:import-from :wu-decimal :parse-decimal) 11 | (:import-from :parse-number) 12 | (:export 13 | :$ :over :^ 14 | :declare-unary-operator 15 | :declare-binary-operator)) 16 | 17 | (in-package #:infix-math) 18 | 19 | (defun precedence< (op1 op2) 20 | (if (right-associative? op1) 21 | (> (precedence op1) (precedence op2)) 22 | (>= (precedence op1) (precedence op2)))) 23 | 24 | (defun precedence= (op1 op2) 25 | (= (precedence op1) (precedence op2))) 26 | 27 | (defun make-node (tree operator) 28 | (let ((operator (trim-dotted-operator operator))) 29 | (destructuring-bind (x y . rest) tree 30 | (cons (list operator y x) rest)))) 31 | 32 | (define-modify-macro nodef (operator) make-node) 33 | 34 | (defun shunting-yard (expression &aux tree stack) 35 | (let ((last-token :start)) 36 | (dolist (token expression) 37 | (if (operator? token) 38 | (progn 39 | (when (and (unary? token) 40 | (or (eq last-token :start) 41 | (operator? last-token))) 42 | (push token tree) 43 | (setf token 'unary)) 44 | (loop while (and stack (precedence< token (car stack))) 45 | do (nodef tree (pop stack)) 46 | finally (push token stack))) 47 | (push token tree)) 48 | (setf last-token token))) 49 | (when stack 50 | (dolist (op stack) 51 | (nodef tree op))) 52 | (car tree)) 53 | 54 | (defun valid? (expression) 55 | ;; Test in ascending order of expense. 56 | (and (consp expression) 57 | (cdr expression) 58 | (oddp (length expression)) 59 | (loop for i from 0 60 | for elt in expression 61 | always (if (oddp i) 62 | (operator? elt) 63 | (not (operator? elt)))))) 64 | 65 | (defun parse-expression (expression) 66 | (when expression 67 | (shunting-yard expression))) 68 | 69 | (defun eliminate-common-subexpressions (form &optional env) 70 | (declare (ignore env)) 71 | (local 72 | (def exprs (dict)) 73 | 74 | ;; TODO Expand symbol macros, but without shadowing functions 75 | ;; which are also the names of symbol macros. (Maybe use 76 | ;; macroexpand-dammit?). 77 | (defun rec (tree) 78 | (when (listp tree) 79 | (let ((count (incf (gethash tree exprs 0)))) 80 | ;; No subexps of subexps. 81 | (when (and (listp tree) (= count 1)) 82 | (mapcar #'rec tree))))) 83 | 84 | (rec form) 85 | 86 | (def repeats 87 | (mapcar #'car 88 | (filter (op (> (cdr _) 1)) 89 | (hash-table-alist exprs)))) 90 | 91 | (def gensyms 92 | (make-gensym-list (length repeats) (string 'subexp))) 93 | 94 | (if repeats 95 | ;; Recurse; there could still be repeated subforms in the 96 | ;; bindings list. E.g. ($ 2 ^ 2x * 3 ^ 2x * 3 ^ 2x), where the 97 | ;; first pass isolates 3^2x and 2x, and the second pass 98 | ;; isolates 2x in 3^2x. 99 | (eliminate-common-subexpressions 100 | `(let ,(mapcar #'list gensyms repeats) 101 | ,(sublis (mapcar #'cons repeats gensyms) form 102 | :test #'equal))) 103 | form))) 104 | 105 | (defun expand-expression (exprs) 106 | (mapcar 107 | (lambda (expr) 108 | (cond ((atom expr) 109 | expr) 110 | ((operator? (second expr)) 111 | (parse-expression (expand-expression expr))) 112 | ;; E.g. (- x * y), (gamma x - y) 113 | ((operator? (third expr)) 114 | (cons (first expr) 115 | (~> expr 116 | rest 117 | expand-expression 118 | parse-expression 119 | list))) 120 | (t (expand-expression expr)))) 121 | exprs)) 122 | 123 | (defun expand-fancy-symbols (form) 124 | "Expand -x into (- x) and 2x into (* 2 x). 125 | 126 | Literal coefficients have the same precedence as unary operators. 127 | 128 | Literal coefficients are assumed to be in base 10." 129 | (local 130 | (defun expand-symbol (sym) 131 | (let ((package (symbol-package sym)) 132 | (str (string sym))) 133 | (cond ((< (length str) 2) sym) 134 | ;; A practical optimization: skip trying to parse 135 | ;; a coefficient if there's clearly no coefficient there. 136 | ((alpha-char-p (aref str 0)) sym) 137 | ;; Replace a series of dashes or underscores with 138 | ;; `over'. 139 | ((or (every (curry #'eql #\-) str) 140 | (every (curry #'eql #\_) str)) 141 | 'over) 142 | (t (multiple-value-bind (coefficient end) 143 | (parse-coefficient str) 144 | (cond (coefficient 145 | (let* ((name (subseq str end)) 146 | (sym2 (intern name package))) 147 | `(* ,coefficient ,sym2))) 148 | ((string^= "!" str) 149 | (let* ((name (subseq str 1)) 150 | (sym2 (intern name package))) 151 | `(! ,sym2))) 152 | ((string^= "√" str) 153 | (let* ((name (subseq str 1)) 154 | (sym2 (intern name package))) 155 | `(sqrt ,sym2))) 156 | (t sym))))))) 157 | 158 | (defun rec (form) 159 | (if (atom form) 160 | (if (and (symbolp form) 161 | (not (null form)) 162 | (not (eql (symbol-package form) 163 | (find-package :common-lisp)))) 164 | (expand-symbol form) 165 | form) 166 | (cons (rec (car form)) 167 | (rec (cdr form))))) 168 | 169 | (rec form))) 170 | 171 | (defun parse-coefficient (str) 172 | (let (fraction? decimal? digits? (i 0)) 173 | (let ((out 174 | (with-input-from-string (in str) 175 | (with-output-to-string (out) 176 | (loop for c = (read-char in nil) 177 | for dot = (eql c #\.) 178 | for slash = (eql c #\/) 179 | for sign = (find c "-+") 180 | for digit = (digit-char-p c 10) 181 | while (and c (or digit dot slash sign)) 182 | do (write-char c out) 183 | (cond (slash 184 | (when decimal? 185 | (return-from parse-coefficient 186 | (values nil i))) 187 | (setf fraction? t)) 188 | ;; But: some Lisps understand 1/1.5. 189 | (dot 190 | (when fraction? 191 | (return-from parse-coefficient 192 | (values nil i))) 193 | (setf decimal? t)) 194 | (digit 195 | (setf digits? t))) 196 | (incf i)))))) 197 | (values 198 | (cond (fraction? 199 | (parse-number out)) 200 | (decimal? 201 | (parse-decimal out :junk-allowed t)) 202 | (digits? 203 | (parse-integer out :junk-allowed t)) 204 | ((string^= "-" str) 205 | (values -1 1)) 206 | ((string^= "+" str) 207 | (values +1 1))) 208 | i)))) 209 | 210 | (defmacro $ (&rest formula &environment env) 211 | "Compile a mathematical formula in infix notation." 212 | (~> formula 213 | expand-fancy-symbols 214 | expand-expression 215 | parse-expression 216 | (eliminate-common-subexpressions env))) 217 | --------------------------------------------------------------------------------