Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
cmucl
cmucl
Commits
66a7c310
Commit
66a7c310
authored
Aug 24, 1990
by
wlott
Browse files
Moved MIPS branch onto trunk; no merge necessary.
parent
ab01e4bf
Changes
29
Expand all
Hide whitespace changes
Inline
Side-by-side
code/alieneval.lisp
View file @
66a7c310
This diff is collapsed.
Click to expand it.
code/array.lisp
View file @
66a7c310
This diff is collapsed.
Click to expand it.
code/defstruct.lisp
View file @
66a7c310
...
...
@@ -7,21 +7,16 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defstruct.lisp,v 1.9 1990/08/24 18:10:38 wlott Exp $
;;;
;;; Defstruct structure definition package (Mark II).
;;; Written by Skef Wholey and Rob MacLachlan.
;;;
(
in-package
'c
)
(
export
'
(
lisp::defstruct
)
"LISP"
)
;;; In Spice Lisp, the default structure representation is a simple-vector with
;;; the subtype field set to 1. The first element is used to hold the name of
;;; the structure. This piece of implementation-dependency resides in the
;;; macros defined here.
;;;
(
proclaim
'
(
inline
structurify
))
(
defun
structurify
(
structure
)
"Frobs a vector to turn it into a named structure. Returns the vector."
(
%primitive
set-vector-subtype
structure
%g-vector-structure-subtype
))
;;; Note: STRUCTURIFY is defined in struct.lisp. It converts a simple-vector
;;; into a structure.
;;; This version of Defstruct is implemented using Defstruct, and is free of
...
...
@@ -285,11 +280,13 @@
;;; This is called by the accessor closures, which have a handle on the type's
;;; Defstruct-Description.
;;;
#+
new-compiler
(
proclaim
'
(
inline
typep-to-structure
))
#+
new-compiler
(
defun
typep-to-structure
(
obj
info
)
(
declare
(
type
defstruct-description
info
)
(
inline
member
))
(
and
(
structurep
obj
)
(
let
((
name
(
%primitive
header
-ref
obj
0
)))
(
let
((
name
(
%primitive
structure
-ref
obj
0
)))
(
or
(
eq
name
(
dd-name
info
))
(
member
name
(
dd-included-by
info
)
:test
#'
eq
)))))
...
...
@@ -312,7 +309,7 @@
(
unless
(
typep-to-structure
structure
info
)
(
error
"Structure for accessor ~S is not a ~S:~% ~S"
(
dsd-accessor
dsd
)
(
dd-name
info
)
structure
))
(
%primitive
hea
de
r
-ref
structure
(
dsd-index
dsd
))))
(
%primitive
structure-in
de
x
-ref
structure
(
dsd-index
dsd
))))
(
unless
(
dsd-read-only
slot
)
(
setf
(
fdefinition
`
(
setf
,
(
dsd-accessor
slot
)))
...
...
@@ -326,7 +323,7 @@
(
error
"New-Value for setter ~S is not a ~S:~% ~S."
`
(
setf
,
(
dsd-accessor
dsd
))
(
dsd-type
dsd
)
new-value
))
(
%primitive
hea
de
r
-set
structure
(
dsd-index
dsd
)
(
%primitive
structure-in
de
x
-set
structure
(
dsd-index
dsd
)
new-value
))))))
(
when
(
dd-predicate
info
)
...
...
@@ -348,11 +345,11 @@
(
do
((
i
1
(
1+
i
))
(
res
(
%primitive
alloc-g-vector
len
nil
)))
((
=
i
len
)
(
%primitive
header
-set
res
0
(
dd-name
info
))
(
%primitive
structure
-set
res
(
dd-name
info
)
0
)
(
structurify
res
))
(
declare
(
fixnum
i
))
(
%primitive
hea
de
r
-set
res
i
(
%primitive
hea
de
r
-ref
structure
i
)))))))
(
%primitive
structure-in
de
x
-set
res
i
(
%primitive
structure-in
de
x
-ref
structure
i
)))))))
(
when
(
dd-doc
info
)
(
setf
(
documentation
(
dd-name
info
)
'type
)
(
dd-doc
info
))))
...
...
@@ -378,7 +375,7 @@
(
declare
(
type
,
type
structure
))
(
the
,
slot-type
(
elt
structure
,
index
)))
,@
(
unless
(
dsd-read-only
slot
)
`
((
defun
(
setf
,
name
)
(
structure
new-valu
e
)
`
((
defun
(
setf
,
name
)
(
new-value
structur
e
)
(
declare
(
type
,
type
structure
)
(
type
,
slot-type
new-value
))
(
setf
(
elt
structure
,
index
)
new-value
)))))
stuff
))))
...
...
@@ -476,7 +473,7 @@
(
let
((
arg
(
car
args
)))
(
cond
((
not
(
atom
arg
))
(
push
(
find-legal-slot
defstruct
(
car
arg
))
slots-in-arglist
))
((
mem
q
arg
'
(
&optional
&rest
&aux
&key
))
((
mem
ber
arg
'
(
&optional
&rest
&aux
&key
)
:test
#'
eq
)
(
setq
arg-kind
arg
))
(
t
(
case
arg-kind
...
...
@@ -494,7 +491,8 @@
:initial-element
`
',
(
dd-name
defstruct
))
(
make-list
(
dd-offset
defstruct
))))
(
thing
(
mapcar
#'
(
lambda
(
slot
)
(
if
(
memq
slot
slots-in-arglist
)
(
if
(
member
slot
slots-in-arglist
:test
#'
eq
)
(
dsd-name
slot
)
(
dsd-default
slot
)))
slots
)))
...
...
@@ -567,7 +565,7 @@
(
let
((
def
(
info
type
structure-info
type
)))
(
if
(
and
def
(
eq
(
dd-type
def
)
'structure
)
(
dd-predicate
def
))
`
(
and
(
structurep
,
object
)
(
if
(
eq
(
%primitive
header
-ref
,
object
0
)
',type
)
(
if
(
eq
(
%primitive
structure
-ref
,
object
0
)
',type
)
t
(
,
(
dd-predicate
def
)
,
object
)))
`
(
lisp::structure-typep
,
object
',type
))))
...
...
code/describe.lisp
View file @
66a7c310
...
...
@@ -206,12 +206,12 @@
(
let
((
rank
(
array-rank
x
)))
(
cond
((
>
rank
1
)
(
format
t
"~&~S is "
x
)
(
write-string
(
if
(
%displacedp
x
)
"a displaced"
"an"
))
(
write-string
(
if
(
%
array-
displaced
-
p
x
)
"a displaced"
"an"
))
(
format
t
" array of rank ~A."
rank
)
(
format
t
"~%Its dimensions are ~S."
(
array-dimensions
x
)))
(
t
(
format
t
"~&~S is a ~:[~;displaced ~]vector of length ~D."
x
(
%
displacedp
x
)
(
length
x
))
(
and
(
array-header-p
x
)
(
%array-
displaced
-
p
x
)
)
(
length
x
))
(
if
(
array-has-fill-pointer-p
x
)
(
format
t
"~&It has a fill pointer, currently ~d"
(
fill-pointer
x
))
...
...
@@ -228,32 +228,30 @@
,
output
))))
(
defun
describe-function
(
x
)
(
case
(
%primitive
get-vector-subtype
x
)
(
#.
%function-entry-subtype
(
describe-function-compiled
x
))
(
#.
%function-closure-subtype
(
declare
(
type
function
x
))
(
case
(
get-type
x
)
(
#.
vm:closure-header-type
(
describe-function-lex-closure
x
))
((
#.
vm:function-header-type
#.
vm:closure-function-header-type
)
(
describe-function-compiled
x
))
(
t
(
format
t
"~&It is an unknown type of function."
))))
(
defun
describe-function-compiled
(
x
)
(
let
((
args
(
%primitive
header-ref
x
%function-
entry
-arglist
-slot
)))
(
let
((
args
(
%function-
header
-arglist
x
)))
(
describe-function-arg-list
*current-describe-object*
(
string=
args
"()"
)
(
write-string
args
)))
(
let
((
*print-level*
nil
)
(
*print-length*
nil
)
(
type
(
%
primitive
header-ref
x
%function-entry-type-slot
)))
(
type
(
%
function-header-type
x
)))
(
format
t
"~&Its argument types are:~% ~S"
(
second
type
))
(
format
t
"~&Its result type is:~% ~S"
(
third
type
)))
(
let
((
name
(
%
primitive
header-ref
x
%function-name-slot
)))
(
let
((
name
(
%
function-header-name
x
)))
(
when
(
symbolp
name
)
(
desc-doc
name
'function
"Function Documention:"
)))
(
let
((
info
(
%primitive
header-ref
(
%primitive
header-ref
x
%function-entry-constants-slot
)
%function-constants-debug-info-slot
)))
(
let
((
info
(
di::code-debug-info
(
di::function-code-header
x
))))
(
when
info
(
let
((
sources
(
c::compiled-debug-info-source
info
)))
(
format
t
"~&On ~A it was compiled from:"
...
...
@@ -275,14 +273,11 @@
(
defun
describe-function-lex-closure
(
x
)
(
print-for-describe
x
)
(
format
t
" is a lexical closure.~%"
)
(
describe-function-compiled
(
%closure-function
x
))
(
format
t
"~&Its lexical environment is:"
)
(
indenting-further
*standard-output*
8
(
do
((
i
%function-closure-variables-offset
(
1+
i
)))
((
=
i
(
%primitive
header-length
x
)))
(
format
t
"~&~D: ~S"
(
-
i
%function-closure-variables-offset
)
(
%primitive
header-ref
x
i
))))
(
describe-function-compiled
(
%primitive
header-ref
x
%function-name-slot
)))
(
indenting-further
*standard-output*
8
)
(
dotimes
(
i
(
get-header-data
x
))
(
format
t
"~&~D: ~S"
i
(
%closure-index-ref
x
i
))))
(
defun
print-for-describe
(
x
&optional
(
freshp
t
))
...
...
code/error.lisp
View file @
66a7c310
...
...
@@ -530,7 +530,8 @@ The previous version is uglier, but it sets up unique run-time tags.
;;; hyperspace.
;;;
(
defmacro
infinite-error-protect
(
form
)
`
(
if
(
and
(
boundp
'*error-system-initialized*
)
(
numberp
*current-error-depth*
))
`
(
if
(
and
(
boundp
'*error-system-initialized*
)
(
numberp
*current-error-depth*
))
(
let
((
*current-error-depth*
(
1+
*current-error-depth*
)))
(
if
(
>
*current-error-depth*
*max-error-depth*
)
(
error-error
"Help! "
*current-error-depth*
" nested errors."
)
...
...
@@ -974,265 +975,13 @@ The previous version sets up unique run-time tags.
none exists."
)
;;;; Internal Error Codes.
;;; *Internal-error-table* contains a vector, by error code, of functions.
;;; This is used in %SP-INTERNAL-ERROR, and initialized MAKE-ERROR-TABLE.
;;;
(
defvar
*internal-error-table*
)
#+
new-compiler
;;; %SP-INTERNAL-ERROR is called by the microcode when an internal error
;;; occurrs. It is simply a dispatch routine which looks up a specialized
;;; function to call in the special variable, *internal-error-table*.
;;;
;;; ERR-CODE -- a fixnum which identifies the specific error.
;;; PC -- the relative offset of the NEXT macro instruction to be
;;; executed in the code vector of the errorful function.
;;; ARG3 & ARG4 -- arbitrary meaning determined by ERR-CODE.
;;;
(
defun
lisp::%sp-internal-error
(
err-code
arg3
arg4
)
(
infinite-error-protect
(
funcall
(
svref
*internal-error-table*
err-code
)
(
find-caller-name
)
0
arg3
arg4
)))
;;; DEF-INTERNAL-ERROR defines a form which can be put into the system init
;;; file (spinit, or vaxinit) to define the errors which the microcode may
;;; signal. The form looks like
;;;
;;; (def-internal-error err-code condition flag control-string &rest args)
;;; ERR-CODE -- the internal code for this error. less than or equal to
;;; max-internal-error which is declared in the init file.
;;; CONDITION -- the name of the error to signal
;;; FLAG -- one of CORRECTABLE, FATAL or SYSTEM-ERROR. (not evaluated)
;;; if CORRECTABLE, %sp-internal-error may return correction values
;;; if SYSTEM-ERROR, the CONDITION arg is ignored.
;;; CONTROL-STRING -- the error message as a format control string.
;;; ARGS -- The args to the control string. The 3rd & 4th args to
;;; %sp-internal-error are available as the variables ARG3 & ARG4.
;;;
;;; NOTE: system-error is never supplied, and condition is never used. Maybe
;;; it will be when we signal appropriate conditions for certain
;;; situations.
;;;
;example
; (def-internal-error 6 :unbound-symbol correctable
; "Unbound symbol: ~s." arg3)
(
defmacro
def-internal-error
(
number
condition
flag
control-string
&rest
args
)
(
declare
(
ignore
condition
))
`
(
setf
(
svref
*internal-error-table*
,
number
)
#'
(
lambda
(
callers-name
PC
arg3
arg4
)
(
declare
(
ignore
,@
(
unless
(
eq
flag
'system-error
)
'
(
PC
))
,@
(
unless
(
member
'arg3
args
)
'
(
arg3
))
,@
(
unless
(
member
'arg4
args
)
'
(
arg4
))))
,
(
case
flag
((
fatal
)
`
(
error
'simple-error
:function-name
callers-name
:format-string
,
control-string
:format-arguments
(
list
,@
args
)))
((
correctable
)
`
(
cerror
'simple-error
:function-name
callers-name
:format-string
,
control-string
:format-arguments
(
list
,@
args
)))))))
(
defconstant
max-internal-error
100
"The largest internal error number for Spice Lisp."
)
(
proclaim
'
(
special
allocation-space
))
(
defun
make-error-table
()
(
setq
*internal-error-table*
(
make-array
(
1+
max-internal-error
)
:initial-element
#'
(
lambda
(
&rest
ignore
)
(
declare
(
ignore
ignore
))
(
break
"Undefined Error."
))))
(
def-internal-error
1
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'List
)
(
def-internal-error
2
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Symbol
)
(
def-internal-error
3
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Number
)
(
def-internal-error
4
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Integer
)
(
def-internal-error
5
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Ratio
)
(
def-internal-error
6
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Complex
)
(
def-internal-error
7
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Vector-like
)
(
def-internal-error
8
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'simple-vector
)
(
def-internal-error
9
:invalid-function
fatal
"Invalid function: ~s."
arg3
)
(
def-internal-error
10
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been a function or an array."
arg3
)
(
def-internal-error
11
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'U-vector-like
)
(
def-internal-error
12
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'simple-bit-vector
)
(
def-internal-error
13
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'simple-string
)
(
def-internal-error
14
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'character
)
(
def-internal-error
15
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Control-Stack-Pointer
)
(
def-internal-error
16
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Binding-Stack-Pointer
)
(
def-internal-error
17
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Array
)
(
def-internal-error
18
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'Positive-Fixnum
)
(
def-internal-error
19
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'SAP-pointer
)
(
def-internal-error
20
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of tyep ~s."
arg3
'system-pointer
)
(
def-internal-error
21
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'float
)
(
def-internal-error
22
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'rational
)
(
def-internal-error
23
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been a non-complex number."
arg3
)
(
def-internal-error
25
:unbound-variable
fatal
"Unbound variable: ~s."
arg3
)
(
def-internal-error
26
:undefined-function
fatal
"Undefined function: ~s."
arg3
)
(
def-internal-error
27
:error
fatal
"Attempt to alter NIL."
)
(
def-internal-error
28
:error
fatal
"Attempt to alter NIL."
)
(
def-internal-error
29
:error
fatal
"Circularity detected in chain of symbols from definition cell of symbol ~S."
arg3
)
;;Special because handlers won't work while allocation-space is wrong.
(
setf
(
svref
*internal-error-table*
24
)
#'
(
lambda
(
callers-name
ignore0
ignore1
ignore2
)
(
declare
(
ignore
ignore0
ignore1
ignore2
))
(
let
((
bazfaz
allocation-space
))
(
setq
allocation-space
0
)
(
error
'simple-error
:function-name
callers-name
:format-string
"Illegal allocation-space value: ~S."
:format-arguments
(
list
bazfaz
)))))
(
def-internal-error
30
:error
fatal
"Illegal u-vector access type: ~s."
arg3
)
(
def-internal-error
31
:error
fatal
"Illegal vector length: ~s."
arg3
)
(
def-internal-error
32
:error
fatal
"Vector index, ~s, out of bounds."
arg3
)
(
def-internal-error
33
:error
fatal
"Illegal index: ~s."
arg3
)
(
def-internal-error
34
:error
fatal
"Illegal shrink value: ~s."
arg3
)
(
def-internal-error
35
:error
fatal
"Shrink value, ~s, is greater than current length of ~s."
arg3
arg4
)
(
def-internal-error
36
:error
fatal
"Illegal data vector, ~S, in an array."
arg3
)
(
def-internal-error
37
:error
fatal
"Too few arguments passed to two or three dimension array access miscop."
)
(
def-internal-error
38
:error
fatal
"Too many arguments passed to two or three dimension array access miscop."
)
(
def-internal-error
39
:error
fatal
"Illegal to allocate vector of size: ~s."
arg3
)
(
def-internal-error
40
:error
fatal
"Illegal byte pointer: (byte ~s ~s)."
arg3
arg4
)
(
def-internal-error
41
:error
fatal
"Illegal position, ~s, in byte spec."
arg3
)
(
def-internal-error
42
:error
fatal
"Illegal size, ~s, in byte spec."
arg3
)
(
def-internal-error
43
:error
fatal
"Illegal shift count: ~s."
arg3
)
(
def-internal-error
44
:error
fatal
"Illegal boole operation: ~s."
arg3
)
(
def-internal-error
50
:error
fatal
"Wrong number of arguments: ~D."
arg3
)
(
def-internal-error
55
:error
fatal
"~s is not <= to ~s (Alien index out of bounds.)"
arg3
arg4
)
(
def-internal-error
60
:error
fatal
"Attempt to divide ~s by ~s."
arg3
arg4
)
(
def-internal-error
61
:unseen-throw-tag
fatal
"No catcher for throw tag ~s."
arg3
)
(
def-internal-error
62
:error
fatal
"Something using ~S and ~S lead to a short-float underflow."
arg3
arg4
)
(
def-internal-error
63
:error
fatal
"Something using ~S and ~S lead to a short-float overflow."
arg3
arg4
)
#|
(def-internal-error 64 :error fatal
"Something using ~S and ~S lead to a single-float underflow." arg3 arg4)
(def-internal-error 65 :error fatal
"Something using ~S and ~S lead to a single-float overflow." arg3 arg4)
|#
(
def-internal-error
66
:error
fatal
"Something using ~S and ~S lead to a long-float underflow."
arg3
arg4
)
(
def-internal-error
67
:error
fatal
"Something using ~S and ~S lead to a long-float overflow."
arg3
arg4
)
(
def-internal-error
68
:error
fatal
"Something using ~S caused a short-float underflow."
arg3
)
(
def-internal-error
69
:error
fatal
"Something using ~S caused a short-float overflow."
arg3
)
(
def-internal-error
70
:error
fatal
"Something using ~S caused a long-float underflow."
arg3
)
(
def-internal-error
71
:error
fatal
"Something using ~S caused a long-float overflow."
arg3
)
(
def-internal-error
72
:error
fatal
"~S is not a legal argument to log, it should be non-zero."
arg3
)
(
def-internal-error
73
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'string-char
)
(
def-internal-error
74
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'short-float
)
(
def-internal-error
75
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'long-float
)
(
def-internal-error
76
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'fixnum
)
(
def-internal-error
77
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'cons
)
(
def-internal-error
78
:error
fatal
"Invalid exit."
)
(
def-internal-error
79
:error
fatal
"Odd number of arguments in keyword part of argument list."
)
(
def-internal-error
80
:error
fatal
"~S is not a known keyword argument specifier."
arg3
)
(
def-internal-error
81
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
arg4
)
(
def-internal-error
82
:wrong-type-argument
fatal
"Wrong type argument, ~s, should have been of type ~s."
arg3
'
(
or
function
symbol
))
(
def-internal-error
83
:error
fatal
"~S is not = to ~S (Alien index out of bounds.)"
arg3
arg4
)
)
;;; ERROR-INIT is called at init time to initialize the error system.
;;; It initializes the internal error table, and sets a variable.
;;;
(
defun
error-init
()
(
make-error-table
)
(
setq
*error-system-initialized*
t
))
#-
new-compiler
(
eval-when
(
compile
)
(
setq
lisp::*bootstrap-defmacro*
nil
))
code/fd-stream.lisp
View file @
66a7c310
This diff is collapsed.
Click to expand it.
code/fdefinition.lisp
View file @
66a7c310
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v
1.1.
1.2 1990/0
4
/2
0 00:36:19
wlott Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fdefinition.lisp,v 1.2 1990/0
8
/2
4 18:10:58
wlott Exp $
;;;
;;; Functions that hack on the global function namespace (primarily
;;; concerned with SETF functions here.)
...
...
code/filesys.lisp
View file @
66a7c310
...
...
@@ -7,6 +7,8 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/filesys.lisp,v 1.3 1990/08/24 18:11:00 wlott Exp $
;;;
;;; Ugly pathname functions for Spice Lisp.
;;; these functions are part of the standard Spice Lisp environment.
;;;
...
...
@@ -42,8 +44,12 @@
"Set to the default pathname-defaults pathname (Got that?)"
)
(
defun
filesys-init
()
(
setq
*default-pathname-defaults*
(
%make-pathname
"Mach"
nil
nil
nil
nil
nil
)))
(
setq
*default-pathname-defaults*
(
%make-pathname
"Mach"
nil
nil
nil
nil
nil
))
(
multiple-value-bind
(
won
dir
)
(
mach:unix-current-directory
)
(
when
won
(
setf
(
search-list
"default:"
)
(
list
dir
)))))
;;; The pathname type is defined with a defstruct.
...
...
@@ -316,7 +322,7 @@
((
zerop
q
)
(
incf
i
)
(
replace
res
res
:start2
i
:end2
len
)
(
%primitive
shrink-vector
res
(
-
len
i
)))
(
shrink-vector
res
(
-
len
i
)))
(
declare
(
simple-string
res
)
(
fixnum
len
i
r
))
(
multiple-value-setq
(
q
r
)
(
truncate
q
10
))
...
...
@@ -1092,8 +1098,8 @@
(
multiple-value-bind
(
gr
dir-or-error
)
(
mach:unix-current-directory
)
(
if
gr
dir-or-error
(
error
(
mach:get-unix-error-msg
dir-or-error
))))
)
(
pathname
(
concatenate
'simple-string
dir-or-error
"/"
))
(
error
dir-or-error
))))
;;;
;;; Maybe this shouldn't go here...
...
...
@@ -1109,5 +1115,5 @@
(
mach:unix-chdir
(
predict-name
new-val
nil
))
(
if
gr
(
car
(
setf
(
search-list
"default:"
)
(
cdr
(
multiple-value-list
(
mach:unix-curren
t-directory
))))
)
(
list
(
defaul
t-directory
))))
(
error
(
mach:get-unix-error-msg
error
)))))
code/format.lisp
View file @
66a7c310
...
...
@@ -948,33 +948,19 @@
(
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
)
(
write-string
(
if
longp
"Control-"
"C-"
)))
(
when
(
char-bit
char
:meta
)
(
write-string
(
if
longp
"Meta-"
"M-"
)))
(
when
(
char-bit
char
:super
)
(
write-string
(
if
longp
"Super-"
"S-"
)))
(
when
(
char-bit
char
:hyper
)
(
write-string
(
if
longp
"Hyper-"
"H-"
)))
(
let*
((
ch
(
code-char
(
char-code
char
)))
;strip funny bits
(
name
(
char-name
ch
)))
(
defun
format-print-named-character
(
char
)
(
let*
((
name
(
char-name
char
)))
(
cond
(
name
(
write-string
(
string-capitalize
name
)))
;; Print control characters as "^"<char>
((
<=
0
(
the
fixnum
(
char-code
char
))
31
)
(
write-char
#\^
)
(
write-char
(
code-char
(
+
64
(
the
fixnum
(
char-code
char
))))))
(
t
(
write-char
ch
)))))
(
t
(
write-char
char
)))))
;;;; NUMERIC PRINTING
...
...
@@ -1227,45 +1213,54 @@
(
format-fixed-aux
number
w
d
k
ovf
pad
atsign
)
(
if
(
rationalp
number
)
(
format-fixed-aux
(
coerce
number
's
hort
-float
)
w
d
k
ovf
pad
atsign
)
(
coerce
number
's
ingle
-float
)
w
d
k
ovf
pad
atsign
)
(
let
((
*print-base*
10
))
(
format-write-field
(
princ-to-string
number
)
w
1
0
#\space
t
)))))))
;;; We return true if we overflowed, so that ~G can output the overflow char
;;; instead of spaces.
;;;
(
defun
format-fixed-aux
(
number
w
d
k
ovf
pad
atsign
)
(
if
(
not
(
or
w
d
))
(
prin1
number
)
(
let
((
spaceleft
w
))
(
when
(
and
w
(
or
atsign
(
minusp
number
)))
(
decf
spaceleft
))
(
multiple-value-bind
(
str
len
lpoint
tpoint
)
(
cond
((
not
(
or
w
d
))
(
prin1
number
)
nil
)
(
t
(
let
((
spaceleft
w
))
(
when
(
and
w
(
or
atsign
(
minusp
number
)))
(
decf
spaceleft
))
(
multiple-value-bind
(
str
len
lpoint
tpoint
)
(
flonum-to-string
(
abs
number
)
spaceleft
d
k
)
;;if caller specifically requested no fraction digits, suppress the
;;if caller specifically requested no fraction digits, suppress the
;;optional trailing zero
(
when
(
and
d
(
zerop
d
))
(
setq
tpoint
nil
))
(
when
w
(
decf
spaceleft
len
)
;;optional leading zero
(
when
lpoint
(
if
(
or
(
>
spaceleft
0
)
tpoint
)
;force at least one digit
(
decf
spaceleft
)
(
setq
lpoint
nil
)))
;;optional trailing zero
(
when
(
and
d
(
zerop
d
))
(
setq
tpoint
nil
))
(
when
w
(
decf
spaceleft
len
)
;;optional leading zero
(
when
lpoint
(
if
(
or
(
>
spaceleft
0
)
tpoint
)
;force at least one digit
(
decf
spaceleft
)