changeset 267: | f3d814fb136a |
parent: | 4ba88cac5bc7 |
child: | a0dfde3cb3c4 |
author: | Richard Westhaver <ellis@rwest.io> |
date: | Sat, 06 Apr 2024 22:53:46 -0400 |
permissions: | -rw-r--r-- |
description: | db upgrades, alik, ignoring c files (for now) |
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: |
122
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
6 | (in-package :std) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
7 | |
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 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
20 | (declaim (type cons *white-space-characters*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
21 | (defparameter *white-space-characters* |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
22 | '(#\Space #\Tab #\Return #\Linefeed) |
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)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
39 | (type string string) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
40 | (type fixnum start end radix)) |
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)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
48 | ;; 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
|
49 | ;; 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
|
50 | ;; beforehand we count it here |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
51 | (let ((relevant-digits (- end-pos start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
52 | (loop :for pos :from (- end-pos 1) :downto start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
53 | :while (member (char string pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
54 | *white-space-characters*) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
55 | :count 1)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
56 | (cons integer relevant-digits)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
57 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
58 | (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
|
59 | "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
|
60 | 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
|
61 | 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
|
62 | 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
|
63 | (declare (optimize (speed 3) (safety 1)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
64 | (type string string) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
65 | (type fixnum start end radix)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
66 | (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
|
67 | for point in splitting-points |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
68 | for right = point |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
69 | 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
|
70 | left |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
71 | right |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
72 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
73 | into integers |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
74 | finally (return |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
75 | (nconc integers |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
76 | (list |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
77 | (parse-integer-and-places string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
78 | left |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
79 | end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
80 | :radix radix |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
81 | ))))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
82 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
83 | (declaim (inline number-value places)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
84 | (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
|
85 | (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
|
86 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
87 | ;; 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
|
88 | ;; #xFF.AA |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
89 | ;; #o12e3 |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
90 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
91 | ;; 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
|
92 | ;; #10r3.2 |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
93 | ;; #2r 11 |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
94 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
95 | (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
|
96 | ((: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
|
97 | *read-default-float-format*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
98 | "Given a string, and start, end, and radix parameters, produce a number according to the syntax definitions in the Common Lisp Hyperspec." |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
99 | (flet ((invalid-number (reason) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
100 | (error 'invalid-number |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
101 | :value (subseq string start end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
102 | :reason reason))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
103 | (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
|
104 | (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
|
105 | (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
|
106 | (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
|
107 | (\)-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
|
108 | (when (or (not \(-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
109 | (not \)-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
110 | (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
|
111 | (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
|
112 | (invalid-number "Mismatched/missing parenthesis")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
113 | (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
|
114 | :start (1+ \(-pos) :end \)-pos))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
115 | (unless real-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
116 | (invalid-number "Missing real part")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
117 | (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
|
118 | :start (1+ real-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
119 | :end \)-pos))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
120 | (unless delimiting-space |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
121 | (invalid-number "Missing imaginary part")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
122 | (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
|
123 | :start (1+ delimiting-space) |
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 img-pos |
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-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
|
128 | :start (1+ img-pos) |
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 | (complex (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
131 | :start real-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
132 | :end delimiting-space |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
133 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
134 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
135 | :start img-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
136 | :end (or img-end-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
137 | \)-pos) |
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 :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
|
140 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
141 | (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
|
142 | ((: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
|
143 | *read-default-float-format*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
144 | "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." |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
145 | (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
|
146 | (case (char string start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
147 | ((#\-) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
148 | (* -1 (parse-positive-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
149 | :start (1+ start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
150 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
151 | :radix radix))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
152 | ((#\+) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
153 | (parse-positive-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
154 | :start (1+ start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
155 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
156 | :radix radix)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
157 | ((#\#) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
158 | (case (char string (1+ start)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
159 | ((#\x #\X) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
160 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
161 | :start (+ start 2) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
162 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
163 | :radix 16)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
164 | ((#\b #\B) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
165 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
166 | :start (+ start 2) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
167 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
168 | :radix 2)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
169 | ((#\o #\O) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
170 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
171 | :start (+ start 2) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
172 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
173 | :radix 8)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
174 | (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
|
175 | (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
|
176 | :start (1+ start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
177 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
178 | :key #'char-downcase))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
179 | (unless r-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
180 | (error 'invalid-number |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
181 | :value (subseq string start end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
182 | :reason "Missing R in #radixR")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
183 | (parse-real-number string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
184 | :start (1+ r-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
185 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
186 | :radix (parse-integer string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
187 | :start (1+ start) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
188 | :end r-pos))))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
189 | (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
|
190 | :start start |
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 radix))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
193 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
194 | (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
|
195 | "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
|
196 | (case char |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
197 | ((#\d #\D) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
198 | 10.0d0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
199 | ((#\e #\E) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
200 | (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
|
201 | ((#\f #\F) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
202 | 10.0f0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
203 | ((#\s #\S) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
204 | 10.0s0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
205 | ((#\l #\L) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
206 | 10.0l0))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
207 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
208 | (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
|
209 | "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
|
210 | 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
|
211 | integer part, fractional part, and exponent respectively." |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
212 | (let* ((base (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
|
213 | (exp (expt base (number-value exp-place)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
214 | (+ (* exp (number-value whole-place)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
215 | (/ (* exp (number-value frac-place)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
216 | (expt (float radix base) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
217 | (places frac-place)))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
218 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
219 | (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
|
220 | "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
|
221 | 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
|
222 | the exponent respectively." |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
223 | (* (number-value whole-place) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
224 | (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
|
225 | (number-value exp-place)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
226 | |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
227 | (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
|
228 | ((: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
|
229 | *read-default-float-format*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
230 | "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." |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
231 | (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
|
232 | (first-char (char string start))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
233 | (flet ((invalid-number (reason) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
234 | (error 'invalid-number |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
235 | :value (subseq string start end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
236 | :reason reason))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
237 | (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
|
238 | :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
|
239 | :start start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
240 | :end end) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
241 | 0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
242 | :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
|
243 | :start start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
244 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
245 | :from-end t)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
246 | (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
|
247 | (case first-char |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
248 | ((#\-) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
249 | (invalid-number "Invalid usage of -")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
250 | ((#\/) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
251 | (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
|
252 | ((#\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
|
253 | (when (= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
254 | (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
|
255 | (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
|
256 | (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
|
257 | for char = (char string index) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
258 | do (case char |
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 | (if /-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
261 | (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
|
262 | (setf /-pos index))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
263 | ((#\.) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
264 | (if .-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
265 | (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
|
266 | (setf .-pos index))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
267 | ((#\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
|
268 | ;; 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
|
269 | ;; 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
|
270 | ;; 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
|
271 | (when (>= (+ 10 |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
272 | (- (char-code (char-upcase char)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
273 | (char-code #\A))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
274 | radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
275 | (when exp-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
276 | (invalid-number |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
277 | "Multiple exponent-markers in number")) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
278 | (setf exp-pos index) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
279 | (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
|
280 | when (eql index (1- end)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
281 | do (case char |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
282 | ((#\/) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
283 | (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
|
284 | ((#\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
|
285 | (when (= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
286 | (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
|
287 | (cond ((and /-pos .-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
288 | (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
|
289 | ((and /-pos exp-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
290 | (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
|
291 | ((and .-pos exp-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
292 | (if (< exp-pos .-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
293 | (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
|
294 | (if (/= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
295 | (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
|
296 | (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
|
297 | (parse-integers string start end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
298 | (list .-pos exp-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
299 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
300 | (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
|
301 | (exp-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
302 | (if (/= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
303 | (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
|
304 | (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
|
305 | (parse-integers string start end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
306 | (list exp-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
307 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
308 | (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
|
309 | (/-pos |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
310 | (multiple-value-bind (numerator denominator) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
311 | (parse-integers string start end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
312 | (list /-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
313 | :radix radix) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
314 | (if (>= (number-value denominator) 0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
315 | (/ (number-value numerator) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
316 | (number-value denominator)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
317 | (invalid-number "Misplaced - sign")))) |
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 | (if (/= radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
320 | (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
|
321 | (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
|
322 | (parse-integers string start end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
323 | (list .-pos) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
324 | :radix 10) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
325 | (cond |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
326 | ((minusp (places frac-part)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
327 | (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
|
328 | (zerop (places whole-part))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
329 | (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
|
330 | (number-value whole-part))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
331 | ((>= (number-value frac-part) 0) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
332 | (coerce (+ (number-value whole-part) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
333 | (/ (number-value frac-part) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
334 | (expt 10 (places frac-part)))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
335 | *read-default-float-format*)) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
336 | (t |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
337 | (invalid-number "Misplaced - sign")))))) |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
338 | (t |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
339 | (values (parse-integer string |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
340 | :start start |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
341 | :end end |
4ba88cac5bc7
num/parse, added DAT system, net/fetch, time/local, refactored trees
ellis <ellis@rwest.io>
parents:
diff
changeset
|
342 | :radix radix)))))))) |