changeset 698: | 96958d3eb5b0 |
parent: | 0af47621fa8b |
author: | Richard Westhaver <ellis@rwest.io> |
date: | Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: | -rw-r--r-- |
description: | fixes |
267
f3d814fb136a
db upgrades, alik, ignoring c files (for now)
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
1 | ;;; std/num/parse.lisp --- Number parsing functions |
f3d814fb136a
db upgrades, alik, ignoring c files (for now)
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
2 | |
f3d814fb136a
db upgrades, alik, ignoring c files (for now)
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
3 | ;; |
f3d814fb136a
db upgrades, alik, ignoring c files (for now)
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
4 | |
f3d814fb136a
db upgrades, alik, ignoring c files (for now)
Richard Westhaver <ellis@rwest.io>
parents:
122
diff
changeset
|
5 | ;;; Code: |
291 | 6 | (in-package :std/num) |
336 | 7 | (declaim (optimize (speed 3) (safety 3))) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
8 | (define-condition invalid-number (parse-error) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
9 | ((value :reader invalid-number-value |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
10 | :initarg :value |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
11 | :initform nil) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
12 | (reason :reader invalid-number-reason |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
13 | :initarg :reason |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
14 | :initform "Not specified")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
15 | (:report (lambda (c s) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
16 | (format s "Invalid number: ~S [Reason: ~A]" |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
17 | (invalid-number-value c) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
18 | (invalid-number-reason c))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
19 | |
336 | 20 | (declaim (type (cons character) *white-space-characters*)) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
21 | (defparameter *white-space-characters* |
336 | 22 | (list #\Space #\Tab #\Return #\Linefeed) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
23 | "A list of all of the whitespace characters.") |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
24 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
25 | (declaim (inline white-space-p)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
26 | (defun white-space-p (x) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
27 | "Is the given character a whitespace character?" |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
28 | (declare (optimize (speed 3) (safety 0)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
29 | (type character x)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
30 | (and (find x *white-space-characters*) t)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
31 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
32 | (declaim (inline parse-integer-and-places)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
33 | (defun parse-integer-and-places (string start end &key (radix 10)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
34 | "Parse an integer and return a 'parsed-integer'. This is an object |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
35 | whose numerical value can be accessed with the function |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
36 | number-value and whose length can be accessed with the function |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
37 | place." |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
38 | (declare (optimize (speed 3) (safety 1)) |
336 | 39 | (type simple-string string) |
40 | (fixnum start end radix)) |
|
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
41 | (multiple-value-bind (integer end-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
42 | (if (= start end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
43 | (values 0 0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
44 | (parse-integer string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
45 | :start start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
46 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
47 | :radix radix)) |
336 | 48 | (declare (fixnum integer end-pos)) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
49 | ;; cl:parse-integer will consume trailing whitespace, thus end-pos may be |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
50 | ;; larger than the number of digits. Instead of trimming whitespace |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
51 | ;; beforehand we count it here |
336 | 52 | (let* ((count (loop for pos from (- end-pos 1) downto start |
53 | while (member (char string pos) |
|
54 | *white-space-characters* |
|
55 | :test 'char=) |
|
56 | :count 1)) |
|
57 | (relevant-digits (the fixnum (- end-pos start count)))) |
|
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
58 | (cons integer relevant-digits)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
59 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
60 | (defun parse-integers (string start end splitting-points &key (radix 10)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
61 | "Parse a string containing multiple integers where SPLITTING-POINTS |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
62 | is a list of locations where each location is inbetween |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
63 | consecutive integers. This will return a list of parsed-integers. |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
64 | The last parsed-integer will have a negative value for its length." |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
65 | (declare (optimize (speed 3) (safety 1)) |
336 | 66 | (type simple-string string) |
67 | (fixnum start end radix) |
|
68 | (list splitting-points)) |
|
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
69 | (values-list (loop for left = start then (1+ right) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
70 | for point in splitting-points |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
71 | for right = point |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
72 | collect (parse-integer-and-places string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
73 | left |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
74 | right |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
75 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
76 | into integers |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
77 | finally (return |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
78 | (nconc integers |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
79 | (list |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
80 | (parse-integer-and-places string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
81 | left |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
82 | end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
83 | :radix radix |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
84 | ))))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
85 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
86 | (declaim (inline number-value places)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
87 | (defun number-value (x) "Get the value of a parsed-integer." (car x)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
88 | (defun places (x) "Get the length of a parsed-integer." (cdr x)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
89 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
90 | ;; Numbers which could've been parsed, but intentionally crippled not to: |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
91 | ;; #xFF.AA |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
92 | ;; #o12e3 |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
93 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
94 | ;; Numbers which CL doesn't parse, but this does: |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
95 | ;; #10r3.2 |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
96 | ;; #2r 11 |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
97 | (defun parse-number (string &key (start 0) (end nil) (radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
98 | ((:float-format *read-default-float-format*) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
99 | *read-default-float-format*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
100 | "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec." |
336 | 101 | (declare (type simple-string string)) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
102 | (flet ((invalid-number (reason) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
103 | (error 'invalid-number |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
104 | :value (subseq string start end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
105 | :reason reason))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
106 | (let ((end (or end (length string)))) |
336 | 107 | (declare (fixnum start end radix)) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
108 | (if (and (eql (char string start) #\#) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
109 | (member (char string (1+ start)) '(#\C #\c))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
110 | (let ((\(-pos (position #\( string :start start :end end)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
111 | (\)-pos (position #\) string :start start :end end))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
112 | (when (or (not \(-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
113 | (not \)-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
114 | (position #\( string :start (1+ \(-pos) :end end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
115 | (position #\) string :start (1+ \)-pos) :end end)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
116 | (invalid-number "Mismatched/missing parenthesis")) |
336 | 117 | |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
118 | (let ((real-pos (position-if-not #'white-space-p string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
119 | :start (1+ \(-pos) :end \)-pos))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
120 | (unless real-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
121 | (invalid-number "Missing real part")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
122 | (let ((delimiting-space (position-if #'white-space-p string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
123 | :start (1+ real-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
124 | :end \)-pos))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
125 | (unless delimiting-space |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
126 | (invalid-number "Missing imaginary part")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
127 | (let ((img-pos (position-if-not #'white-space-p string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
128 | :start (1+ delimiting-space) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
129 | :end \)-pos))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
130 | (unless img-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
131 | (invalid-number "Missing imaginary part")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
132 | (let ((img-end-pos (position-if #'white-space-p string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
133 | :start (1+ img-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
134 | :end \)-pos))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
135 | (complex (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
136 | :start real-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
137 | :end delimiting-space |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
138 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
139 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
140 | :start img-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
141 | :end (or img-end-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
142 | \)-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
143 | :radix radix))))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
144 | (parse-real-number string :start start :end end :radix radix))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
145 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
146 | (defun parse-real-number (string &key (start 0) (end nil) (radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
147 | ((:float-format *read-default-float-format*) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
148 | *read-default-float-format*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
149 | "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec -- except for complex numbers." |
336 | 150 | (declare (simple-string string)) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
151 | (let ((end (or end (length string)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
152 | (case (char string start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
153 | ((#\-) |
336 | 154 | (* -1 (the fixnum (parse-positive-real-number string |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
155 | :start (1+ start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
156 | :end end |
336 | 157 | :radix radix)))) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
158 | ((#\+) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
159 | (parse-positive-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
160 | :start (1+ start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
161 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
162 | :radix radix)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
163 | ((#\#) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
164 | (case (char string (1+ start)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
165 | ((#\x #\X) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
166 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
167 | :start (+ start 2) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
168 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
169 | :radix 16)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
170 | ((#\b #\B) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
171 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
172 | :start (+ start 2) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
173 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
174 | :radix 2)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
175 | ((#\o #\O) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
176 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
177 | :start (+ start 2) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
178 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
179 | :radix 8)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
180 | (t (if (digit-char-p (char string (1+ start))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
181 | (let ((r-pos (position #\r string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
182 | :start (1+ start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
183 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
184 | :key #'char-downcase))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
185 | (unless r-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
186 | (error 'invalid-number |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
187 | :value (subseq string start end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
188 | :reason "Missing R in #radixR")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
189 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
190 | :start (1+ r-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
191 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
192 | :radix (parse-integer string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
193 | :start (1+ start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
194 | :end r-pos))))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
195 | (t (parse-positive-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
196 | :start start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
197 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
198 | :radix radix))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
199 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
200 | (defun base-for-exponent-marker (char) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
201 | "Return the base for an exponent-marker." |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
202 | (case char |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
203 | ((#\d #\D) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
204 | 10.0d0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
205 | ((#\e #\E) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
206 | (coerce 10 *read-default-float-format*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
207 | ((#\f #\F) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
208 | 10.0f0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
209 | ((#\s #\S) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
210 | 10.0s0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
211 | ((#\l #\L) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
212 | 10.0l0))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
213 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
214 | (defun make-float/frac (radix exp-marker whole-place frac-place exp-place) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
215 | "Create a float using EXP-MARKER as the exponent-marker and the |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
216 | parsed-integers WHOLE-PLACE, FRAC-PLACE, and EXP-PLACE as the |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
217 | integer part, fractional part, and exponent respectively." |
336 | 218 | (declare (fixnum radix)) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
219 | (let* ((base (base-for-exponent-marker exp-marker)) |
336 | 220 | (exp (expt base (number-value exp-place)))) |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
221 | (+ (* exp (number-value whole-place)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
222 | (/ (* exp (number-value frac-place)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
223 | (expt (float radix base) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
224 | (places frac-place)))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
225 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
226 | (defun make-float/whole (exp-marker whole-place exp-place) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
227 | "Create a float where EXP-MARKER is the exponent-marker and the |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
228 | parsed-integers WHOLE-PLACE and EXP-PLACE as the integer part and |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
229 | the exponent respectively." |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
230 | (* (number-value whole-place) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
231 | (expt (base-for-exponent-marker exp-marker) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
232 | (number-value exp-place)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
233 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
234 | (defun parse-positive-real-number (string &key (start 0) (end nil) (radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
235 | ((:float-format *read-default-float-format*) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
236 | *read-default-float-format*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
237 | "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec -- except for complex numbers and negative numbers." |
336 | 238 | (declare (simple-string string) |
239 | (fixnum radix)) |
|
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
240 | (let ((end (or end (length string))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
241 | (first-char (char string start))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
242 | (flet ((invalid-number (reason) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
243 | (error 'invalid-number |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
244 | :value (subseq string start end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
245 | :reason reason))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
246 | (when (position-if #'white-space-p string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
247 | :start (or (position-if-not #'white-space-p string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
248 | :start start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
249 | :end end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
250 | 0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
251 | :end (position-if-not #'white-space-p string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
252 | :start start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
253 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
254 | :from-end t)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
255 | (invalid-number "Whitespace inside the number")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
256 | (case first-char |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
257 | ((#\-) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
258 | (invalid-number "Invalid usage of -")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
259 | ((#\/) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
260 | (invalid-number "/ at beginning of number")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
261 | ((#\d #\D #\e #\E #\l #\L #\f #\F #\s #\S) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
262 | (when (= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
263 | (invalid-number "Exponent-marker at beginning of number")))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
264 | (let (/-pos .-pos exp-pos exp-marker) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
265 | (loop for index from start below end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
266 | for char = (char string index) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
267 | do (case char |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
268 | ((#\/) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
269 | (if /-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
270 | (invalid-number "Multiple /'s in number") |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
271 | (setf /-pos index))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
272 | ((#\.) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
273 | (if .-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
274 | (invalid-number "Multiple .'s in number") |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
275 | (setf .-pos index))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
276 | ((#\e #\E #\f #\F #\s #\S #\l #\L #\d #\D) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
277 | ;; We should only execute this if the base is |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
278 | ;; not used for the given radix (ie the digit |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
279 | ;; e is valid in base 15 and up). |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
280 | (when (>= (+ 10 |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
281 | (- (char-code (char-upcase char)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
282 | (char-code #\A))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
283 | radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
284 | (when exp-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
285 | (invalid-number |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
286 | "Multiple exponent-markers in number")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
287 | (setf exp-pos index) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
288 | (setf exp-marker (char-downcase char))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
289 | when (eql index (1- end)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
290 | do (case char |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
291 | ((#\/) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
292 | (invalid-number "/ at end of number")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
293 | ((#\d #\D #\e #\E #\s #\S #\l #\L #\f #\F) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
294 | (when (= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
295 | (invalid-number "Exponent-marker at end of number"))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
296 | (cond ((and /-pos .-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
297 | (invalid-number "Both . and / cannot be present simultaneously")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
298 | ((and /-pos exp-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
299 | (invalid-number "Both an exponent-marker and / cannot be present simultaneously")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
300 | ((and .-pos exp-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
301 | (if (< exp-pos .-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
302 | (invalid-number "Exponent-markers must occur after . in number") |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
303 | (if (/= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
304 | (invalid-number "Only decimal numbers can contain exponent-markers or decimal points") |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
305 | (multiple-value-bind (whole-place frac-place exp-place) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
306 | (parse-integers string start end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
307 | (list .-pos exp-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
308 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
309 | (make-float/frac radix exp-marker whole-place frac-place exp-place))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
310 | (exp-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
311 | (if (/= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
312 | (invalid-number "Only decimals can contain exponent-markers") |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
313 | (multiple-value-bind (whole-place exp-place) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
314 | (parse-integers string start end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
315 | (list exp-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
316 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
317 | (make-float/whole exp-marker whole-place exp-place)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
318 | (/-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
319 | (multiple-value-bind (numerator denominator) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
320 | (parse-integers string start end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
321 | (list /-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
322 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
323 | (if (>= (number-value denominator) 0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
324 | (/ (number-value numerator) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
325 | (number-value denominator)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
326 | (invalid-number "Misplaced - sign")))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
327 | (.-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
328 | (if (/= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
329 | (invalid-number "Only decimal numbers can contain decimal points") |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
330 | (multiple-value-bind (whole-part frac-part) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
331 | (parse-integers string start end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
332 | (list .-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
333 | :radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
334 | (cond |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
335 | ((minusp (places frac-part)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
336 | (if (and (zerop (number-value whole-part)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
337 | (zerop (places whole-part))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
338 | (invalid-number "Only the . is present") |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
339 | (number-value whole-part))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
340 | ((>= (number-value frac-part) 0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
341 | (coerce (+ (number-value whole-part) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
342 | (/ (number-value frac-part) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
343 | (expt 10 (places frac-part)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
344 | *read-default-float-format*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
345 | (t |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
346 | (invalid-number "Misplaced - sign")))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
347 | (t |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
348 | (values (parse-integer string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
349 | :start start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
350 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
351 | :radix radix)))))))) |