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
09de8632
Commit
09de8632
authored
35 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
Back-merged type declaration fix into working code version as of this date.
parent
6ef0b882
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/format.lisp
+88
-64
88 additions, 64 deletions
code/format.lisp
with
88 additions
and
64 deletions
code/format.lisp
+
88
−
64
View file @
09de8632
...
...
@@ -15,10 +15,9 @@
;;;
;;; FORMAT is part of the standard Spice Lisp environment.
;;;
;;; **********************************************************************
(
in-package
"LISP"
)
(
in-package
'lisp
)
(
export
'format
)
(
export
'
(
format
))
;;; Special variables local to FORMAT
...
...
@@ -54,7 +53,7 @@
;;; ERRORS
;;;
;
ERRORS
;;; Since errors may occur while an indirect control string is being
;;; processed, i.e. by ~? or ~{~:}, some sort of backtrace is necessary
...
...
@@ -105,6 +104,7 @@
error
))))))
;;;; WITH-FORMAT-PARAMETERS, and other useful macros.
;;; This macro rebinds collects output to the standard output stream
;;; in a string. For efficiency, we avoid consing a new stream on
;;; every call. A stack of string streams is maintained in order to
...
...
@@ -116,11 +116,11 @@
(
pop
*format-stream-stack*
)
(
make-string-output-stream
))))
(
unwind-protect
(
progn
,@
forms
(
prog1
(
get-output-stream-string
*standard-output*
)
(
push
*standard-output*
*format-stream-stack*
)))
(
get-output-stream-string
*standard-output*
))))
(
progn
,@
forms
(
prog1
(
get-output-stream-string
*standard-output*
)
(
push
*standard-output*
*format-stream-stack*
)))
(
get-output-stream-string
*standard-output*
))))
...
...
@@ -155,7 +155,7 @@
;;; C
ONTROL STRING PARSING
;;;
;
C
ontrol String Parsing
;;; The current control string is kept in *format-control-string*.
;;; The variable *format-index* is the position of the last character
...
...
@@ -226,27 +226,39 @@
(
t
nil
)))
;;; Parses a format directive, including flags and parameters. On entry,
;;; *format-index* should point to the "~" preceding the command. On
;;; exit, *format-index* points to the command character itself.
;;; Returns the list of parameters, the ":" flag, the "@" flag, and the
;;; command character as multiple values. Explicitly defaulted parameters
;;; appear in the list of parameters as NIL. Omitted parameters are simply
;;; not included in the list at all.
;;;; Parsing the directives to FORMAT.
;;; PARSE-FORMAT-OPERATION parses a format directive, including flags and
;;; parameters. On entry, *format-index* should point to the "~" preceding the
;;; command. On exit, *format-index* points to the command character itself.
;;; Returns the list of parameters, the ":" flag, the "@" flag, and the command
;;; character as multiple values. Explicitly defaulted parameters appear in
;;; the list of parameters as NIL. Omitted parameters are simply not included
;;; in the list at all.
;;;
(
defmacro
parse-format-operation-modifier
()
`
(
let
((
temp
(
format-peek
)))
(
cond
((
char=
temp
#\:
)
(
nextchar
)
(
setf
colon-p
t
))
((
char=
temp
#\@
)
(
nextchar
)
(
setf
atsign-p
t
)))))
;;;
(
defun
parse-format-operation
()
(
let
((
ch
(
nextchar
)))
(
values
(
if
(
or
(
digit-char-p
ch
)
(
member
ch
'
(
#\,
#\#
#\V
#\v
#\'
#\+
#\-
)
:test
#'
char=
))
(
do
((
parms
(
list
(
format-get-parameter
))
(
cons
(
format-get-parameter
)
parms
)))
((
char/=
(
format-peek
)
#\,
)
(
nreverse
parms
))
(
declare
(
list
parms
))
(
nextchar
))
'
())
(
if
(
char=
(
format-peek
)
#\:
)
(
nextchar
)
nil
)
(
if
(
char=
(
format-peek
)
#\@
)
(
nextchar
)
nil
)
(
format-peek
))))
(
let*
((
ch
(
nextchar
))
(
parms
(
if
(
or
(
digit-char-p
ch
)
(
member
ch
'
(
#\,
#\#
#\V
#\v
#\'
#\+
#\-
)
:test
#'
char=
))
(
do
((
parms
(
list
(
format-get-parameter
))
(
cons
(
format-get-parameter
)
parms
)))
((
char/=
(
format-peek
)
#\,
)
(
nreverse
parms
))
(
declare
(
list
parms
))
(
nextchar
))
'
()))
colon-p
atsign-p
)
(
parse-format-operation-modifier
)
(
parse-format-operation-modifier
)
(
values
parms
colon-p
atsign-p
(
format-peek
))))
...
...
@@ -300,7 +312,7 @@
;;; This is the FORMAT top-level function.
;;;
;
This is the FORMAT top-level function.
(
defun
format
(
destination
control-string
&rest
format-arguments
)
"Provides various facilities for formatting output.
...
...
@@ -372,6 +384,8 @@
(
error
"~%~:{~@?~%~}"
(
nreverse
errorp
))))
nil
)))))
;;;; SUB-FORMAT, the real work of FORMAT.
;;; This function does the real work of format. The segment of the control
;;; string between indiced START (inclusive) and END (exclusive) is processed
;;; as follows: Text not part of a directive is output without further
...
...
@@ -379,7 +393,7 @@
;;; and the appropriate handlers invoked with the arguments COLON, ATSIGN, and
;;; PARMS.
;;;
;;; Implementation Note: FORMAT-FIND-CHAR uses the POSITION s
equence
operation
;;; Implementation Note: FORMAT-FIND-CHAR uses the POSITION s
tream
operation
;;; for speed. This is potentially faster than character-at-a-time searching.
(
defun
sub-format
(
start
end
)
...
...
@@ -410,7 +424,7 @@
;;; Conditional case conversion ~( ... ~)
;;;
;
Conditional case conversion ~( ... ~)
(
defun
format-capitalization
(
colon
atsign
parms
)
(
when
parms
...
...
@@ -462,7 +476,7 @@
(
throw
(
if
colon
'format-colon-escape
'format-escape
)
nil
)))
;;; Conditional expression ~[ ... ]
;;;
;
Conditional expression ~[ ... ]
;;; ~[
...
...
@@ -556,7 +570,7 @@
(
t
(
format-untagged-condition
))))
;;; Iteration ~{ ... ~}
;;;
;
Iteration ~{ ... ~}
(
defun
format-iteration
(
colon
atsign
parms
)
(
with-format-parameters
parms
((
max-iter
-1
))
...
...
@@ -616,7 +630,7 @@
;;; Justification ~< ... ~>
;;;
;
Justification ~< ... ~>
;;; Parses a list of clauses delimited by ~; and terminated by ~>.
;;; Recursively invoke SUB-FORMAT to process them, and return a list
...
...
@@ -669,11 +683,13 @@
;;;; Padding functions for Justification.
;;; Given the total number of SPACES needed for padding, and the number
;;; of padding segments needed (PADDINGS), returns a list of such segments.
;;; We try to allocate the spaces equally to each segment. When this is
;;; not possible, allocate any left over spaces to the first segment.
;;;
(
defun
make-pad-segs
(
spaces
padding-segs
)
(
do*
((
extra-space
()
(
and
(
plusp
extra-spaces
)
extra-inc
...
...
@@ -696,7 +712,7 @@
;;; characters according to the following rule: If WIDTH is less than or
;;; equal to MINCOL, use WIDTH as the actual width. Otherwise, round up
;;; to MINCOL + k * COLINC for the smallest possible positive integer k.
;;;
(
defun
format-round-columns
(
width
mincol
colinc
)
(
if
(
>
width
mincol
)
(
multiple-value-bind
...
...
@@ -748,7 +764,7 @@
(
dotimes
(
i
(
car
spcs
))
(
write-char
padchar
))
(
write-string
(
car
segs
)))))))))
;;; Newline ~&
;;;
;
Newline ~&
(
defun
format-terpri
(
colon
atsign
parms
)
(
when
(
or
colon
atsign
)
...
...
@@ -806,7 +822,7 @@
(
t
(
format-eat-whitespace
))))
;;; Pluralize word
~P
;;;
;
Pluralize word
(
~P
) and Skip Arguments (~*)
(
defun
format-plural
(
colon
atsign
parms
)
(
when
parms
...
...
@@ -851,7 +867,7 @@
;;; Indirection ~?
;;;
;
Indirection ~?
(
defun
format-indirection
(
colon
atsign
parms
)
(
if
(
or
colon
parms
)
(
format-error
"Colon flag or parameters not allowed"
))
...
...
@@ -892,7 +908,7 @@
:start
0
:end
40
)))))
;;; Ascii ~A
;;;
;
Ascii ~A
(
defun
format-princ
(
colon
atsign
parms
)
(
let
((
arg
(
pop-format-arg
)))
...
...
@@ -929,9 +945,15 @@
(
let
((
char
(
pop-format-arg
)))
(
unless
(
characterp
char
)
(
format-error
"Argument must be a character"
))
(
cond
((
and
atsign
(
not
colon
))
(
prin1
char
))
(
t
(
format-print-named-character
char
colon
))))))
(
cond
((
not
colon
)
(
cond
(
atsign
(
prin1
char
))
((
zerop
(
char-bits
char
))
(
write-char
char
))
(
t
(
format-print-named-character
char
nil
))))
(
t
(
format-print-named-character
char
t
))))))
(
defun
format-print-named-character
(
char
longp
)
(
when
(
char-bit
char
:control
)
...
...
@@ -954,8 +976,7 @@
;;; NUMERIC PRINTING
;;;; NUMERIC PRINTING
;;; Insert commas after every third digit, scanning from right to left.
...
...
@@ -1001,9 +1022,9 @@
(
dotimes
(
i
(
-
width
strlen
))
(
write-char
padchar
))))))
;;;
This functions
does most of the work for the numeric printing
;;;
FORMAT-PRINT-NUMBER
does most of the work for the numeric printing
;;; directives. The parameters are interpreted as defined for ~D.
;;;
(
defun
format-print-number
(
number
radix
print-commas-p
print-sign-p
parms
)
(
with-format-parameters
parms
((
mincol
0
)
(
padchar
#\space
)
(
commachar
#\,
))
...
...
@@ -1022,7 +1043,7 @@
(
write-string
text
)))))
;;; Print a cardinal number in English
;;;
;
Print a cardinal number in English
;;; The following are initialized in FORMAT-INIT to get around cold-loader
...
...
@@ -1079,7 +1100,7 @@
(
write-string
(
svref
cardinal-periods
period
)))))
;;; Print an ordinal number in English
;;;
;
Print an ordinal number in English
(
defvar
ordinal-ones
()
"Table of ordinal ones-place digits in English"
)
...
...
@@ -1149,6 +1170,8 @@
;;;; Format Radix Options (~D ~B ~O ~X ~R).
;;; Decimal ~D
(
defun
format-print-decimal
(
colon
atsign
parms
)
...
...
@@ -1188,11 +1211,10 @@
(
format-print-cardinal
number
))))))
;;; FLOATING-POINT NUMBERS
;;;; FLOATING-POINT NUMBERS
;;; Fixed-format floating point ~F
;;;
(
defun
format-fixed
(
colon
atsign
parms
)
(
when
colon
(
format-error
"Colon flag not allowed"
))
...
...
@@ -1246,7 +1268,7 @@
(
when
tpoint
(
write-char
#\0
))))))))
;;; Exponential-format floating point ~E
;;;
;
Exponential-format floating point ~E
(
defun
format-exponential
(
colon
atsign
parms
)
...
...
@@ -1328,7 +1350,7 @@
;;; General Floating Point - ~G
;;;
;
General Floating Point - ~G
(
defun
format-general-float
(
colon
atsign
parms
)
(
when
colon
...
...
@@ -1395,6 +1417,8 @@
(
format-write-field
(
princ-to-string
number
)
w
1
0
#\space
t
))))))
;;;; Some stuff for Compiler, MACLISP interaction.
;;; The following crock simulates some Common Lisp functions in the
;;; cross-compiler's MACLISP environment for the benefit of the hairy
;;; dispatch-table initialization macro. The internal representation
...
...
@@ -1426,7 +1450,7 @@
(list '**character** code)))
|#
;;; INITIALIZATION
;;;
;
INITIALIZATION
;;; Hairy dispatch-table initialization macro. Takes a list of two-element
...
...
@@ -1466,25 +1490,25 @@
;;; cold loader.
(
defun
format-init
()
(
set
q
cardinal-ones
(
set
f
cardinal-ones
'#(
nil
"one"
"two"
"three"
"four"
"five"
"six"
"seven"
"eight"
"nine"
))
(
set
q
cardinal-tens
(
set
f
cardinal-tens
'#(
nil
nil
"twenty"
"thirty"
"forty"
"fifty"
"sixty"
"seventy"
"eighty"
"ninety"
))
(
set
q
cardinal-teens
(
set
f
cardinal-teens
'#(
"ten"
"eleven"
"twelve"
"thirteen"
"fourteen"
;;; RAD
"fifteen"
"sixteen"
"seventeen"
"eighteen"
"nineteen"
))
(
set
q
cardinal-periods
(
set
f
cardinal-periods
'#(
""
" thousand"
" million"
" billion"
" trillion"
" quadrillion"
" quintillion"
" sextillion"
" septillion"
" octillion"
" nonillion"
" decillion"
))
(
set
q
ordinal-ones
(
set
f
ordinal-ones
'#(
nil
"first"
"second"
"third"
"fourth"
"fifth"
"sixth"
"seventh"
"eighth"
"ninth"
))
(
set
q
ordinal-tens
(
set
f
ordinal-tens
'#(
nil
"tenth"
"twentieth"
"thirtieth"
"fortieth"
"fiftieth"
"sixtieth"
"seventieth"
"eightieth"
"ninetieth"
))
(
set
q
*format-dispatch-table*
(
set
f
*format-dispatch-table*
(
make-dispatch-vector
(
#\B
#'
format-print-binary
)
(
#\O
#'
format-print-octal
)
...
...
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