Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
52168c78
Commit
52168c78
authored
20 years ago
by
rtoy
Browse files
Options
Downloads
Patches
Plain Diff
Oops. Remove unused code. Add a couple of comments.
parent
4958e03b
No related branches found
No related tags found
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
code/print.lisp
+1
-39
1 addition, 39 deletions
code/print.lisp
code/reader.lisp
+10
-435
10 additions, 435 deletions
code/reader.lisp
with
11 additions
and
474 deletions
code/print.lisp
+
1
−
39
View file @
52168c78
...
@@ -5,7 +5,7 @@
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.8
8
2004/04/22 14:
26
:2
7
rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.8
9
2004/04/22 14:
38
:2
5
rtoy Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -1673,44 +1673,6 @@
...
@@ -1673,44 +1673,6 @@
output-float-free-format-exponent-min
output-float-free-format-exponent-min
output-float-free-format-exponent-max
)))))))
output-float-free-format-exponent-max
)))))))
#+
(
or
)
(
defmacro
output-float-free-format-p
(
x
)
"Returns true if x can be printed in free format, as per ANSI CL."
(
loop
with
x-var
=
(
gensym
)
for
type
in
'
(
short-float
single-float
double-float
long-float
)
collect
`
(
,
type
(
and
(
>=
,
x-var
,
(
coerce
output-float-free-format-min
type
))
(
<
,
x-var
,
(
coerce
output-float-free-format-max
type
))))
into
clauses
finally
(
return
`
(
let
((
,
x-var
,
x
))
(
etypecase
,
x-var
,@
clauses
)))))
#+
(
or
)
(
defun
output-float-aux
(
x
stream
)
(
if
(
output-float-free-format-p
x
)
;;free format
(
multiple-value-bind
(
str
len
lpoint
tpoint
)
(
flonum-to-string
x
)
(
declare
(
ignore
len
))
(
when
lpoint
(
write-char
#\0
stream
))
(
write-string
str
stream
)
(
when
tpoint
(
write-char
#\0
stream
))
(
print-float-exponent
x
0
stream
))
;;exponential format
(
multiple-value-bind
(
f
ex
)
(
scale-exponent
x
)
(
multiple-value-bind
(
str
len
lpoint
tpoint
)
(
flonum-to-string
f
nil
nil
1
)
(
declare
(
ignore
len
))
(
when
lpoint
(
write-char
#\0
stream
))
(
write-string
str
stream
)
(
when
tpoint
(
write-char
#\0
stream
))
;; subtract out scale factor of 1 passed to flonum-to-string
(
print-float-exponent
x
(
1-
ex
)
stream
)))))
;; Smallest possible (unbiased) exponents
;; Smallest possible (unbiased) exponents
(
defconstant
double-float-min-e
(
defconstant
double-float-min-e
...
...
This diff is collapsed.
Click to expand it.
code/reader.lisp
+
10
−
435
View file @
52168c78
...
@@ -5,7 +5,7 @@
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.4
5
2004/04/22 14:
26
:2
7
rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/reader.lisp,v 1.4
6
2004/04/22 14:
38
:2
5
rtoy Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -155,6 +155,15 @@
...
@@ -155,6 +155,15 @@
(
defconstant
package-delimiter
11
)
(
defconstant
package-delimiter
11
)
;;fake attribute for use in read-unqualified-token
;;fake attribute for use in read-unqualified-token
(
defconstant
delimiter
12
)
(
defconstant
delimiter
12
)
;; More fake attributes for used for reading numbers.
;;
;; The following two are not static but depend on *READ-BASE*.
;; DECIMAL-DIGIT is for characters being digits in base 10 but not in
;; base *READ-BASE* (which is therefore perforce smaller than 10);
;; DIGIT-OR-EXPT is for characters being both exponent markers and
;; digits in base *READ-BASE* (which is therefore perforce larger
;; than 10).
(
defconstant
constituent-decimal-digit
13
)
(
defconstant
constituent-decimal-digit
13
)
(
defconstant
constituent-digit-or-expt
14
))
(
defconstant
constituent-digit-or-expt
14
))
...
@@ -877,341 +886,6 @@
...
@@ -877,341 +886,6 @@
(
cond
(
all-lower
(
raise-em
))
(
cond
(
all-lower
(
raise-em
))
(
all-upper
(
lower-em
))))))))))))
(
all-upper
(
lower-em
))))))))))))
#+
(
or
)
(
defun
read-token
(
stream
firstchar
)
"This function is just an fsm that recognizes numbers and symbols."
;;check explicitly whether firstchar has entry for non-terminating
;;in character-attribute-table and read-dot-number-symbol in CMT.
;;Report an error if these are violated (if we called this, we want
;;something that is a legitimate token!).
;;read in the longest possible string satisfying the bnf for
;;"unqualified-token". Leave the result in the *READ-BUFFER*.
;;Return next char after token (last char read).
(
when
*read-suppress*
(
internal-read-extended-token
stream
firstchar
nil
)
(
return-from
read-token
nil
))
(
let
((
attribute-table
(
character-attribute-table
*readtable*
))
(
package
nil
)
(
colons
0
)
(
possibly-rational
t
)
(
possibly-float
t
)
(
escapes
()))
(
reset-read-buffer
)
(
prog
((
char
firstchar
))
(
case
(
char-class3
char
attribute-table
)
(
#.
constituent-sign
(
go
SIGN
))
(
#.
constituent-digit
(
go
LEFTDIGIT
))
(
#.
constituent-dot
(
go
FRONTDOT
))
(
#.
escape
(
go
ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
;;can't have eof, whitespace, or terminating macro as first char!
(
t
(
go
SYMBOL
)))
SIGN
;;saw "sign"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
go
RETURN-SYMBOL
))
(
setq
possibly-rational
t
possibly-float
t
)
(
case
(
char-class3
char
attribute-table
)
(
#.
constituent-digit
(
go
LEFTDIGIT
))
(
#.
constituent-dot
(
go
SIGNDOT
))
(
#.
escape
(
go
ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
delimiter
(
unread-char
char
stream
)
(
go
RETURN-SYMBOL
))
(
t
(
go
SYMBOL
)))
LEFTDIGIT
;;saw "[sign] {digit}+"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
return
(
make-integer
)))
(
case
(
char-class3
char
attribute-table
)
(
#.
constituent-digit
(
go
LEFTDIGIT
))
(
#.
constituent-dot
(
if
possibly-float
(
go
MIDDLEDOT
)
(
go
SYMBOL
)))
(
#.
constituent-expt
(
go
EXPONENT
))
(
#.
constituent-slash
(
if
possibly-rational
(
go
RATIO
)
(
go
SYMBOL
)))
(
#.
delimiter
(
unread-char
char
stream
)
(
return
(
make-integer
)))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
MIDDLEDOT
;;saw "[sign] {digit}+ dot"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
return
(
let
((
*read-base*
10
))
(
make-integer
))))
(
case
(
char-class
char
attribute-table
)
(
#.
constituent-digit
(
go
RIGHTDIGIT
))
(
#.
constituent-expt
(
go
EXPONENT
))
(
#.
delimiter
(
unread-char
char
stream
)
(
return
(
let
((
*read-base*
10
))
(
make-integer
))))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
RIGHTDIGIT
;;saw "[sign] {digit}* dot {digit}+"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
return
(
make-float
)))
(
case
(
char-class
char
attribute-table
)
(
#.
constituent-digit
(
go
RIGHTDIGIT
))
(
#.
constituent-expt
(
go
EXPONENT
))
(
#.
delimiter
(
unread-char
char
stream
)
(
return
(
make-float
)))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
SIGNDOT
;;saw "[sign] dot"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
go
RETURN-SYMBOL
))
(
case
(
char-class
char
attribute-table
)
(
#.
constituent-digit
(
go
RIGHTDIGIT
))
(
#.
delimiter
(
unread-char
char
stream
)
(
go
RETURN-SYMBOL
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
t
(
go
SYMBOL
)))
FRONTDOT
;;saw "dot"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
%reader-error
stream
"Dot context error."
))
(
case
(
char-class
char
attribute-table
)
(
#.
constituent-digit
(
go
RIGHTDIGIT
))
(
#.
constituent-dot
(
go
DOTS
))
(
#.
delimiter
(
%reader-error
stream
"Dot context error."
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
EXPONENT
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
go
RETURN-SYMBOL
))
(
case
(
char-class
char
attribute-table
)
(
#.
constituent-sign
(
go
EXPTSIGN
))
(
#.
constituent-digit
(
go
EXPTDIGIT
))
(
#.
delimiter
(
unread-char
char
stream
)
(
go
RETURN-SYMBOL
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
EXPTSIGN
;;we got to EXPONENT, and saw a sign character.
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
go
RETURN-SYMBOL
))
(
case
(
char-class
char
attribute-table
)
(
#.
constituent-digit
(
go
EXPTDIGIT
))
(
#.
delimiter
(
unread-char
char
stream
)
(
go
RETURN-SYMBOL
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
EXPTDIGIT
;;got to EXPONENT, saw "[sign] {digit}+"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
return
(
make-float
)))
(
case
(
char-class
char
attribute-table
)
(
#.
constituent-digit
(
go
EXPTDIGIT
))
(
#.
delimiter
(
unread-char
char
stream
)
(
return
(
make-float
)))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
RATIO
;;saw "[sign] {digit}+ slash"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
go
RETURN-SYMBOL
))
(
case
(
char-class2
char
attribute-table
)
(
#.
constituent-digit
(
go
RATIODIGIT
))
(
#.
delimiter
(
unread-char
char
stream
)
(
go
RETURN-SYMBOL
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
RATIODIGIT
;;saw "[sign] {digit}+ slash {digit}+"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
return
(
make-ratio
)))
(
case
(
char-class2
char
attribute-table
)
(
#.
constituent-digit
(
go
RATIODIGIT
))
(
#.
delimiter
(
unread-char
char
stream
)
(
return
(
make-ratio
)))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
DOTS
;;saw "dot {dot}+"
(
ouch-read-buffer
char
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
%reader-error
stream
"Too many dots."
))
(
case
(
char-class
char
attribute-table
)
(
#.
constituent-dot
(
go
DOTS
))
(
#.
delimiter
(
unread-char
char
stream
)
(
%reader-error
stream
"Too many dots."
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
SYMBOL
;;not a dot, dots, or number.
(
let
((
stream
(
in-synonym-of
stream
)))
(
stream-dispatch
stream
;; simple-stream
(
prog
()
SYMBOL-LOOP
(
ouch-read-buffer
char
)
(
setq
char
(
stream::%read-char
stream
nil
nil
t
t
))
(
unless
char
(
go
RETURN-SYMBOL
))
(
case
(
char-class
char
attribute-table
)
(
#.
escape
(
go
ESCAPE
))
(
#.
delimiter
(
stream::%unread-char
stream
char
)
(
go
RETURN-SYMBOL
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL-LOOP
))))
;; lisp-stream
(
prepare-for-fast-read-char
stream
(
prog
()
SYMBOL-LOOP
(
ouch-read-buffer
char
)
(
setq
char
(
fast-read-char
nil
nil
))
(
unless
char
(
go
RETURN-SYMBOL
))
(
case
(
char-class
char
attribute-table
)
(
#.
escape
(
done-with-fast-read-char
)
(
go
ESCAPE
))
(
#.
delimiter
(
done-with-fast-read-char
)
(
unread-char
char
stream
)
(
go
RETURN-SYMBOL
))
(
#.
multiple-escape
(
done-with-fast-read-char
)
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
done-with-fast-read-char
)
(
go
COLON
))
(
t
(
go
SYMBOL-LOOP
)))))
;; fundamental-stream
(
prog
()
SYMBOL-LOOP
(
ouch-read-buffer
char
)
(
setq
char
(
stream-read-char
stream
))
(
when
(
eq
char
:eof
)
(
go
RETURN-SYMBOL
))
(
case
(
char-class
char
attribute-table
)
(
#.
escape
(
go
ESCAPE
))
(
#.
delimiter
(
stream-unread-char
stream
char
)
(
go
RETURN-SYMBOL
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL-LOOP
))))))
ESCAPE
;;saw an escape.
;;don't put the escape in the read-buffer.
;;read-next char, put in buffer (no case conversion).
(
let
((
nextchar
(
read-char
stream
nil
nil
)))
(
unless
nextchar
(
reader-eof-error
stream
"after escape character"
))
(
push
*ouch-ptr*
escapes
)
(
ouch-read-buffer
nextchar
))
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
go
RETURN-SYMBOL
))
(
case
(
char-class
char
attribute-table
)
(
#.
delimiter
(
unread-char
char
stream
)
(
go
RETURN-SYMBOL
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
MULT-ESCAPE
(
do
((
char
(
read-char
stream
t
)
(
read-char
stream
t
)))
((
multiple-escape-p
char
))
(
if
(
escapep
char
)
(
setq
char
(
read-char
stream
t
)))
(
push
*ouch-ptr*
escapes
)
(
ouch-read-buffer
char
))
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
go
RETURN-SYMBOL
))
(
case
(
char-class
char
attribute-table
)
(
#.
delimiter
(
unread-char
char
stream
)
(
go
RETURN-SYMBOL
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
COLON
))
(
t
(
go
SYMBOL
)))
COLON
(
casify-read-buffer
escapes
)
(
unless
(
zerop
colons
)
(
%reader-error
stream
"Too many colons in ~S"
(
read-buffer-to-string
)))
(
setq
colons
1
)
(
setq
package
(
if
(
eql
(
char-class
firstchar
attribute-table
)
#.
package-delimiter
)
*keyword-package*
(
read-buffer-to-string
)))
(
reset-read-buffer
)
(
setq
escapes
())
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
reader-eof-error
stream
"after reading a colon"
))
(
case
(
char-class
char
attribute-table
)
(
#.
delimiter
(
unread-char
char
stream
)
(
%reader-error
stream
"Illegal terminating character after a colon, ~S."
char
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
go
INTERN
))
(
t
(
go
SYMBOL
)))
INTERN
(
setq
colons
2
)
(
setq
char
(
read-char
stream
nil
nil
))
(
unless
char
(
reader-eof-error
stream
"after reading a colon"
))
(
case
(
char-class
char
attribute-table
)
(
#.
delimiter
(
unread-char
char
stream
)
(
%reader-error
stream
"Illegal terminating character after a colon, ~S"
char
))
(
#.
escape
(
go
ESCAPE
))
(
#.
multiple-escape
(
go
MULT-ESCAPE
))
(
#.
package-delimiter
(
%reader-error
stream
"To many colons after ~S:"
package
))
(
t
(
go
SYMBOL
)))
RETURN-SYMBOL
(
casify-read-buffer
escapes
)
(
let
((
found
(
if
package
(
find-package
package
)
*package*
)))
(
unless
found
(
error
'reader-package-error
:stream
stream
:format-arguments
(
list
package
)
:format-control
"Package ~S not found."
))
(
if
(
or
(
zerop
colons
)
(
=
colons
2
)
(
eq
found
*keyword-package*
))
(
return
(
intern*
*read-buffer*
*ouch-ptr*
found
))
(
multiple-value-bind
(
symbol
test
)
(
find-symbol*
*read-buffer*
*ouch-ptr*
found
)
(
when
(
eq
test
:external
)
(
return
symbol
))
(
let
((
name
(
read-buffer-to-string
)))
(
with-simple-restart
(
continue
"Use symbol anyway."
)
(
error
'reader-package-error
:stream
stream
:format-arguments
(
list
name
(
package-name
found
))
:format-control
(
if
test
"The symbol ~S is not external in the ~A package."
"Symbol ~S not found in the ~A package."
)))
(
return
(
intern
name
found
)))))))))
(
defun
read-token
(
stream
firstchar
)
(
defun
read-token
(
stream
firstchar
)
"This function is just an fsm that recognizes numbers and symbols."
"This function is just an fsm that recognizes numbers and symbols."
;; Check explicitly whether FIRSTCHAR has an entry for
;; Check explicitly whether FIRSTCHAR has an entry for
...
@@ -1713,105 +1387,6 @@
...
@@ -1713,105 +1387,6 @@
(
setq
number
(
+
num
(
*
number
base-power
)))))))
(
setq
number
(
+
num
(
*
number
base-power
)))))))
#+
(
or
)
(
defun
make-float
()
;;assume that the contents of *read-buffer* are a legal float, with nothing
;;else after it.
(
read-unwind-read-buffer
)
(
let
((
negative-fraction
nil
)
(
number
0
)
(
divisor
1
)
(
negative-exponent
nil
)
(
exponent
0
)
(
float-char
())
(
char
(
inch-read-buffer
)))
(
if
(
cond
((
char=
char
#\+
)
t
)
((
char=
char
#\-
)
(
setq
negative-fraction
t
)))
;;flush it
(
setq
char
(
inch-read-buffer
)))
;;read digits before the dot
(
do*
((
ch
char
(
inch-read-buffer
))
(
dig
(
digit-char-p
ch
)
(
digit-char-p
ch
)))
((
not
dig
)
(
setq
char
ch
))
(
setq
number
(
+
(
*
number
10
)
dig
)))
;;deal with the dot, if it's there.
(
when
(
char=
char
#\.
)
(
setq
char
(
inch-read-buffer
))
;;read digits after the dot.
(
do*
((
ch
char
(
inch-read-buffer
))
(
dig
(
and
(
not
(
eofp
ch
))
(
digit-char-p
ch
))
(
and
(
not
(
eofp
ch
))
(
digit-char-p
ch
))))
((
not
dig
)
(
setq
char
ch
))
(
setq
divisor
(
*
divisor
10
))
(
setq
number
(
+
(
*
number
10
)
dig
))))
;;is there an exponent letter?
(
cond
((
eofp
char
)
;;if not, we've read the whole number.
(
let
((
num
(
make-float-aux
number
divisor
*read-default-float-format*
)))
(
return-from
make-float
(
if
negative-fraction
(
-
num
)
num
))))
((
exponent-letterp
char
)
(
setq
float-char
char
)
;;build exponent
(
setq
char
(
inch-read-buffer
))
;;check leading sign
(
if
(
cond
((
char=
char
#\+
)
t
)
((
char=
char
#\-
)
(
setq
negative-exponent
t
)))
;;flush sign
(
setq
char
(
inch-read-buffer
)))
;;read digits for exponent
(
do*
((
ch
char
(
inch-read-buffer
))
(
dig
(
and
(
not
(
eofp
ch
))
(
digit-char-p
ch
))
(
and
(
not
(
eofp
ch
))
(
digit-char-p
ch
))))
((
not
dig
)
(
setq
exponent
(
if
negative-exponent
(
-
exponent
)
exponent
)))
(
setq
exponent
(
+
(
*
exponent
10
)
dig
)))
;;generate and return the float, depending on float-char:
(
let*
((
float-format
(
case
(
char-upcase
float-char
)
(
#\E
*read-default-float-format*
)
(
#\S
'short-float
)
(
#\F
'single-float
)
(
#\D
'double-float
)
(
#\L
'long-float
)))
num
)
;; toy@rtp.ericsson.se: We need to watch out if the
;; exponent is too small or too large. We add enough to
;; EXPONENT to make it within range and scale NUMBER
;; appropriately. This should avoid any unnecessary
;; underflow or overflow problems.
(
multiple-value-bind
(
min-expo
max-expo
)
(
case
float-format
(
short-float
(
values
#.
(
log
least-positive-normalized-short-float
10s0
)
#.
(
log
most-positive-short-float
10s0
)))
(
single-float
(
values
#.
(
log
least-positive-normalized-single-float
10f0
)
#.
(
log
most-positive-single-float
10f0
)))
(
double-float
(
values
#.
(
log
least-positive-normalized-double-float
10d0
)
#.
(
log
most-positive-double-float
10d0
)))
(
long-float
(
values
#.
(
log
least-positive-normalized-long-float
10L0
)
#.
(
log
most-positive-long-float
10L0
))))
(
let
((
correction
(
cond
((
<=
exponent
min-expo
)
(
ceiling
(
-
min-expo
exponent
)))
((
>=
exponent
max-expo
)
(
floor
(
-
max-expo
exponent
)))
(
t
0
))))
(
incf
exponent
correction
)
(
setf
number
(
/
number
(
expt
10
correction
)))
(
setq
num
(
make-float-aux
number
divisor
float-format
))
(
setq
num
(
*
num
(
expt
10
exponent
)))
(
return-from
make-float
(
if
negative-fraction
(
-
num
)
num
))))))
;;should never happen:
(
t
(
error
"Internal error in floating point reader."
)))))
(
defun
make-float
()
(
defun
make-float
()
;; Assume that the contents of *read-buffer* are a legal float, with nothing
;; Assume that the contents of *read-buffer* are a legal float, with nothing
;; else after it.
;; else after it.
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment