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
a6577064
Commit
a6577064
authored
Apr 20, 2010
by
rtoy
Browse files
Change uses of _"foo" to (intl:gettext "foo"). This is because slime
may get confused with source locations if the reader macros are installed.
parent
897e7991
Changes
136
Expand all
Hide whitespace changes
Inline
Side-by-side
code/alieneval.lisp
View file @
a6577064
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.6
8
2010/04/
19 02:18:0
3 rtoy
Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alieneval.lisp,v 1.6
9
2010/04/
20 17:57:4
3 rtoy
Rel
$"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -186,7 +186,7 @@
(
defun
alien-type-class-or-lose
(
name
)
(
or
(
gethash
name
*alien-type-classes*
)
(
error
_
"No alien type class ~S"
name
)))
(
error
(
intl:gettext
"No alien type class ~S"
)
name
)))
(
defun
create-alien-type-class-if-necessary
(
name
include
)
(
let
((
old
(
gethash
name
*alien-type-classes*
))
...
...
@@ -212,7 +212,7 @@
(
defun
method-slot
(
method
)
(
cdr
(
or
(
assoc
method
method-slot-alist
)
(
error
_
"No method ~S"
method
))))
(
error
(
intl:gettext
"No method ~S"
)
method
))))
)
; eval-when
...
...
@@ -275,7 +275,7 @@
`
(
funcall
(
do
((
class
(
alien-type-class-or-lose
(
alien-type-class
,
type
))
(
alien-type-class-include
class
)))
((
null
class
)
(
error
_
"Method ~S not defined for ~S"
(
error
(
intl:gettext
"Method ~S not defined for ~S"
)
',method
(
alien-type-class
,
type
)))
(
let
((
fn
(
,
slot
class
)))
(
when
fn
...
...
@@ -334,19 +334,19 @@
(
if
(
consp
type
)
(
let
((
translator
(
info
alien-type
translator
(
car
type
))))
(
unless
translator
(
error
_
"Unknown alien type: ~S"
type
))
(
error
(
intl:gettext
"Unknown alien type: ~S"
)
type
))
(
funcall
translator
type
))
(
case
(
info
alien-type
kind
type
)
(
:primitive
(
let
((
translator
(
info
alien-type
translator
type
)))
(
unless
translator
(
error
_
"No translator for primitive alien type ~S?"
type
))
(
error
(
intl:gettext
"No translator for primitive alien type ~S?"
)
type
))
(
funcall
translator
(
list
type
))))
(
:defined
(
or
(
info
alien-type
definition
type
)
(
error
_
"Definition missing for alien type ~S?"
type
)))
(
error
(
intl:gettext
"Definition missing for alien type ~S?"
)
type
)))
(
:unknown
(
error
_
"Unknown alien type: ~S"
type
)))))
(
error
(
intl:gettext
"Unknown alien type: ~S"
)
type
)))))
(
defun
auxiliary-alien-type
(
kind
name
)
(
flet
((
aux-defn-matches
(
x
)
...
...
@@ -368,9 +368,9 @@
(
flet
((
aux-defn-matches
(
x
)
(
and
(
eq
(
first
x
)
kind
)
(
eq
(
second
x
)
name
))))
(
when
(
find-if
#'
aux-defn-matches
*new-auxiliary-types*
)
(
error
_
"Attempt to multiple define ~A ~S."
kind
name
))
(
error
(
intl:gettext
"Attempt to multiple define ~A ~S."
)
kind
name
))
(
when
(
find-if
#'
aux-defn-matches
*auxiliary-type-definitions*
)
(
error
_
"Attempt to shadow definition of ~A ~S."
kind
name
)))
(
error
(
intl:gettext
"Attempt to shadow definition of ~A ~S."
)
kind
name
)))
(
push
(
list
kind
name
defn
)
*new-auxiliary-types*
)
defn
)
...
...
@@ -387,7 +387,7 @@
(
info
alien-type
union
name
))
(
:enum
(
info
alien-type
enum
name
)))
(
error
_
"Attempt to shadow definition of ~A ~S."
kind
name
)))))
(
error
(
intl:gettext
"Attempt to shadow definition of ~A ~S."
)
kind
name
)))))
;;; *record-type-already-unparsed* -- internal
;;;
...
...
@@ -464,7 +464,7 @@
(
macrolet
((
frob
(
kind
)
`
(
let
((
old
(
info
alien-type
,
kind
name
)))
(
unless
(
or
(
null
old
)
(
alien-type-=
old
defn
))
(
warn
_
"Redefining ~A ~S to be:~% ~S,~%was:~% ~S"
(
warn
(
intl:gettext
"Redefining ~A ~S to be:~% ~S,~%was:~% ~S"
)
kind
name
defn
old
))
(
setf
(
info
alien-type
,
kind
name
)
defn
))))
(
ecase
kind
...
...
@@ -475,11 +475,11 @@
(
defun
%def-alien-type
(
name
new
)
(
ecase
(
info
alien-type
kind
name
)
(
:primitive
(
error
_
"~S is a built-in alien type."
name
))
(
error
(
intl:gettext
"~S is a built-in alien type."
)
name
))
(
:defined
(
let
((
old
(
info
alien-type
definition
name
)))
(
unless
(
or
(
null
old
)
(
alien-type-=
new
old
))
(
warn
_
"Redefining ~S to be:~% ~S,~%was~% ~S"
name
(
warn
(
intl:gettext
"Redefining ~S to be:~% ~S,~%was~% ~S"
)
name
(
unparse-alien-type
new
)
(
unparse-alien-type
old
)))))
(
:unknown
))
(
setf
(
info
alien-type
definition
name
)
new
)
...
...
@@ -588,27 +588,27 @@
(
def-alien-type-method
(
root
:naturalize-gen
)
(
type
alien
)
(
declare
(
ignore
alien
))
(
error
_
"Cannot represent ~S typed aliens."
type
))
(
error
(
intl:gettext
"Cannot represent ~S typed aliens."
)
type
))
(
def-alien-type-method
(
root
:deport-gen
)
(
type
object
)
(
declare
(
ignore
object
))
(
error
_
"Cannot represent ~S typed aliens."
type
))
(
error
(
intl:gettext
"Cannot represent ~S typed aliens."
)
type
))
(
def-alien-type-method
(
root
:extract-gen
)
(
type
sap
offset
)
(
declare
(
ignore
sap
offset
))
(
error
_
"Cannot represent ~S typed aliens."
type
))
(
error
(
intl:gettext
"Cannot represent ~S typed aliens."
)
type
))
(
def-alien-type-method
(
root
:deposit-gen
)
(
type
sap
offset
value
)
`
(
setf
,
(
invoke-alien-type-method
:extract-gen
type
sap
offset
)
,
value
))
(
def-alien-type-method
(
root
:arg-tn
)
(
type
state
)
(
declare
(
ignore
state
))
(
error
_
"Cannot pass aliens of type ~S as arguments to call-out"
(
error
(
intl:gettext
"Cannot pass aliens of type ~S as arguments to call-out"
)
(
unparse-alien-type
type
)))
(
def-alien-type-method
(
root
:result-tn
)
(
type
state
)
(
declare
(
ignore
state
))
(
error
_
"Cannot return aliens of type ~S from call-out"
(
error
(
intl:gettext
"Cannot return aliens of type ~S from call-out"
)
(
unparse-alien-type
type
)))
...
...
@@ -685,7 +685,7 @@
(
64
'sap-ref-64
)))))
(
if
ref-fun
`
(
,
ref-fun
,
sap
(
/
,
offset
vm:byte-bits
))
(
error
_
"Cannot extract ~D bit integers."
(
error
(
intl:gettext
"Cannot extract ~D bit integers."
)
(
alien-integer-type-bits
type
)))))
...
...
@@ -731,7 +731,7 @@
(
auxiliary-alien-type
:enum
name
)
(
when
old-p
(
unless
(
alien-type-=
result
old
)
(
warn
_
"Redefining alien enum ~S"
name
)))
(
warn
(
intl:gettext
"Redefining alien enum ~S"
)
name
)))
;; I (rtoy) am not 100% sure about this. But compare
;; what this does with what PARSE-ALIEN-RECORD-TYPE
;; does. So, if we've seen this type before and it's
...
...
@@ -754,14 +754,14 @@
(
result
found
)
(
auxiliary-alien-type
:enum
name
)
(
unless
found
(
error
_
"Unknown enum type: ~S"
name
))
(
error
(
intl:gettext
"Unknown enum type: ~S"
)
name
))
result
))
(
t
(
error
_
"Empty enum type: ~S"
type
))))
(
error
(
intl:gettext
"Empty enum type: ~S"
)
type
))))
(
defun
parse-enum
(
name
elements
)
(
when
(
null
elements
)
(
error
_
"An enumeration must contain at least one element."
))
(
error
(
intl:gettext
"An enumeration must contain at least one element."
))
)
(
let
((
min
nil
)
(
max
nil
)
(
from-alist
())
...
...
@@ -775,15 +775,15 @@
(
values
el
(
1+
prev
)))
(
setf
prev
val
)
(
unless
(
keywordp
sym
)
(
error
_
"Enumeration element ~S is not a keyword."
sym
))
(
error
(
intl:gettext
"Enumeration element ~S is not a keyword."
)
sym
))
(
unless
(
integerp
val
)
(
error
_
"Element value ~S is not an integer."
val
))
(
error
(
intl:gettext
"Element value ~S is not an integer."
)
val
))
(
unless
(
and
max
(
>
max
val
))
(
setq
max
val
))
(
unless
(
and
min
(
<
min
val
))
(
setq
min
val
))
(
when
(
rassoc
val
from-alist
)
(
error
_
"Element value ~S used more than once."
val
))
(
error
(
intl:gettext
"Element value ~S used more than once."
)
val
))
(
when
(
assoc
sym
from-alist
:test
#'
eq
)
(
error
_
"Enumeration element ~S used more than once."
sym
))
(
error
(
intl:gettext
"Enumeration element ~S used more than once."
)
sym
))
(
push
(
cons
sym
val
)
from-alist
)))
(
let*
((
signed
(
minusp
min
))
(
min-bits
(
if
signed
...
...
@@ -791,7 +791,7 @@
(
integer-length
max
)))
(
integer-length
max
))))
(
when
(
>
min-bits
32
)
(
error
_
"Can't represent enums needing more than 32 bits."
))
(
error
(
intl:gettext
"Can't represent enums needing more than 32 bits."
))
)
(
setf
from-alist
(
sort
from-alist
#'
<
:key
#'
cdr
))
(
cond
;;
...
...
@@ -1022,7 +1022,7 @@
(
def-alien-type-method
(
mem-block
:deposit-gen
)
(
type
sap
offset
value
)
(
let
((
bits
(
alien-mem-block-type-bits
type
)))
(
unless
bits
(
error
_
"Cannot deposit aliens of type ~S (unknown size)."
type
))
(
error
(
intl:gettext
"Cannot deposit aliens of type ~S (unknown size)."
)
type
))
`
(
kernel:system-area-copy
,
value
0
,
sap
,
offset
',bits
)))
...
...
@@ -1035,12 +1035,12 @@
(
def-alien-type-translator
array
(
ele-type
&rest
dims
)
(
when
dims
(
unless
(
typep
(
first
dims
)
'
(
or
kernel:index
null
))
(
error
_
"First dimension is not a non-negative fixnum or NIL: ~S"
(
error
(
intl:gettext
"First dimension is not a non-negative fixnum or NIL: ~S"
)
(
first
dims
)))
(
let
((
loser
(
find-if-not
#'
(
lambda
(
x
)
(
typep
x
'kernel:index
))
(
rest
dims
))))
(
when
loser
(
error
_
"Dimension is not a non-negative fixnum: ~S"
loser
))))
(
error
(
intl:gettext
"Dimension is not a non-negative fixnum: ~S"
)
loser
))))
(
let
((
type
(
parse-alien-type
ele-type
)))
(
make-alien-array-type
...
...
@@ -1149,10 +1149,10 @@
:name
var
)))
(
push
parsed-field
parsed-fields
)
(
when
(
null
bits
)
(
error
_
"Unknown size: ~S"
(
error
(
intl:gettext
"Unknown size: ~S"
)
(
unparse-alien-type
field-type
)))
(
when
(
null
alignment
)
(
error
_
"Unknown alignment: ~S"
(
error
(
intl:gettext
"Unknown alignment: ~S"
)
(
unparse-alien-type
field-type
)))
(
setf
overall-alignment
(
max
overall-alignment
alignment
))
(
ecase
(
alien-record-type-kind
result
)
...
...
@@ -1270,7 +1270,7 @@ If so return true; otherwise call ALTERNATIVE."
(
def-alien-type-translator
values
(
&rest
values
)
(
unless
*values-type-okay*
(
error
_
"Cannot use values types here."
))
(
error
(
intl:gettext
"Cannot use values types here."
))
)
(
let
((
*values-type-okay*
nil
))
(
make-alien-values-type
:values
(
mapcar
#'
parse-alien-type
values
))))
...
...
@@ -1368,7 +1368,7 @@ If so return true; otherwise call ALTERNATIVE."
(
values
name
(
guess-alien-name-from-lisp-name
name
)))
(
list
(
unless
(
=
(
length
name
)
2
)
(
error
_
"Badly formed alien name."
))
(
error
(
intl:gettext
"Badly formed alien name."
))
)
(
values
(
cadr
name
)
(
car
name
)))))
;;; DEF-ALIEN-VARIABLE -- public
...
...
@@ -1532,7 +1532,7 @@ If so return true; otherwise call ALTERNATIVE."
(
let
((
alien-type
(
parse-alien-type
type
)))
(
if
(
eq
(
compute-alien-rep-type
alien-type
)
'system-area-pointer
)
`
(
%sap-alien
,
sap
',alien-type
)
(
error
_
"Cannot make aliens of type ~S out of SAPs"
type
))))
(
error
(
intl:gettext
"Cannot make aliens of type ~S out of SAPs"
)
type
))))
(
defun
%sap-alien
(
sap
type
)
(
declare
(
type
system-area-pointer
sap
)
...
...
@@ -1566,7 +1566,7 @@ If so return true; otherwise call ALTERNATIVE."
(
size
(
unless
dims
(
error
_
"Cannot override the size of zero-dimensional arrays."
))
(
intl:gettext
"Cannot override the size of zero-dimensional arrays."
))
)
(
when
(
constantp
size
)
(
setf
alien-type
(
copy-alien-array-type
alien-type
))
(
setf
(
alien-array-type-dimensions
alien-type
)
...
...
@@ -1581,9 +1581,9 @@ If so return true; otherwise call ALTERNATIVE."
(
let
((
bits
(
alien-type-bits
element-type
))
(
alignment
(
alien-type-alignment
element-type
)))
(
unless
bits
(
error
_
"Size of ~S unknown."
(
unparse-alien-type
element-type
)))
(
error
(
intl:gettext
"Size of ~S unknown."
)
(
unparse-alien-type
element-type
)))
(
unless
alignment
(
error
_
"Alignment of ~S unknown."
(
unparse-alien-type
element-type
)))
(
error
(
intl:gettext
"Alignment of ~S unknown."
)
(
unparse-alien-type
element-type
)))
`
(
%sap-alien
(
%make-alien
(
*
,
(
align-offset
bits
alignment
)
,
size-expr
))
',
(
make-alien-pointer-type
:to
alien-type
))))))
...
...
@@ -1621,7 +1621,7 @@ If so return true; otherwise call ALTERNATIVE."
(
type
symbol
slot
))
(
or
(
find
slot
(
alien-record-type-fields
type
)
:key
#'
alien-record-field-name
)
(
error
_
"No slot named ~S in ~S"
slot
type
)))
(
error
(
intl:gettext
"No slot named ~S in ~S"
)
slot
type
)))
;;; SLOT -- public
;;;
...
...
@@ -1701,7 +1701,7 @@ If so return true; otherwise call ALTERNATIVE."
(
etypecase
type
(
alien-pointer-type
(
when
(
cdr
indices
)
(
error
_
"Too many indices when derefing ~S: ~D"
(
error
(
intl:gettext
"Too many indices when derefing ~S: ~D"
)
type
(
length
indices
)))
(
let
((
element-type
(
alien-pointer-type-to
type
)))
...
...
@@ -1713,7 +1713,7 @@ If so return true; otherwise call ALTERNATIVE."
0
))))
(
alien-array-type
(
unless
(
=
(
length
indices
)
(
length
(
alien-array-type-dimensions
type
)))
(
error
_
"Incorrect number of indices when derefing ~S: ~D"
(
error
(
intl:gettext
"Incorrect number of indices when derefing ~S: ~D"
)
type
(
length
indices
)))
(
labels
((
frob
(
dims
indices
offset
)
(
if
(
null
dims
)
...
...
@@ -1835,7 +1835,7 @@ If so return true; otherwise call ALTERNATIVE."
(
info
(
if
(
and
(
consp
info
)
(
eq
(
car
info
)
'quote
))
(
second
info
)
(
error
_
"Something is wrong; local-alien-info not found: ~S"
(
error
(
intl:gettext
"Something is wrong; local-alien-info not found: ~S"
)
whole
))))
(
values
nil
nil
...
...
@@ -1854,7 +1854,7 @@ If so return true; otherwise call ALTERNATIVE."
(
defun
%local-alien-addr
(
info
alien
)
(
declare
(
type
local-alien-info
info
))
(
unless
(
local-alien-info-force-to-memory-p
info
)
(
error
_
"~S isn't forced to memory. Something went wrong."
alien
))
(
error
(
intl:gettext
"~S isn't forced to memory. Something went wrong."
)
alien
))
alien
)
(
defun
dispose-local-alien
(
info
alien
)
...
...
@@ -1885,7 +1885,7 @@ If so return true; otherwise call ALTERNATIVE."
(
eq
(
car
info-arg
)
'quote
)
(
second
info-arg
)))))
(
unless
(
local-alien-info-p
info
)
(
error
_
"Something is wrong, local-alien-info not found: ~S"
(
error
(
intl:gettext
"Something is wrong, local-alien-info not found: ~S"
)
form
))
(
setf
(
local-alien-info-force-to-memory-p
info
)
t
))
(
cons
'%local-alien-addr
(
cdr
form
)))))
...
...
@@ -1893,7 +1893,7 @@ If so return true; otherwise call ALTERNATIVE."
(
let
((
kind
(
info
variable
kind
form
)))
(
when
(
eq
kind
:alien
)
`
(
%heap-alien-addr
',
(
info
variable
alien-info
form
))))))
(
error
_
"~S is not a valid L-value"
form
))))
(
error
(
intl:gettext
"~S is not a valid L-value"
)
form
))))
;;;; The CAST macro.
...
...
@@ -1916,8 +1916,8 @@ If so return true; otherwise call ALTERNATIVE."
(
alien-array-type-p
alien-type
)
(
alien-function-type-p
alien-type
))
(
naturalize
(
alien-value-sap
alien
)
target-type
)
(
error
_
"~S cannot be cast."
alien
)))
(
error
_
"Cannot cast to alien type ~S"
(
unparse-alien-type
target-type
))))
(
error
(
intl:gettext
"~S cannot be cast."
)
alien
)))
(
error
(
intl:gettext
"Cannot cast to alien type ~S"
)
(
unparse-alien-type
target-type
))))
...
...
@@ -1934,7 +1934,7 @@ If so return true; otherwise call ALTERNATIVE."
(
:bits
1
)
(
:bytes
vm:byte-bits
)
(
:words
vm:word-bits
))))
(
error
_
"Unknown size for alien type ~S."
(
error
(
intl:gettext
"Unknown size for alien type ~S."
)
(
unparse-alien-type
alien-type
)))))
...
...
@@ -1980,7 +1980,7 @@ If so return true; otherwise call ALTERNATIVE."
(
alien-function-type
(
unless
(
=
(
length
(
alien-function-type-arg-types
type
))
(
length
args
))
(
error
_
"Wrong number of arguments for ~S~%Expected ~D, got ~D."
(
error
(
intl:gettext
"Wrong number of arguments for ~S~%Expected ~D, got ~D."
)
type
(
length
(
alien-function-type-arg-types
type
))
(
length
args
)))
...
...
@@ -1996,7 +1996,7 @@ If so return true; otherwise call ALTERNATIVE."
(
setf
(
alien-function-type-stub
type
)
stub
))
(
apply
stub
alien
args
)))
(
t
(
error
_
"~S is not an alien function."
alien
)))))
(
error
(
intl:gettext
"~S is not an alien function."
)
alien
)))))
(
defmacro
def-alien-routine
(
name
result-type
&rest
args
)
"Def-Alien-Routine Name Result-Type
...
...
@@ -2043,12 +2043,12 @@ If so return true; otherwise call ALTERNATIVE."
(
docs
arg
)
(
destructuring-bind
(
name
type
&optional
(
style
:in
))
arg
(
unless
(
member
style
'
(
:in
:copy
:out
:in-out
))
(
error
_
"Bogus argument style ~S in ~S."
style
arg
))
(
error
(
intl:gettext
"Bogus argument style ~S in ~S."
)
style
arg
))
(
unless
(
eq
style
:out
)
(
lisp-args
name
))
(
when
(
and
(
member
style
'
(
:out
:in-out
))
(
typep
(
parse-alien-type
type
)
'alien-pointer-type
))
(
error
_
"Can't use :out or :in-out on pointer-like type:~% ~S"
(
error
(
intl:gettext
"Can't use :out or :in-out on pointer-like type:~% ~S"
)
type
))
(
cond
((
eq
style
:in
)
(
arg-types
type
)
...
...
@@ -2229,7 +2229,7 @@ type and arg types), so we can detect incompatible redefinitions."
(
len
(
*
page-size
(
ceiling
length
page-size
))))
(
unless
(
unix::unix-mprotect
code-base
len
(
logior
unix:prot_exec
unix:prot_read
unix:prot_write
))
(
warn
_
"Unable to mprotect ~S bytes (~S) at ~S (~S). Callbacks may not work."
(
warn
(
intl:gettext
"Unable to mprotect ~S bytes (~S) at ~S (~S). Callbacks may not work."
)
len
length
code-base
code
)))
(
new-assem:segment-map-output
segment
(
lambda
(
sap
length
)
...
...
@@ -2271,12 +2271,12 @@ type and arg types), so we can detect incompatible redefinitions."
(
setf
(
callback-function-type
callback
)
fn-type
)
callback
)
(
t
(
let
((
e
(
format
nil
_
"~
(
let
((
e
(
format
nil
(
intl:gettext
"~
Attempt to redefine callback with incompatible return type.
Old type was: ~A
New type is: ~A"
old-type
fn-type
))
(
c
(
format
nil
_
"~
Create new trampoline (old trampoline calls old lisp function)."
)))
New type is: ~A"
)
old-type
fn-type
))
(
c
(
format
nil
(
intl:gettext
"~
Create new trampoline (old trampoline calls old lisp function)."
)))
)
(
cerror
c
e
)
(
register-new-callback
))))))
(
t
(
register-new-callback
))))
...
...
@@ -2290,7 +2290,7 @@ Create new trampoline (old trampoline calls old lisp function).")))
(
typecase
type
((
or
integer$
single$
double$
pointer$
sap$
)
(
ceiling
(
word-aligned-bits
type
)
vm:byte-bits
))
(
t
(
error
_
"Unsupported argument type: ~A"
spec
)))))
(
t
(
error
(
intl:gettext
"Unsupported argument type: ~A"
)
spec
)))))
(
defun
parse-return-type
(
spec
)
(
let
((
*values-type-okay*
t
))
...
...
@@ -2311,7 +2311,7 @@ Create new trampoline (old trampoline calls old lisp function).")))
(
store
`
(
unsigned
,
(
word-aligned-bits
type
))))
((
or
single$
double$
pointer$
sap$
)
(
store
spec
))
(
t
(
error
_
"Unsupported return type: ~A"
spec
))))))
(
t
(
error
(
intl:gettext
"Unsupported return type: ~A"
)
spec
))))))
(
defmacro
def-callback
(
name
(
return-type
&rest
arg-specs
)
&parse-body
(
body
decls
doc
))
"(defcallback NAME (RETURN-TYPE {(ARG-NAME ARG-TYPE)}*)
...
...
code/alpha-vm.lisp
View file @
a6577064
...
...
@@ -5,11 +5,11 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alpha-vm.lisp,v 1.
7
2010/04/
19 02:18:0
3 rtoy
Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alpha-vm.lisp,v 1.
8
2010/04/
20 17:57:4
3 rtoy
Rel
$"
)
;;;
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alpha-vm.lisp,v 1.
7
2010/04/
19 02:18:0
3 rtoy
Exp
$
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/alpha-vm.lisp,v 1.
8
2010/04/
20 17:57:4
3 rtoy
Rel
$
;;;
;;; This file contains the Alpha specific runtime stuff.
;;;
...
...
@@ -75,7 +75,7 @@
;;;
(
defun
fixup-code-object
(
code
offset
value
kind
)
(
unless
(
zerop
(
rem
offset
word-bytes
))
(
error
_
"Unaligned instruction? offset=#x~X."
offset
))
(
error
(
intl:gettext
"Unaligned instruction? offset=#x~X."
)
offset
))
(
system:without-gcing
(
let
((
sap
(
truly-the
system-area-pointer
(
%primitive
c::code-instructions
code
))))
...
...
@@ -227,7 +227,7 @@
value
(
let
((
value
(
system:alternate-get-global-address
name
)))
(
when
(
zerop
value
)
(
error
_
"Unknown foreign symbol: ~S"
name
))
(
error
(
intl:gettext
"Unknown foreign symbol: ~S"
)
name
))
value
))))))
...
...
code/amd64-vm.lisp
View file @
a6577064
...
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/amd64-vm.lisp,v 1.
6
2010/04/
19 02:18:0
3 rtoy
Exp
$"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/amd64-vm.lisp,v 1.
7
2010/04/
20 17:57:4
3 rtoy
Rel
$"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -230,7 +230,7 @@
(
ncode-words
(
kernel:code-header-ref
code
1
))
(
code-end-addr
(
+
code-start-addr
(
*
ncode-words
8
))))
(
unless
(
member
kind
'
(
:absolute
:relative
))
(
error
_
"Unknown code-object-fixup kind ~s."
kind
))
(
error
(
intl:gettext
"Unknown code-object-fixup kind ~s."
)
kind
))
(
ecase
kind
(
:absolute
;; Word at sap + offset contains a value to be replaced by
...
...
@@ -470,7 +470,7 @@
value
(
let
((
value
(
system:alternate-get-global-address
name
)))
(
when
(
zerop
value
)
(
error
_
"Unknown foreign symbol: ~S"
name
))
(
error
(
intl:gettext
"Unknown foreign symbol: ~S"
)
name
))
value
))))))
...
...
code/array.lisp
View file @
a6577064
...
...
@@ -5,7 +5,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.5
3
2010/04/
19 02:18:0
3 rtoy Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/array.lisp,v 1.5
4
2010/04/
20 17:57:4
3 rtoy Exp $"
)
;;;
;;; **********************************************************************
;;;
...
...
@@ -88,12 +88,12 @@
(
let*
((
size
(
array-total-size
array
))
(
end
(
cond
(
end
(
unless
(
<=
end
size
)
(
error
_
"End ~D is greater than total size ~D."
(
error
(
intl:gettext
"End ~D is greater than total size ~D."
)
end
size
))
end
)
(
t
size
))))
(
when
(
>
start
end
)
(
error
_
"Start ~D is greater than end ~D."
start
end
))
(
error
(
intl:gettext
"Start ~D is greater than end ~D."
)
start
end
))
(
do
((
data
array
(
%array-data-vector
data
))
(
cumulative-offset
0
(
+
cumulative-offset
...
...
@@ -181,7 +181,7 @@
#.
vm:simple-array-double-float-type
#.
vm:simple-array-complex-single-float-type
#.
vm:simple-array-complex-double-float-type
))
(
error
_
"Cannot make a static array of element type ~S"
element-type
))
(
error
(
intl:gettext
"Cannot make a static array of element type ~S"
)
element-type
))
;; Malloc space for the vector. We need enough space for the data
;; itself, and then 2 words for the vector header (header word and
;; length). Use calloc to make sure the area is initialized to
...
...
@@ -198,7 +198,7 @@
;; Malloc should return double-word (8 byte) alignment.
(
assert
(
zerop
(
logand
7
(
sys:sap-int
pointer
))))
(
when
(
zerop
(
sys:sap-int
pointer
))
(
error
_
"Failed to allocate space for static array of length ~S of type ~S"
(
error
(
intl:gettext
"Failed to allocate space for static array of length ~S of type ~S"
)
length
element-type
))
;; Fill in the vector header word and length word. Set the data
...
...
@@ -251,11 +251,11 @@
(
null
displaced-to
))))
(
declare
(
fixnum
array-rank
))
(
when
(
and
displaced-index-offset
(
null
displaced-to
))
(
error
_
"Can't specify :displaced-index-offset without :displaced-to"
))
(
error
(
intl:gettext
"Can't specify :displaced-index-offset without :displaced-to"
))
)
(
when
(
and
adjustable
static-array-p
)
(
error
_
"Cannot make an adjustable static array"
))
(
error
(
intl:gettext
"Cannot make an adjustable static array"
))
)
(
when
(
and
displaced-to
static-array-p
)
(
error
_
"Cannot make a displaced array static"
))
(
error
(
intl:gettext
"Cannot make a displaced array static"
))
)
(
if
(
and
simple
(
=
array-rank
1
))
;; It's a (simple-array * (*))
(
multiple-value-bind
(
type
bits
)
...
...
@@ -278,11 +278,11 @@
(
fill
array
initial-element
))
(
when
initial-contents-p
(
when
initial-element-p
(
error
_
"Cannot specify both :initial-element and ~
:initial-contents"
))
(
error
(
intl:gettext
"Cannot specify both :initial-element and ~
:initial-contents"
))
)
(
unless
(
=
length
(
length
initial-contents
))
(
error
_
"~D elements in the initial-contents, but the ~
vector length is ~D."
(
error
(
intl:gettext
"~D elements in the initial-contents, but the ~
vector length is ~D."
)
(
length
initial-contents
)
length
))
(
replace
array
initial-contents
))
...
...
@@ -303,7 +303,7 @@
array-rank
)))
(
cond
(
fill-pointer
(
unless
(
=
array-rank
1
)
(
error
_
"Only vectors can have fill pointers."
))
(
error
(
intl:gettext
"Only vectors can have fill pointers."
))
)
(
let
((
length
(
car
dimensions
)))
(
declare
(
fixnum
length
))
(
setf
(
%array-fill-pointer
array
)
...
...
@@ -313,7 +313,7 @@
(
unless
(
and
(
fixnump
fill-pointer
)
(
>=
fill-pointer
0
)
(
<=
fill-pointer
length
))
(
error
_
"Invalid fill-pointer ~D"
(
error
(
intl:gettext
"Invalid fill-pointer ~D"
)
fill-pointer
))
fill-pointer
))))
(
setf
(
%array-fill-pointer-p
array
)
t
))
...
...
@@ -324,8 +324,8 @@
(
setf
(
%array-data-vector
array
)
data
)
(
cond
(
displaced-to
(
when
(
or
initial-element-p
initial-contents-p
)
(
error
_
"Neither :initial-element nor :initial-contents ~
can be specified along with :displaced-to"
))
(
error
(
intl:gettext
"Neither :initial-element nor :initial-contents ~
can be specified along with :displaced-to"
))
)
;; The CLHS entry for MAKE-ARRAY says that if the
;; actual array element types are not type equivalent
;; (subtypes of each other), the consequences are
...
...
@@ -334,13 +334,13 @@
(
array-element-type
displaced-to
))
(
subtypep
(
array-element-type
displaced-to
)
(
upgraded-array-element-type
element-type
)))
(
error
_
"One can't displace an array of type ~S into ~
another of type ~S."
(
error
(
intl:gettext
"One can't displace an array of type ~S into ~
another of type ~S."
)
element-type
(
array-element-type
displaced-to
)))
(
let
((
offset
(
or
displaced-index-offset
0
)))
(
when
(
>
(
+
offset
total-size
)
(
array-total-size
displaced-to
))
(
error
_
"~S doesn't have enough elements."
displaced-to
))
(
error
(
intl:gettext
"~S doesn't have enough elements."
)
displaced-to
))
(
setf
(
%array-displacement
array
)
offset
)
(
setf
(
%array-displaced-p
array
)
t
)))
(
t
...
...
@@ -362,7 +362,7 @@
(
defun
free-static-vector
(
vector
)
(
sys:without-gcing
(
let
((
addr
(
logandc1
vm:lowtag-mask
(
kernel:get-lisp-obj-address
vector
))))
(
format
t
_
"~&Freeing foreign vector at #x~X~%"
addr
)
(
format
t
(
intl:gettext
"~&Freeing foreign vector at #x~X~%"
)
addr
)
(
alien:alien-funcall
(
alien:extern-alien
"free"
(
function
c-call:void
...
...
@@ -378,7 +378,7 @@
;; gencgc.c.
(
when
*static-vectors*
(
let
((
*print-array*
nil
))