including the name BACKTRACE, not (as in 0.pre7.88)
just "0: (\"hairy arg processor\" ...)"
* more renaming in global external names:
- ** used DEFINE-THE-FOO-THING and DEFFOO style consistently (and
- deprecated supported extensions named in the DEF-FOO
- style, e.g. SB-ALIEN:DEF-ALIEN-ROUTINE)
** reserved DO-FOO-style names for iteration macros
** finished s/FUNCTION/FUN/
** s/VARIABLE/VAR/
("src/code/target-c-call" :not-host)
("src/code/target-allocate" :not-host)
- ;; This needs DEF-ALIEN-ROUTINE from target-alieneval.
+ ;; This needs DEFINE-ALIEN-ROUTINE from target-alieneval.
("src/code/misc-aliens" :not-host)
("src/code/array" :not-host)
;; for DEFSTRUCT ALIEN-TYPE, needed by host-type.lisp
("src/code/host-alieneval")
- ;; can't be done until definition of e.g. DEF-ALIEN-TYPE-CLASS in
+ ;; can't be done until definition of e.g. DEFINE-ALIEN-TYPE-CLASS in
;; host-alieneval.lisp
("src/code/host-c-call")
_ \code{*print-length*} are used.
_ \end{defvar}
_
-_ \begin{defmac}{extensions:}{def-source-context}{%
+_ \begin{defmac}{extensions:}{define-source-context}{%
_ \args{\var{name} \var{lambda-list} \mstar{form}}}
_
_ This macro defines how to extract an abbreviated source context from
there's a builtin operator to do it, you don't need to
do the nasty idiom the manual says you need to do. -->
<!-- FIXME: Also, the CMU CL alien documentation claims you
- can just do (DEF-ALIEN-VARIABLE "errno" INT), which fails
+ can just do (DEFINE-ALIEN-VARIABLE "errno" INT), which fails
with modern multithreading hacks. -->
<!-- FIXME: Also, LOAD-FOREIGN isn't implemented as of sbcl-0.6.7,
but LOAD-1-FOREIGN is. -->
"VALUES" "*")
:export ("ADDR" "ALIEN" "ALIEN-FUNCALL" "ALIEN-SAP" "ALIEN-SIZE"
"CAST"
- "DEF-ALIEN-ROUTINE" "DEF-ALIEN-TYPE"
- "DEF-ALIEN-VARIABLE" "DEF-BUILTIN-ALIEN-TYPE"
+ "DEFINE-ALIEN-ROUTINE" "DEFINE-ALIEN-TYPE" "DEFINE-ALIEN-VARIABLE"
+
+ ;; FIXME: These old names don't match the DEFFOO - vs. -
+ ;; DEFINE-FOO convention used in the ANSI spec, and so
+ ;; were deprecated in sbcl-0.pre7, ca. 2001-12-12. After
+ ;; a year or so they can go away completely.
+ "DEF-ALIEN-ROUTINE" "DEF-ALIEN-TYPE" "DEF-ALIEN-VARIABLE"
+
"DEREF"
"ENUM" "EXTERN-ALIEN"
"FREE-ALIEN"
"ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "COMPUTE-ALIEN-REP-TYPE"
"COMPUTE-DEPORT-LAMBDA" "COMPUTE-DEPOSIT-LAMBDA"
"COMPUTE-EXTRACT-LAMBDA" "COMPUTE-LISP-REP-TYPE"
- "COMPUTE-NATURALIZE-LAMBDA" "DEF-ALIEN-TYPE-CLASS"
- "DEF-ALIEN-TYPE-METHOD" "DEF-ALIEN-TYPE-TRANSLATOR" "DEPORT"
+ "COMPUTE-NATURALIZE-LAMBDA" "DEFINE-ALIEN-TYPE-CLASS"
+ "DEFINE-ALIEN-TYPE-METHOD" "DEFINE-ALIEN-TYPE-TRANSLATOR" "DEPORT"
"DEPOSIT-ALIEN-VALUE" "DISPOSE-LOCAL-ALIEN" "EXTRACT-ALIEN-VALUE"
"HEAP-ALIEN-INFO" "HEAP-ALIEN-INFO-P" "HEAP-ALIEN-INFO-SAP-FORM"
"HEAP-ALIEN-INFO-TYPE" "INVOKE-ALIEN-TYPE-METHOD" "LOCAL-ALIEN"
"DEALLOC-NUMBER-STACK-SPACE" "DEF-BOOLEAN-ATTRIBUTE"
"DEF-IR1-TRANSLATOR"
"!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS"
- "DEF-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE"
+ "DEFINE-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE"
"DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUNCTION"
"DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE"
"DEFINE-STORAGE-CLASS" "DEFINE-VOP"
;; and for dedicated users who really want to customize
;; error reporting, we have
- "DEF-SOURCE-CONTEXT"
+ "DEFINE-SOURCE-CONTEXT"
+
+ ;; FIXME: This name doesn't match the DEFFOO - vs. -
+ ;; DEFINE-FOO convention used in the ANSI spec, and so
+ ;; was deprecated in sbcl-0.pre7, ca. 2001-12-12. After
+ ;; a year or so it can go away completely.
+ "DEF-SOURCE-CONTEXT"
;; FIXME: These seem like the right thing, but are they
;; consistent with ANSI? (And actually maybe they're not
"PSXHASH"
"%BREAK"
"NTH-BUT-WITH-SANE-ARG-ORDER"
+ "DEPRECATION-WARNING"
;; ..and macros..
"COLLECT"
(defvar *bits-per-word* 64)
;;; See x86-vm.lisp for a description of this.
-(def-alien-type os-context-t (struct os-context-t-struct))
+(define-alien-type os-context-t (struct os-context-t-struct))
\f
;;;; MACHINE-TYPE and MACHINE-VERSION
(assert (zerop (ldb (byte 2 0) value)))
#+nil
(setf (sap-ref-16 sap offset)
- (logior (sap-ref-16 sap offset) (ldb (byte 14 0) (ash value -2)))))
+ (logior (sap-ref-16 sap offset)
+ (ldb (byte 14 0) (ash value -2)))))
(:bits-63-48
(let* ((value (if (logbitp 15 value) (+ value (ash 1 16)) value))
(value (if (logbitp 31 value) (+ value (ash 1 32)) value))
(setf (sap-ref-8 sap offset) (ldb (byte 8 0) value))
(setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value)))))))
\f
-;;;; "Sigcontext" access functions, cut & pasted from x86-vm.lisp then
+;;;; "sigcontext" access functions, cut & pasted from x86-vm.lisp then
;;;; hacked for types.
;;;;
;;;; KLUDGE: The alpha has 64-bit registers, so these potentially
;;;;
;;;; See also x86-vm for commentary on signed vs unsigned.
-(def-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long)
+(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-long)
(context (* os-context-t)))
(defun context-pc (context)
(declare (type (alien (* os-context-t)) context))
(int-sap (deref (context-pc-addr context))))
-(def-alien-routine ("os_context_register_addr" context-register-addr)
+(define-alien-routine ("os_context_register_addr" context-register-addr)
(* unsigned-long)
(context (* os-context-t))
(index int))
;;; FIXME: Whether COERCE actually knows how to make a float out of a
;;; long is another question. This stuff still needs testing.
-(def-alien-routine ("os_context_fpregister_addr" context-float-register-addr)
+(define-alien-routine ("os_context_fpregister_addr"
+ context-float-register-addr)
(* long)
(context (* os-context-t))
(index int))
(zerop (logand (sap-int x) #b11))))
#!+x86
-(sb!alien:def-alien-routine component-ptr-from-pc (system-area-pointer)
+(sb!alien:define-alien-routine component-ptr-from-pc (system-area-pointer)
(pc system-area-pointer))
#!+x86
;;; returns the overwritten bits. You must call this in a context in
;;; which GC is disabled, so that Lisp doesn't move objects around
;;; that C is pointing to.
-(sb!alien:def-alien-routine "breakpoint_install" sb!c-call:unsigned-long
+(sb!alien:define-alien-routine "breakpoint_install" sb!c-call:unsigned-long
(code-obj sb!c-call:unsigned-long)
(pc-offset sb!c-call:int))
;;; This removes the break instruction and replaces the original
;;; instruction. You must call this in a context in which GC is disabled
;;; so Lisp doesn't move objects around that C is pointing to.
-(sb!alien:def-alien-routine "breakpoint_remove" sb!c-call:void
+(sb!alien:define-alien-routine "breakpoint_remove" sb!c-call:void
(code-obj sb!c-call:unsigned-long)
(pc-offset sb!c-call:int)
(old-inst sb!c-call:unsigned-long))
-(sb!alien:def-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void
+(sb!alien:define-alien-routine "breakpoint_do_displaced_inst" sb!c-call:void
(scp (* os-context-t))
(orig-inst sb!c-call:unsigned-long))
(if (typep possibly-logical-pathname 'logical-pathname)
(translate-logical-pathname possibly-logical-pathname)
possibly-logical-pathname))
+
+(defun deprecation-warning (bad-name &optional good-name)
+ (warn "using deprecated ~S~@[, should use ~S instead~]"
+ bad-name
+ good-name))
;; which are opaque at the Lisp level ca. sbcl-0.6.7. It needs to be
;; revived, which will require writing a C-level os-dependent
;; function to extract floating point modes, and a Lisp-level
- ;; DEF-ALIEN-ROUTINE to get to the C-level os-dependent function.
+ ;; DEFINE-ALIEN-ROUTINE to get to the C-level os-dependent function.
;; Meanwhile we just say "something went wrong".
(error 'floating-point-exception)
#|
(defvar *dso-linker-options* '("-G" "-o"))
-(sb-alien:def-alien-routine dlopen system-area-pointer
+(sb-alien:define-alien-routine dlopen system-area-pointer
(file sb-c-call:c-string) (mode sb-c-call:int))
-(sb-alien:def-alien-routine dlsym system-area-pointer
+(sb-alien:define-alien-routine dlsym system-area-pointer
(lib system-area-pointer)
(name sb-c-call:c-string))
-(sb-alien:def-alien-routine dlerror sb-c-call:c-string)
+(sb-alien:define-alien-routine dlerror sb-c-call:c-string)
;;; Ensure that we've opened our own binary so we can dynamically resolve
;;; symbols in the C runtime.
ld -shared -o /tmp/ffi-test.so /tmp/ffi-test.o
then in SBCL do this:
(LOAD-1-FOREIGN \"/tmp/ffi-test.so\")
- (DEF-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT))
+ (DEFINE-ALIEN-ROUTINE SUMMISH INT (X INT) (Y INT))
Now running (SUMMISH 10 20) should return 31.
"
(ensure-runtime-symbol-table-opened)
\f
;;;; internal GC
-(sb!alien:def-alien-routine collect-garbage sb!c-call:int
+(sb!alien:define-alien-routine collect-garbage sb!c-call:int
#!+gencgc (last-gen sb!c-call:int))
-(sb!alien:def-alien-routine set-auto-gc-trigger sb!c-call:void
+(sb!alien:define-alien-routine set-auto-gc-trigger sb!c-call:void
(dynamic-usage sb!c-call:unsigned-long))
-(sb!alien:def-alien-routine clear-auto-gc-trigger sb!c-call:void)
+(sb!alien:define-alien-routine clear-auto-gc-trigger sb!c-call:void)
;;; This variable contains the function that does the real GC. This is
;;; for low-level GC experimentation. Do not touch it if you do not
;;; We define a keyword "BOA" constructor so that we can reference the
;;; slot names in init forms.
-(def!macro def-alien-type-class ((name &key include include-args) &rest slots)
+(def!macro define-alien-type-class ((name &key include include-args)
+ &rest slots)
(let ((defstruct-name (symbolicate "ALIEN-" name "-TYPE")))
(multiple-value-bind (include include-defstruct overrides)
(etypecase include
,@include-args)))
,@slots)))))
-(def!macro def-alien-type-method ((class method) lambda-list &rest body)
+(def!macro define-alien-type-method ((class method) lambda-list &rest body)
(let ((defun-name (symbolicate class "-" method "-METHOD")))
`(progn
(defun ,defun-name ,lambda-list
\f
;;;; alien type defining stuff
-(def!macro def-alien-type-translator (name lambda-list &body body)
+(def!macro define-alien-type-translator (name lambda-list &body body)
(let ((whole (gensym "WHOLE"))
(env (gensym "ENV"))
(defun-name (symbolicate "ALIEN-" name "-TYPE-TRANSLATOR")))
(multiple-value-bind (body decls docs)
(sb!kernel:parse-defmacro lambda-list whole body name
- 'def-alien-type-translator
+ 'define-alien-type-translator
:environment env)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ,defun-name (,whole ,env)
,@decls
(block ,name
,body))
- (%def-alien-type-translator ',name #',defun-name ,docs)))))
+ (%define-alien-type-translator ',name #',defun-name ,docs)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun %def-alien-type-translator (name translator docs)
+ (defun %define-alien-type-translator (name translator docs)
(declare (ignore docs))
(setf (info :alien-type :kind name) :primitive)
(setf (info :alien-type :translator name) translator)
(setf (fdocumentation name 'alien-type) docs)
name))
-(def!macro def-alien-type (name type &environment env)
+(def!macro define-alien-type (name type &environment env)
#!+sb-doc
"Define the alien type NAME to be equivalent to TYPE. Name may be NIL for
STRUCT and UNION types, in which case the name is taken from the type
,@(when *new-auxiliary-types*
`((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
,@(when name
- `((%def-alien-type ',name ',alien-type)))))))
+ `((%define-alien-type ',name ',alien-type)))))))
+(def!macro def-alien-type (&rest rest)
+ (deprecation-warning 'def-alien-type 'define-alien-type)
+ `(define-alien-type ,@rest))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun %def-auxiliary-alien-types (types)
(:struct (frob :struct))
(:union (frob :union))
(:enum (frob :enum)))))))
- (defun %def-alien-type (name new)
+ (defun %define-alien-type (name new)
(ecase (info :alien-type :kind name)
(:primitive
(error "~S is a built-in alien type." name))
\f
;;;; the SAP type
-(def-alien-type-class (system-area-pointer))
+(define-alien-type-class (system-area-pointer))
-(def-alien-type-translator system-area-pointer ()
+(define-alien-type-translator system-area-pointer ()
(make-alien-system-area-pointer-type
:bits #!-alpha sb!vm:n-word-bits #!+alpha 64))
-(def-alien-type-method (system-area-pointer :unparse) (type)
+(define-alien-type-method (system-area-pointer :unparse) (type)
(declare (ignore type))
'system-area-pointer)
-(def-alien-type-method (system-area-pointer :lisp-rep) (type)
+(define-alien-type-method (system-area-pointer :lisp-rep) (type)
(declare (ignore type))
'system-area-pointer)
-(def-alien-type-method (system-area-pointer :alien-rep) (type)
+(define-alien-type-method (system-area-pointer :alien-rep) (type)
(declare (ignore type))
'system-area-pointer)
-(def-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
+(define-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
(declare (ignore type))
alien)
-(def-alien-type-method (system-area-pointer :deport-gen) (type object)
+(define-alien-type-method (system-area-pointer :deport-gen) (type object)
(declare (ignore type))
(/noshow "doing alien type method SYSTEM-AREA-POINTER :DEPORT-GEN" object)
object)
-(def-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
+(define-alien-type-method (system-area-pointer :extract-gen) (type sap offset)
(declare (ignore type))
`(sap-ref-sap ,sap (/ ,offset sb!vm:n-byte-bits)))
\f
;;;; the ALIEN-VALUE type
-(def-alien-type-class (alien-value :include system-area-pointer))
+(define-alien-type-class (alien-value :include system-area-pointer))
-(def-alien-type-method (alien-value :lisp-rep) (type)
+(define-alien-type-method (alien-value :lisp-rep) (type)
(declare (ignore type))
nil)
-(def-alien-type-method (alien-value :naturalize-gen) (type alien)
+(define-alien-type-method (alien-value :naturalize-gen) (type alien)
`(%sap-alien ,alien ',type))
-(def-alien-type-method (alien-value :deport-gen) (type value)
+(define-alien-type-method (alien-value :deport-gen) (type value)
(declare (ignore type))
(/noshow "doing alien type method ALIEN-VALUE :DEPORT-GEN" value)
`(alien-sap ,value))
\f
;;;; default methods
-(def-alien-type-method (root :unparse) (type)
+(define-alien-type-method (root :unparse) (type)
`(<unknown-alien-type> ,(type-of type)))
-(def-alien-type-method (root :type=) (type1 type2)
+(define-alien-type-method (root :type=) (type1 type2)
(declare (ignore type1 type2))
t)
-(def-alien-type-method (root :subtypep) (type1 type2)
+(define-alien-type-method (root :subtypep) (type1 type2)
(alien-type-= type1 type2))
-(def-alien-type-method (root :lisp-rep) (type)
+(define-alien-type-method (root :lisp-rep) (type)
(declare (ignore type))
nil)
-(def-alien-type-method (root :alien-rep) (type)
+(define-alien-type-method (root :alien-rep) (type)
(declare (ignore type))
'*)
-(def-alien-type-method (root :naturalize-gen) (type alien)
+(define-alien-type-method (root :naturalize-gen) (type alien)
(declare (ignore alien))
(error "cannot represent ~S typed aliens" type))
-(def-alien-type-method (root :deport-gen) (type object)
+(define-alien-type-method (root :deport-gen) (type object)
(declare (ignore object))
(error "cannot represent ~S typed aliens" type))
-(def-alien-type-method (root :extract-gen) (type sap offset)
+(define-alien-type-method (root :extract-gen) (type sap offset)
(declare (ignore sap offset))
(error "cannot represent ~S typed aliens" type))
-(def-alien-type-method (root :deposit-gen) (type sap offset value)
+(define-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)
+(define-alien-type-method (root :arg-tn) (type state)
(declare (ignore state))
(error "Aliens of type ~S cannot be passed as arguments to CALL-OUT."
(unparse-alien-type type)))
-(def-alien-type-method (root :result-tn) (type state)
+(define-alien-type-method (root :result-tn) (type state)
(declare (ignore state))
(error "Aliens of type ~S cannot be returned from CALL-OUT."
(unparse-alien-type type)))
\f
;;;; the INTEGER type
-(def-alien-type-class (integer)
+(define-alien-type-class (integer)
(signed t :type (member t nil)))
-(def-alien-type-translator signed (&optional (bits sb!vm:n-word-bits))
+(define-alien-type-translator signed (&optional (bits sb!vm:n-word-bits))
(make-alien-integer-type :bits bits))
-(def-alien-type-translator integer (&optional (bits sb!vm:n-word-bits))
+(define-alien-type-translator integer (&optional (bits sb!vm:n-word-bits))
(make-alien-integer-type :bits bits))
-(def-alien-type-translator unsigned (&optional (bits sb!vm:n-word-bits))
+(define-alien-type-translator unsigned (&optional (bits sb!vm:n-word-bits))
(make-alien-integer-type :bits bits :signed nil))
-(def-alien-type-method (integer :unparse) (type)
+(define-alien-type-method (integer :unparse) (type)
(list (if (alien-integer-type-signed type) 'signed 'unsigned)
(alien-integer-type-bits type)))
-(def-alien-type-method (integer :type=) (type1 type2)
+(define-alien-type-method (integer :type=) (type1 type2)
(and (eq (alien-integer-type-signed type1)
(alien-integer-type-signed type2))
(= (alien-integer-type-bits type1)
(alien-integer-type-bits type2))))
-(def-alien-type-method (integer :lisp-rep) (type)
+(define-alien-type-method (integer :lisp-rep) (type)
(list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
(alien-integer-type-bits type)))
-(def-alien-type-method (integer :alien-rep) (type)
+(define-alien-type-method (integer :alien-rep) (type)
(list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
(alien-integer-type-bits type)))
-(def-alien-type-method (integer :naturalize-gen) (type alien)
+(define-alien-type-method (integer :naturalize-gen) (type alien)
(declare (ignore type))
alien)
-(def-alien-type-method (integer :deport-gen) (type value)
+(define-alien-type-method (integer :deport-gen) (type value)
(declare (ignore type))
value)
-(def-alien-type-method (integer :extract-gen) (type sap offset)
+(define-alien-type-method (integer :extract-gen) (type sap offset)
(declare (type alien-integer-type type))
(let ((ref-fun
(if (alien-integer-type-signed type)
\f
;;;; the BOOLEAN type
-(def-alien-type-class (boolean :include integer :include-args (signed)))
+(define-alien-type-class (boolean :include integer :include-args (signed)))
;;; FIXME: Check to make sure that we aren't attaching user-readable
;;; stuff to CL:BOOLEAN in any way which impairs ANSI compliance.
-(def-alien-type-translator boolean (&optional (bits sb!vm:n-word-bits))
+(define-alien-type-translator boolean (&optional (bits sb!vm:n-word-bits))
(make-alien-boolean-type :bits bits :signed nil))
-(def-alien-type-method (boolean :unparse) (type)
+(define-alien-type-method (boolean :unparse) (type)
`(boolean ,(alien-boolean-type-bits type)))
-(def-alien-type-method (boolean :lisp-rep) (type)
+(define-alien-type-method (boolean :lisp-rep) (type)
(declare (ignore type))
`(member t nil))
-(def-alien-type-method (boolean :naturalize-gen) (type alien)
+(define-alien-type-method (boolean :naturalize-gen) (type alien)
(declare (ignore type))
`(not (zerop ,alien)))
-(def-alien-type-method (boolean :deport-gen) (type value)
+(define-alien-type-method (boolean :deport-gen) (type value)
(declare (ignore type))
`(if ,value 1 0))
\f
;;;; the ENUM type
-(def-alien-type-class (enum :include (integer (:bits 32))
- :include-args (signed))
+(define-alien-type-class (enum :include (integer (:bits 32))
+ :include-args (signed))
name ; name of this enum (if any)
from ; alist from keywords to integers.
to ; alist or vector from integers to keywords.
kind ; Kind of from mapping, :vector or :alist.
offset) ; Offset to add to value for :vector from mapping.
-(def-alien-type-translator enum (&whole
+(define-alien-type-translator enum (&whole
type name
&rest mappings
&environment env)
from-alist)
:kind :alist))))))
-(def-alien-type-method (enum :unparse) (type)
+(define-alien-type-method (enum :unparse) (type)
`(enum ,(alien-enum-type-name type)
,@(let ((prev -1))
(mapcar #'(lambda (mapping)
(setf prev value))))
(alien-enum-type-from type)))))
-(def-alien-type-method (enum :type=) (type1 type2)
+(define-alien-type-method (enum :type=) (type1 type2)
(and (eq (alien-enum-type-name type1)
(alien-enum-type-name type2))
(equal (alien-enum-type-from type1)
(alien-enum-type-from type2))))
-(def-alien-type-method (enum :lisp-rep) (type)
+(define-alien-type-method (enum :lisp-rep) (type)
`(member ,@(mapcar #'car (alien-enum-type-from type))))
-(def-alien-type-method (enum :naturalize-gen) (type alien)
+(define-alien-type-method (enum :naturalize-gen) (type alien)
(ecase (alien-enum-type-kind type)
(:vector
`(svref ',(alien-enum-type-to type)
`(,(car mapping) ,(cdr mapping)))
(alien-enum-type-to type))))))
-(def-alien-type-method (enum :deport-gen) (type value)
+(define-alien-type-method (enum :deport-gen) (type value)
`(ecase ,value
,@(mapcar #'(lambda (mapping)
`(,(car mapping) ,(cdr mapping)))
\f
;;;; the FLOAT types
-(def-alien-type-class (float)
+(define-alien-type-class (float)
(type (missing-arg) :type symbol))
-(def-alien-type-method (float :unparse) (type)
+(define-alien-type-method (float :unparse) (type)
(alien-float-type-type type))
-(def-alien-type-method (float :lisp-rep) (type)
+(define-alien-type-method (float :lisp-rep) (type)
(alien-float-type-type type))
-(def-alien-type-method (float :alien-rep) (type)
+(define-alien-type-method (float :alien-rep) (type)
(alien-float-type-type type))
-(def-alien-type-method (float :naturalize-gen) (type alien)
+(define-alien-type-method (float :naturalize-gen) (type alien)
(declare (ignore type))
alien)
-(def-alien-type-method (float :deport-gen) (type value)
+(define-alien-type-method (float :deport-gen) (type value)
(declare (ignore type))
value)
-(def-alien-type-class (single-float :include (float (:bits 32))
- :include-args (type)))
+(define-alien-type-class (single-float :include (float (:bits 32))
+ :include-args (type)))
-(def-alien-type-translator single-float ()
+(define-alien-type-translator single-float ()
(make-alien-single-float-type :type 'single-float))
-(def-alien-type-method (single-float :extract-gen) (type sap offset)
+(define-alien-type-method (single-float :extract-gen) (type sap offset)
(declare (ignore type))
`(sap-ref-single ,sap (/ ,offset sb!vm:n-byte-bits)))
-(def-alien-type-class (double-float :include (float (:bits 64))
- :include-args (type)))
+(define-alien-type-class (double-float :include (float (:bits 64))
+ :include-args (type)))
-(def-alien-type-translator double-float ()
+(define-alien-type-translator double-float ()
(make-alien-double-float-type :type 'double-float))
-(def-alien-type-method (double-float :extract-gen) (type sap offset)
+(define-alien-type-method (double-float :extract-gen) (type sap offset)
(declare (ignore type))
`(sap-ref-double ,sap (/ ,offset sb!vm:n-byte-bits)))
#!+long-float
-(def-alien-type-class (long-float :include (float (:bits #!+x86 96
- #!+sparc 128))
- :include-args (type)))
+(define-alien-type-class (long-float :include (float (:bits #!+x86 96
+ #!+sparc 128))
+ :include-args (type)))
#!+long-float
-(def-alien-type-translator long-float ()
+(define-alien-type-translator long-float ()
(make-alien-long-float-type :type 'long-float))
#!+long-float
-(def-alien-type-method (long-float :extract-gen) (type sap offset)
+(define-alien-type-method (long-float :extract-gen) (type sap offset)
(declare (ignore type))
`(sap-ref-long ,sap (/ ,offset sb!vm:n-byte-bits)))
\f
;;;; the POINTER type
-(def-alien-type-class (pointer :include (alien-value (:bits
- #!-alpha
- sb!vm:n-word-bits
- #!+alpha 64)))
+(define-alien-type-class (pointer :include (alien-value (:bits
+ #!-alpha
+ sb!vm:n-word-bits
+ #!+alpha 64)))
(to nil :type (or alien-type null)))
-(def-alien-type-translator * (to &environment env)
+(define-alien-type-translator * (to &environment env)
(make-alien-pointer-type :to (if (eq to t) nil (parse-alien-type to env))))
-(def-alien-type-method (pointer :unparse) (type)
+(define-alien-type-method (pointer :unparse) (type)
(let ((to (alien-pointer-type-to type)))
`(* ,(if to
(%unparse-alien-type to)
t))))
-(def-alien-type-method (pointer :type=) (type1 type2)
+(define-alien-type-method (pointer :type=) (type1 type2)
(let ((to1 (alien-pointer-type-to type1))
(to2 (alien-pointer-type-to type2)))
(if to1
nil)
(null to2))))
-(def-alien-type-method (pointer :subtypep) (type1 type2)
+(define-alien-type-method (pointer :subtypep) (type1 type2)
(and (alien-pointer-type-p type2)
(let ((to1 (alien-pointer-type-to type1))
(to2 (alien-pointer-type-to type2)))
t)
(null to2)))))
-(def-alien-type-method (pointer :deport-gen) (type value)
+(define-alien-type-method (pointer :deport-gen) (type value)
(/noshow "doing alien type method POINTER :DEPORT-GEN" type value)
(values
;; FIXME: old version, highlighted a bug in xc optimization
\f
;;;; the MEM-BLOCK type
-(def-alien-type-class (mem-block :include alien-value))
+(define-alien-type-class (mem-block :include alien-value))
-(def-alien-type-method (mem-block :extract-gen) (type sap offset)
+(define-alien-type-method (mem-block :extract-gen) (type sap offset)
(declare (ignore type))
`(sap+ ,sap (/ ,offset sb!vm:n-byte-bits)))
-(def-alien-type-method (mem-block :deposit-gen) (type sap offset value)
+(define-alien-type-method (mem-block :deposit-gen) (type sap offset value)
(let ((bits (alien-mem-block-type-bits type)))
(unless bits
(error "can't deposit aliens of type ~S (unknown size)" type))
\f
;;;; the ARRAY type
-(def-alien-type-class (array :include mem-block)
+(define-alien-type-class (array :include mem-block)
(element-type (missing-arg) :type alien-type)
(dimensions (missing-arg) :type list))
-(def-alien-type-translator array (ele-type &rest dims &environment env)
+(define-alien-type-translator array (ele-type &rest dims &environment env)
(when dims
(unless (typep (first dims) '(or index null))
(alien-type-alignment parsed-ele-type))
(reduce #'* dims))))))
-(def-alien-type-method (array :unparse) (type)
+(define-alien-type-method (array :unparse) (type)
`(array ,(%unparse-alien-type (alien-array-type-element-type type))
,@(alien-array-type-dimensions type)))
-(def-alien-type-method (array :type=) (type1 type2)
+(define-alien-type-method (array :type=) (type1 type2)
(and (equal (alien-array-type-dimensions type1)
(alien-array-type-dimensions type2))
(alien-type-= (alien-array-type-element-type type1)
(alien-array-type-element-type type2))))
-(def-alien-type-method (array :subtypep) (type1 type2)
+(define-alien-type-method (array :subtypep) (type1 type2)
(and (alien-array-type-p type2)
(let ((dim1 (alien-array-type-dimensions type1))
(dim2 (alien-array-type-dimensions type2)))
(alien-record-field-name field)
(alien-record-field-bits field))))
-(def-alien-type-class (record :include mem-block)
+(define-alien-type-class (record :include mem-block)
(kind :struct :type (member :struct :union))
(name nil :type (or symbol null))
(fields nil :type list))
-(def-alien-type-translator struct (name &rest fields &environment env)
+(define-alien-type-translator struct (name &rest fields &environment env)
(parse-alien-record-type :struct name fields env))
-(def-alien-type-translator union (name &rest fields &environment env)
+(define-alien-type-translator union (name &rest fields &environment env)
(parse-alien-record-type :union name fields env))
(defun parse-alien-record-type (kind name fields env)
(setf (alien-record-type-bits result)
(align-offset total-bits overall-alignment))))
-(def-alien-type-method (record :unparse) (type)
+(define-alien-type-method (record :unparse) (type)
`(,(case (alien-record-type-kind type)
(:struct 'struct)
(:union 'union)
(type-= field1 field2 (1+ depth))))
(return nil))))))
-(def-alien-type-method (record :type=) (type1 type2)
+(define-alien-type-method (record :type=) (type1 type2)
(and (eq (alien-record-type-name type1)
(alien-record-type-name type2))
(eq (alien-record-type-kind type1)
(defvar *values-type-okay* nil)
-(def-alien-type-class (fun :include mem-block)
+(define-alien-type-class (fun :include mem-block)
(result-type (missing-arg) :type alien-type)
(arg-types (missing-arg) :type list)
(stub nil :type (or null function)))
-(def-alien-type-translator function (result-type &rest arg-types
+(define-alien-type-translator function (result-type &rest arg-types
&environment env)
(make-alien-fun-type
:result-type (let ((*values-type-okay* t))
:arg-types (mapcar (lambda (arg-type) (parse-alien-type arg-type env))
arg-types)))
-(def-alien-type-method (fun :unparse) (type)
+(define-alien-type-method (fun :unparse) (type)
`(function ,(%unparse-alien-type (alien-fun-type-result-type type))
,@(mapcar #'%unparse-alien-type
(alien-fun-type-arg-types type))))
-(def-alien-type-method (fun :type=) (type1 type2)
+(define-alien-type-method (fun :type=) (type1 type2)
(and (alien-type-= (alien-fun-type-result-type type1)
(alien-fun-type-result-type type2))
(= (length (alien-fun-type-arg-types type1))
(alien-fun-type-arg-types type1)
(alien-fun-type-arg-types type2))))
-(def-alien-type-class (values)
+(define-alien-type-class (values)
(values (missing-arg) :type list))
-(def-alien-type-translator values (&rest values &environment env)
+(define-alien-type-translator values (&rest values &environment env)
(unless *values-type-okay*
(error "cannot use values types here"))
(let ((*values-type-okay* nil))
:values (mapcar (lambda (alien-type) (parse-alien-type alien-type env))
values))))
-(def-alien-type-method (values :unparse) (type)
+(define-alien-type-method (values :unparse) (type)
`(values ,@(mapcar #'%unparse-alien-type
(alien-values-type-values type))))
-(def-alien-type-method (values :type=) (type1 type2)
+(define-alien-type-method (values :type=) (type1 type2)
(and (= (length (alien-values-type-values type1))
(length (alien-values-type-values type2)))
(every #'alien-type-=
(/show0 "host-c-call.lisp 12")
-(def-alien-type-class (c-string :include pointer :include-args (to)))
+(define-alien-type-class (c-string :include pointer :include-args (to)))
-(def-alien-type-translator c-string ()
+(define-alien-type-translator c-string ()
(make-alien-c-string-type :to
(parse-alien-type 'char
(sb!kernel::make-null-lexenv))))
-(def-alien-type-method (c-string :unparse) (type)
+(define-alien-type-method (c-string :unparse) (type)
(declare (ignore type))
'c-string)
-(def-alien-type-method (c-string :lisp-rep) (type)
+(define-alien-type-method (c-string :lisp-rep) (type)
(declare (ignore type))
'(or simple-base-string null (alien (* char))))
-(def-alien-type-method (c-string :naturalize-gen) (type alien)
+(define-alien-type-method (c-string :naturalize-gen) (type alien)
(declare (ignore type))
`(if (zerop (sap-int ,alien))
nil
(%naturalize-c-string ,alien)))
-(def-alien-type-method (c-string :deport-gen) (type value)
+(define-alien-type-method (c-string :deport-gen) (type value)
(declare (ignore type))
`(etypecase ,value
(null (int-sap 0))
(let ((function (symbolicate "%" (string-upcase name))))
`(progn
(proclaim '(inline ,function))
- (sb!alien:def-alien-routine (,name ,function) double-float
+ (sb!alien:define-alien-routine (,name ,function) double-float
,@(let ((results nil))
(dotimes (i num-args (nreverse results))
(push (list (intern (format nil "ARG-~D" i))
(in-package "SB!IMPL")
(declaim (inline memmove))
-(def-alien-routine ("memmove" memmove) void
+(define-alien-routine ("memmove" memmove) void
(dest (* char))
(src (* char))
(n unsigned-int))
-(def-alien-routine ("os_get_errno" get-errno) integer)
+(define-alien-routine ("os_get_errno" get-errno) integer)
(setf (fdocumentation 'get-errno 'function)
"Return the value of the C library pseudo-variable named \"errno\".")
(in-package "SB!KERNEL")
-(sb!alien:def-alien-routine ("purify" %purify) sb!c-call:void
+(sb!alien:define-alien-routine ("purify" %purify) sb!c-call:void
(static-roots sb!c-call:unsigned-long)
(read-only-roots sb!c-call:unsigned-long))
;;;; which (at least in sbcl-0.6.10 on Red Hat Linux 6.2) is not
;;;; visible at GENESIS time.
-(def-alien-variable "environ" (* c-string))
+(define-alien-variable "environ" (* c-string))
(push (lambda ()
;; We redo this here to protect ourselves from this scenario:
;; * Build under one version of shared lib, save a core.
;; alien code be preserved across a save/load cycle, but this
;; problem with alien variables is only one of several
;; problems which'd need to be solved before that can happen.)
- (def-alien-variable "environ" (* c-string)))
+ (define-alien-variable "environ" (* c-string)))
*after-save-initializations*)
(defun posix-environ ()
\f
;;;; Import wait3(2) from Unix.
-(sb-alien:def-alien-routine ("wait3" c-wait3) sb-c-call:int
+(sb-alien:define-alien-routine ("wait3" c-wait3) sb-c-call:int
(status sb-c-call:int :out)
(options sb-c-call:int)
(rusage sb-c-call:int))
(defvar *handlers-installed* nil)
#+FreeBSD
-(def-alien-type nil
+(define-alien-type nil
(struct sgttyb
(sg-ispeed sb-c-call:char) ; input speed
(sg-ospeed sb-c-call:char) ; output speed
(sg-kill sb-c-call:char) ; kill character
(sg-flags sb-c-call:short))) ; mode flags
#+OpenBSD
-(def-alien-type nil
+(define-alien-type nil
(struct sgttyb
(sg-four sb-c-call:int)
(sg-chars (array sb-c-call:char 4))
,@body)
(sb-sys:deallocate-system-memory ,sap ,size)))))
-(sb-alien:def-alien-routine spawn sb-c-call:int
+(sb-alien:define-alien-routine spawn sb-c-call:int
(program sb-c-call:c-string)
(argv (* sb-c-call:c-string))
(envp (* sb-c-call:c-string))
\f
;;;; SAVE-LISP-AND-DIE itself
-(sb!alien:def-alien-routine "save" (sb!alien:boolean)
+(sb!alien:define-alien-routine "save" (sb!alien:boolean)
(file sb!c-call:c-string)
(initial-function (sb!alien:unsigned #.sb!vm:n-word-bits)))
(error "badly formed alien name"))
(values (cadr name) (car name))))))
-(defmacro def-alien-variable (name type &environment env)
+(defmacro define-alien-variable (name type &environment env)
#!+sb-doc
"Define NAME as an external alien variable of type TYPE. NAME should be
a list of a string holding the alien name and a symbol to use as the Lisp
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@(when *new-auxiliary-types*
`((%def-auxiliary-alien-types ',*new-auxiliary-types*)))
- (%def-alien-variable ',lisp-name
- ',alien-name
- ',alien-type))))))
+ (%define-alien-variable ',lisp-name
+ ',alien-name
+ ',alien-type))))))
-;;; Do the actual work of DEF-ALIEN-VARIABLE.
+(defmacro def-alien-variable (&rest rest)
+ (deprecation-warning 'def-alien-variable 'define-alien-variable)
+ `(define-alien-variable ,@rest))
+
+;;; Do the actual work of DEFINE-ALIEN-VARIABLE.
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun %def-alien-variable (lisp-name alien-name type)
+ (defun %define-alien-variable (lisp-name alien-name type)
(setf (info :variable :kind lisp-name) :alien)
(setf (info :variable :where-from lisp-name) :defined)
(clear-info :variable :constant-value lisp-name)
(funcall (coerce (compute-deposit-lambda type) 'function)
sap offset type value))
\f
-;;;; ALIEN-FUNCALL, DEF-ALIEN-ROUTINE
+;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE
(defun alien-funcall (alien &rest args)
#!+sb-doc
(t
(error "~S is not an alien function." alien)))))
-(defmacro def-alien-routine (name result-type &rest args &environment lexenv)
+(defmacro define-alien-routine (name result-type
+ &rest args
+ &environment lexenv)
#!+sb-doc
- "DEF-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}*
+ "DEFINE-ALIEN-ROUTINE Name Result-Type {(Arg-Name Arg-Type [Style])}*
Define a foreign interface function for the routine with the specified NAME.
Also automatically DECLAIM the FTYPE of the defined function.
(values ,@temps ,@(results))))
`(values (alien-funcall ,lisp-name ,@(alien-args))
,@(results)))))))))
+
+(defmacro def-alien-routine (&rest rest)
+ (deprecation-warning 'def-alien-routine 'define-alien-routine)
+ `(define-alien-routine ,@rest))
\f
(defun alien-typep (object type)
#!+sb-doc
(in-package "SB!KERNEL")
-(sb!alien:def-alien-routine ("os_allocate" allocate-system-memory)
- system-area-pointer
+(sb!alien:define-alien-routine ("os_allocate" allocate-system-memory)
+ system-area-pointer
(bytes sb!c-call:unsigned-long))
-(sb!alien:def-alien-routine ("os_allocate_at" allocate-system-memory-at)
- system-area-pointer
+(sb!alien:define-alien-routine ("os_allocate_at" allocate-system-memory-at)
+ system-area-pointer
(address system-area-pointer)
(bytes sb!c-call:unsigned-long))
-(sb!alien:def-alien-routine ("os_reallocate" reallocate-system-memory)
- system-area-pointer
+(sb!alien:define-alien-routine ("os_reallocate" reallocate-system-memory)
+ system-area-pointer
(old system-area-pointer)
(old-size sb!c-call:unsigned-long)
(new-size sb!c-call:unsigned-long))
-(sb!alien:def-alien-routine ("os_deallocate" deallocate-system-memory)
- sb!c-call:void
+(sb!alien:define-alien-routine ("os_deallocate" deallocate-system-memory)
+ sb!c-call:void
(addr system-area-pointer)
(bytes sb!c-call:unsigned-long))
\f
;;;; extra types
-(def-alien-type char (integer 8))
-(def-alien-type short (integer 16))
-(def-alien-type int (integer 32))
-(def-alien-type long (integer #!-alpha 32 #!+alpha 64))
+(define-alien-type char (integer 8))
+(define-alien-type short (integer 16))
+(define-alien-type int (integer 32))
+(define-alien-type long (integer #!-alpha 32 #!+alpha 64))
-(def-alien-type unsigned-char (unsigned 8))
-(def-alien-type unsigned-short (unsigned 16))
-(def-alien-type unsigned-int (unsigned 32))
-(def-alien-type unsigned-long (unsigned #!-alpha 32 #!+alpha 64))
+(define-alien-type unsigned-char (unsigned 8))
+(define-alien-type unsigned-short (unsigned 16))
+(define-alien-type unsigned-int (unsigned 32))
+(define-alien-type unsigned-long (unsigned #!-alpha 32 #!+alpha 64))
-(def-alien-type float single-float)
-(def-alien-type double double-float)
+(define-alien-type float single-float)
+(define-alien-type double double-float)
-(def-alien-type-translator void ()
+(define-alien-type-translator void ()
(parse-alien-type '(values) (sb!kernel:make-null-lexenv)))
\f
(defun %naturalize-c-string (sap)
;;;; system calls that deal with signals
#!-sb-fluid (declaim (inline real-unix-kill))
-(sb!alien:def-alien-routine ("kill" real-unix-kill) sb!c-call:int
+(sb!alien:define-alien-routine ("kill" real-unix-kill) sb!c-call:int
(pid sb!c-call:int)
(signal sb!c-call:int))
(real-unix-kill pid (unix-signal-number signal)))
#!-sb-fluid (declaim (inline real-unix-killpg))
-(sb!alien:def-alien-routine ("killpg" real-unix-killpg) sb!c-call:int
+(sb!alien:define-alien-routine ("killpg" real-unix-killpg) sb!c-call:int
(pgrp sb!c-call:int)
(signal sb!c-call:int))
;;; can pull it out of the CMU CL sources, or the old SBCL sources;
;;; but you might also consider doing things the SBCL way and moving
;;; this kind of C-level work down to C wrapper functions.)
-(sb!alien:def-alien-routine ("sigsetmask" unix-sigsetmask)
- sb!c-call:unsigned-long
+(sb!alien:define-alien-routine ("sigsetmask" unix-sigsetmask)
+ sb!c-call:unsigned-long
(mask sb!c-call:unsigned-long))
\f
;;;; C routines that actually do all the work of establishing signal handlers
-(sb!alien:def-alien-routine ("install_handler" install-handler)
- sb!c-call:unsigned-long
+(sb!alien:define-alien-routine ("install_handler" install-handler)
+ sb!c-call:unsigned-long
(signal sb!c-call:int)
(handler sb!c-call:unsigned-long))
\f
;;; Returns two values:
;;; - the minutes west of GMT.
;;; - T if daylight savings is in effect, NIL if not.
-(sb!alien:def-alien-routine get-timezone sb!c-call:void
+(sb!alien:define-alien-routine get-timezone sb!c-call:void
(when sb!c-call:long :in)
(minutes-west sb!c-call:int :out)
(daylight-savings-p sb!alien:boolean :out))
(defun ctype-needs-to-be-interpreted-p (ctype)
;; What we should really do is factor out the code in
- ;; (DEF-SOURCE-TRANSFORM TYPEP ..) so that it can be shared here.
+ ;; (DEFINE-SOURCE-TRANSFORM TYPEP ..) so that it can be shared here.
;; Until then this toy version should be good enough for some testing.
(warn "FIXME: This is just a toy stub CTYPE-NEEDS-TO-BE-INTERPRETED-P.")
(not (or (position (type-specifier ctype)
\f
;;;; hacking the Unix environment
-(def-alien-routine ("getenv" posix-getenv) c-string
+(define-alien-routine ("getenv" posix-getenv) c-string
"Return the \"value\" part of the environment string \"name=value\" which
corresponds to NAME, or NIL if there is none."
(name c-string))
;;; is not extreme enough, since it doesn't need to be blindingly
;;; fast: we can just implement those functions in C as a wrapper
;;; layer.
-(def-alien-type fd-mask unsigned-long)
+(define-alien-type fd-mask unsigned-long)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant fd-setsize 1024))
-(def-alien-type nil
+(define-alien-type nil
(struct fd-set
(fds-bits (array fd-mask #.(/ fd-setsize 32)))))
;; A time value that is accurate to the nearest
;; microsecond but also has a range of years.
-(def-alien-type nil
+(define-alien-type nil
(struct timeval
(tv-sec time-t) ; seconds
(tv-usec time-t))) ; and microseconds
(defconstant rusage_children -1) ; terminated child processes
(defconstant rusage_both -2)
-(def-alien-type nil
+(define-alien-type nil
(struct rusage
(ru-utime (struct timeval)) ; user time used
(ru-stime (struct timeval)) ; system time used.
(void-syscall ("exit" int) code))
;;; Return the process id of the current process.
-(def-alien-routine ("getpid" unix-getpid) int)
+(define-alien-routine ("getpid" unix-getpid) int)
;;; Return the real user-id associated with the current process.
-(def-alien-routine ("getuid" unix-getuid) int)
+(define-alien-routine ("getuid" unix-getuid) int)
;;; Invoke readlink(2) on the file name specified by PATH. Return
;;; (VALUES LINKSTRING NIL) on success, or (VALUES NIL ERRNO) on
;;; st_size is a long, not an off-t, because off-t is a 64-bit
;;; quantity on Alpha. And FIXME: "No one would want a file length
;;; longer than 32 bits anyway, right?":-|
-(def-alien-type nil
+(define-alien-type nil
(struct wrapped_stat
(st-dev unsigned-long) ; would be dev-t in a real stat
(st-ino ino-t)
;; the POSIX.4 structure for a time value. This is like a "struct
;; timeval" but has nanoseconds instead of microseconds.
-(def-alien-type nil
+(define-alien-type nil
(struct timespec
(tv-sec long) ; seconds
(tv-nsec long))) ; nanoseconds
;; used by other time functions
-(def-alien-type nil
+(define-alien-type nil
(struct tm
(tm-sec int) ; Seconds. [0-60] (1 leap second)
(tm-min int) ; Minutes. [0-59]
(tm-gmtoff long) ; Seconds east of UTC.
(tm-zone c-string))) ; Timezone abbreviation.
-(def-alien-routine get-timezone sb!c-call:void
+(define-alien-routine get-timezone sb!c-call:void
(when sb!c-call:long :in)
(minutes-west sb!c-call:int :out)
(daylight-savings-p sb!alien:boolean :out))
;;; Structure crudely representing a timezone. KLUDGE: This is
;;; obsolete and should never be used.
-(def-alien-type nil
+(define-alien-type nil
(struct timezone
(tz-minuteswest int) ; minutes west of Greenwich
(tz-dsttime int))) ; type of dst correction
;;; FIXME: Since SBCL, unlike CMU CL, uses this as an opaque type,
;;; it's no longer architecture-dependent, and probably belongs in
;;; some other package, perhaps SB-KERNEL.
-(def-alien-type os-context-t (struct os-context-t-struct))
+(define-alien-type os-context-t (struct os-context-t-struct))
\f
;;;; MACHINE-TYPE and MACHINE-VERSION
;;;; and internal error handling) the extra runtime cost should be
;;;; negligible.
-(def-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
+(define-alien-routine ("os_context_pc_addr" context-pc-addr) (* unsigned-int)
;; (Note: Just as in CONTEXT-REGISTER-ADDR, we intentionally use an
;; 'unsigned *' interpretation for the 32-bit word passed to us by
;; the C code, even though the C code may think it's an 'int *'.)
(declare (type (alien (* unsigned-int)) addr))
(int-sap (deref addr))))
-(def-alien-routine ("os_context_register_addr" context-register-addr)
+(define-alien-routine ("os_context_register_addr" context-register-addr)
(* unsigned-int)
;; (Note the mismatch here between the 'int *' value that the C code
;; may think it's giving us and the 'unsigned *' value that we
(defstruct arg-state
(stack-frame-size 0))
-(def-alien-type-method (integer :arg-tn) (type state)
+(define-alien-type-method (integer :arg-tn) (type state)
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(multiple-value-bind
(my-make-wired-tn ptype reg-sc (+ stack-frame-size nl0-offset))
(my-make-wired-tn ptype stack-sc (* 2 (- stack-frame-size 4)))))))
-(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+(define-alien-type-method (system-area-pointer :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
'sap-stack
(* 2 (- stack-frame-size 4))))))
-(def-alien-type-method (double-float :arg-tn) (type state)
+(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
'double-stack
(* 2 (- stack-frame-size 6))))))
-(def-alien-type-method (single-float :arg-tn) (type state)
+(define-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
-(def-alien-type-method (integer :result-tn) (type state)
+(define-alien-type-method (integer :result-tn) (type state)
(declare (ignore state))
(multiple-value-bind
(ptype reg-sc)
(values 'unsigned-byte-64 'unsigned-reg))
(my-make-wired-tn ptype reg-sc lip-offset)))
-(def-alien-type-method (system-area-pointer :result-tn) (type state)
+(define-alien-type-method (system-area-pointer :result-tn) (type state)
(declare (ignore type state))
(my-make-wired-tn 'system-area-pointer 'sap-reg lip-offset))
-(def-alien-type-method (double-float :result-tn) (type state)
+(define-alien-type-method (double-float :result-tn) (type state)
(declare (ignore type state))
(my-make-wired-tn 'double-float 'double-reg lip-offset))
-(def-alien-type-method (single-float :result-tn) (type state)
+(define-alien-type-method (single-float :result-tn) (type state)
(declare (ignore type state))
(my-make-wired-tn 'single-float 'single-reg lip-offset))
-(def-alien-type-method (values :result-tn) (type state)
+(define-alien-type-method (values :result-tn) (type state)
(let ((values (alien-values-type-values type)))
(when (cdr values)
(error "Too many result values from c-call."))
;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the
;;; elements.
-(def-source-transform vector (&rest elements)
+(define-source-transform vector (&rest elements)
(let ((len (length elements))
(n -1))
(once-only ((n-vec `(make-array ,len)))
,n-vec))))
;;; Just convert it into a MAKE-ARRAY.
-(def-source-transform make-string (length &key
- (element-type ''base-char)
- (initial-element
- '#.*default-init-char-form*))
+(define-source-transform make-string (length &key
+ (element-type ''base-char)
+ (initial-element
+ '#.*default-init-char-form*))
`(make-array (the index ,length)
:element-type ,element-type
:initial-element ,initial-element))
;;; assertions on the array.
(macrolet ((define-frob (reffer setter type)
`(progn
- (def-source-transform ,reffer (a &rest i)
+ (define-source-transform ,reffer (a &rest i)
`(aref (the ,',type ,a) ,@i))
- (def-source-transform ,setter (a &rest i)
+ (define-source-transform ,setter (a &rest i)
`(%aset (the ,',type ,a) ,@i)))))
(define-frob svref %svset simple-vector)
(define-frob schar %scharset simple-string)
;;; We need to define these predicates, since the TYPEP source
;;; transform picks whichever predicate was defined last when there
;;; are multiple predicates for equivalent types.
-(def-source-transform short-float-p (x) `(single-float-p ,x))
+(define-source-transform short-float-p (x) `(single-float-p ,x))
#!-long-float
-(def-source-transform long-float-p (x) `(double-float-p ,x))
+(define-source-transform long-float-p (x) `(double-float-p ,x))
-(def-source-transform compiled-function-p (x)
+(define-source-transform compiled-function-p (x)
`(functionp ,x))
-(def-source-transform char-int (x)
+(define-source-transform char-int (x)
`(char-code ,x))
(deftransform abs ((x) (rational))
'(if (< x 0) (- x) x))
;;; The layout is stored in slot 0.
-(def-source-transform %instance-layout (x)
+(define-source-transform %instance-layout (x)
`(truly-the layout (%instance-ref ,x 0)))
-(def-source-transform %set-instance-layout (x val)
+(define-source-transform %set-instance-layout (x val)
`(%instance-set ,x 0 (the layout ,val)))
\f
;;;; character support
;;; In our implementation there are really only BASE-CHARs.
-(def-source-transform characterp (obj)
+(define-source-transform characterp (obj)
`(base-char-p ,obj))
\f
;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
;;; compiler. If the called function is a FUNCTION form, then convert
;;; directly to %FUNCALL, instead of waiting around for type
;;; inference.
-(def-source-transform funcall (function &rest args)
+(define-source-transform funcall (function &rest args)
(if (and (consp function) (eq (car function) 'function))
`(%funcall ,function ,@args)
(values nil t)))
;;; it's a reasonable thing to put in SB-EXT in case some dedicated
;;; user wants to do some heavy tweaking to make SBCL give more
;;; informative output about his code.
-(defmacro def-source-context (name lambda-list &body body)
+(defmacro define-source-context (name lambda-list &body body)
#!+sb-doc
- "DEF-SOURCE-CONTEXT Name Lambda-List Form*
+ "DEFINE-SOURCE-CONTEXT Name Lambda-List Form*
This macro defines how to extract an abbreviated source context from the
Named form when it appears in the compiler input. Lambda-List is a DEFMACRO
style lambda-list used to parse the arguments. The Body should return a
#'(lambda (,n-whole)
(destructuring-bind ,lambda-list ,n-whole ,@body)))))
-(def-source-context defstruct (name-or-options &rest slots)
+(defmacro def-source-context (&rest rest)
+ (deprecation-warning 'def-source-context 'define-source-context)
+ `(define-source-context ,@rest))
+
+(define-source-context defstruct (name-or-options &rest slots)
(declare (ignore slots))
`(defstruct ,(if (consp name-or-options)
(car name-or-options)
name-or-options)))
-(def-source-context function (thing)
+(define-source-context function (thing)
(if (and (consp thing) (eq (first thing) 'lambda) (consp (rest thing)))
`(lambda ,(second thing))
`(function ,thing)))
;;; If the desirability of the transformation depends on the current
;;; OPTIMIZE parameters, then the POLICY macro should be used to
;;; determine when to pass.
-(defmacro def-source-transform (name lambda-list &body body)
+(defmacro define-source-transform (name lambda-list &body body)
(let ((fn-name
(if (listp name)
(collect ((pieces))
(do-anonymous ,(do-clauses)
(,endtest ,n-first) ,call))))))))
-(def-source-transform mapc (function list &rest more-lists)
+(define-source-transform mapc (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) nil t))
-(def-source-transform mapcar (function list &rest more-lists)
+(define-source-transform mapcar (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) :list t))
-(def-source-transform mapcan (function list &rest more-lists)
+(define-source-transform mapcan (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) :nconc t))
-(def-source-transform mapl (function list &rest more-lists)
+(define-source-transform mapl (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) nil nil))
-(def-source-transform maplist (function list &rest more-lists)
+(define-source-transform maplist (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) :list nil))
-(def-source-transform mapcon (function list &rest more-lists)
+(define-source-transform mapcon (function list &rest more-lists)
(mapfoo-transform function (cons list more-lists) :nconc nil))
\f
;;;; mapping onto sequences: the MAP function
;;; Convert into an IF so that IF optimizations will eliminate redundant
;;; negations.
-(def-source-transform not (x) `(if ,x nil t))
-(def-source-transform null (x) `(if ,x nil t))
+(define-source-transform not (x) `(if ,x nil t))
+(define-source-transform null (x) `(if ,x nil t))
;;; ENDP is just NULL with a LIST assertion. The assertion will be
;;; optimized away when SAFETY optimization is low; hopefully that
;;; is consistent with ANSI's "should return an error".
-(def-source-transform endp (x) `(null (the list ,x)))
+(define-source-transform endp (x) `(null (the list ,x)))
;;; We turn IDENTITY into PROG1 so that it is obvious that it just
;;; returns the first value of its argument. Ditto for VALUES with one
;;; arg.
-(def-source-transform identity (x) `(prog1 ,x))
-(def-source-transform values (x) `(prog1 ,x))
+(define-source-transform identity (x) `(prog1 ,x))
+(define-source-transform values (x) `(prog1 ,x))
;;; Bind the values and make a closure that returns them.
-(def-source-transform constantly (value)
+(define-source-transform constantly (value)
(let ((rest (gensym "CONSTANTLY-REST-")))
`(lambda (&rest ,rest)
(declare (ignore ,rest))
;;; whatever is right for them is right for us. FIFTH..TENTH turn into
;;; Nth, which can be expanded into a CAR/CDR later on if policy
;;; favors it.
-(def-source-transform first (x) `(car ,x))
-(def-source-transform rest (x) `(cdr ,x))
-(def-source-transform second (x) `(cadr ,x))
-(def-source-transform third (x) `(caddr ,x))
-(def-source-transform fourth (x) `(cadddr ,x))
-(def-source-transform fifth (x) `(nth 4 ,x))
-(def-source-transform sixth (x) `(nth 5 ,x))
-(def-source-transform seventh (x) `(nth 6 ,x))
-(def-source-transform eighth (x) `(nth 7 ,x))
-(def-source-transform ninth (x) `(nth 8 ,x))
-(def-source-transform tenth (x) `(nth 9 ,x))
+(define-source-transform first (x) `(car ,x))
+(define-source-transform rest (x) `(cdr ,x))
+(define-source-transform second (x) `(cadr ,x))
+(define-source-transform third (x) `(caddr ,x))
+(define-source-transform fourth (x) `(cadddr ,x))
+(define-source-transform fifth (x) `(nth 4 ,x))
+(define-source-transform sixth (x) `(nth 5 ,x))
+(define-source-transform seventh (x) `(nth 6 ,x))
+(define-source-transform eighth (x) `(nth 7 ,x))
+(define-source-transform ninth (x) `(nth 8 ,x))
+(define-source-transform tenth (x) `(nth 9 ,x))
;;; Translate RPLACx to LET and SETF.
-(def-source-transform rplaca (x y)
+(define-source-transform rplaca (x y)
(once-only ((n-x x))
`(progn
(setf (car ,n-x) ,y)
,n-x)))
-(def-source-transform rplacd (x y)
+(define-source-transform rplacd (x y)
(once-only ((n-x x))
`(progn
(setf (cdr ,n-x) ,y)
,n-x)))
-(def-source-transform nth (n l) `(car (nthcdr ,n ,l)))
+(define-source-transform nth (n l) `(car (nthcdr ,n ,l)))
(defvar *default-nthcdr-open-code-limit* 6)
(defvar *extreme-nthcdr-open-code-limit* 20)
\f
;;;; arithmetic and numerology
-(def-source-transform plusp (x) `(> ,x 0))
-(def-source-transform minusp (x) `(< ,x 0))
-(def-source-transform zerop (x) `(= ,x 0))
+(define-source-transform plusp (x) `(> ,x 0))
+(define-source-transform minusp (x) `(< ,x 0))
+(define-source-transform zerop (x) `(= ,x 0))
-(def-source-transform 1+ (x) `(+ ,x 1))
-(def-source-transform 1- (x) `(- ,x 1))
+(define-source-transform 1+ (x) `(+ ,x 1))
+(define-source-transform 1- (x) `(- ,x 1))
-(def-source-transform oddp (x) `(not (zerop (logand ,x 1))))
-(def-source-transform evenp (x) `(zerop (logand ,x 1)))
+(define-source-transform oddp (x) `(not (zerop (logand ,x 1))))
+(define-source-transform evenp (x) `(zerop (logand ,x 1)))
;;; Note that all the integer division functions are available for
;;; inline expansion.
(macrolet ((deffrob (fun)
- `(def-source-transform ,fun (x &optional (y nil y-p))
+ `(define-source-transform ,fun (x &optional (y nil y-p))
(declare (ignore y))
(if y-p
(values nil t)
#-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
(deffrob ceiling))
-(def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
-(def-source-transform lognor (x y) `(lognot (logior ,x ,y)))
-(def-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
-(def-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
-(def-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
-(def-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
-(def-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
-(def-source-transform logbitp (index integer)
+(define-source-transform lognand (x y) `(lognot (logand ,x ,y)))
+(define-source-transform lognor (x y) `(lognot (logior ,x ,y)))
+(define-source-transform logandc1 (x y) `(logand (lognot ,x) ,y))
+(define-source-transform logandc2 (x y) `(logand ,x (lognot ,y)))
+(define-source-transform logorc1 (x y) `(logior (lognot ,x) ,y))
+(define-source-transform logorc2 (x y) `(logior ,x (lognot ,y)))
+(define-source-transform logtest (x y) `(not (zerop (logand ,x ,y))))
+(define-source-transform logbitp (index integer)
`(not (zerop (logand (ash 1 ,index) ,integer))))
-(def-source-transform byte (size position) `(cons ,size ,position))
-(def-source-transform byte-size (spec) `(car ,spec))
-(def-source-transform byte-position (spec) `(cdr ,spec))
-(def-source-transform ldb-test (bytespec integer)
+(define-source-transform byte (size position) `(cons ,size ,position))
+(define-source-transform byte-size (spec) `(car ,spec))
+(define-source-transform byte-position (spec) `(cdr ,spec))
+(define-source-transform ldb-test (bytespec integer)
`(not (zerop (mask-field ,bytespec ,integer))))
;;; With the ratio and complex accessors, we pick off the "identity"
;;; case, and use a primitive to handle the cell access case.
-(def-source-transform numerator (num)
+(define-source-transform numerator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%numerator ,n-num)
,n-num)))
-(def-source-transform denominator (num)
+(define-source-transform denominator (num)
(once-only ((n-num `(the rational ,num)))
`(if (ratiop ,n-num)
(%denominator ,n-num)
`(let ((,,temp ,,spec))
,,@body))))))
- (def-source-transform ldb (spec int)
+ (define-source-transform ldb (spec int)
(with-byte-specifier (size pos spec)
`(%ldb ,size ,pos ,int)))
- (def-source-transform dpb (newbyte spec int)
+ (define-source-transform dpb (newbyte spec int)
(with-byte-specifier (size pos spec)
`(%dpb ,newbyte ,size ,pos ,int)))
- (def-source-transform mask-field (spec int)
+ (define-source-transform mask-field (spec int)
(with-byte-specifier (size pos spec)
`(%mask-field ,size ,pos ,int)))
- (def-source-transform deposit-field (newbyte spec int)
+ (define-source-transform deposit-field (newbyte spec int)
(with-byte-specifier (size pos spec)
`(%deposit-field ,newbyte ,size ,pos ,int))))
((zerop i)
`((lambda ,vars ,result) . ,args)))))))
-(def-source-transform = (&rest args) (multi-compare '= args nil))
-(def-source-transform < (&rest args) (multi-compare '< args nil))
-(def-source-transform > (&rest args) (multi-compare '> args nil))
-(def-source-transform <= (&rest args) (multi-compare '> args t))
-(def-source-transform >= (&rest args) (multi-compare '< args t))
+(define-source-transform = (&rest args) (multi-compare '= args nil))
+(define-source-transform < (&rest args) (multi-compare '< args nil))
+(define-source-transform > (&rest args) (multi-compare '> args nil))
+(define-source-transform <= (&rest args) (multi-compare '> args t))
+(define-source-transform >= (&rest args) (multi-compare '< args t))
-(def-source-transform char= (&rest args) (multi-compare 'char= args nil))
-(def-source-transform char< (&rest args) (multi-compare 'char< args nil))
-(def-source-transform char> (&rest args) (multi-compare 'char> args nil))
-(def-source-transform char<= (&rest args) (multi-compare 'char> args t))
-(def-source-transform char>= (&rest args) (multi-compare 'char< args t))
+(define-source-transform char= (&rest args) (multi-compare 'char= args nil))
+(define-source-transform char< (&rest args) (multi-compare 'char< args nil))
+(define-source-transform char> (&rest args) (multi-compare 'char> args nil))
+(define-source-transform char<= (&rest args) (multi-compare 'char> args t))
+(define-source-transform char>= (&rest args) (multi-compare 'char< args t))
-(def-source-transform char-equal (&rest args)
+(define-source-transform char-equal (&rest args)
(multi-compare 'char-equal args nil))
-(def-source-transform char-lessp (&rest args)
+(define-source-transform char-lessp (&rest args)
(multi-compare 'char-lessp args nil))
-(def-source-transform char-greaterp (&rest args)
+(define-source-transform char-greaterp (&rest args)
(multi-compare 'char-greaterp args nil))
-(def-source-transform char-not-greaterp (&rest args)
+(define-source-transform char-not-greaterp (&rest args)
(multi-compare 'char-greaterp args t))
-(def-source-transform char-not-lessp (&rest args)
+(define-source-transform char-not-lessp (&rest args)
(multi-compare 'char-lessp args t))
;;; This function does source transformation of N-arg inequality
(dolist (v2 next)
(setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
-(def-source-transform /= (&rest args) (multi-not-equal '= args))
-(def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
-(def-source-transform char-not-equal (&rest args)
+(define-source-transform /= (&rest args) (multi-not-equal '= args))
+(define-source-transform char/= (&rest args) (multi-not-equal 'char= args))
+(define-source-transform char-not-equal (&rest args)
(multi-not-equal 'char-equal args))
;;; Expand MAX and MIN into the obvious comparisons.
-(def-source-transform max (arg &rest more-args)
+(define-source-transform max (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(arg2 `(max ,@more-args)))
`(if (> ,arg1 ,arg2)
,arg1 ,arg2))))
-(def-source-transform min (arg &rest more-args)
+(define-source-transform min (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(t
(associate-arguments fun (first args) (rest args)))))
-(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
-(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
-(def-source-transform logior (&rest args)
+(define-source-transform + (&rest args)
+ (source-transform-transitive '+ args 0))
+(define-source-transform * (&rest args)
+ (source-transform-transitive '* args 1))
+(define-source-transform logior (&rest args)
(source-transform-transitive 'logior args 0))
-(def-source-transform logxor (&rest args)
+(define-source-transform logxor (&rest args)
(source-transform-transitive 'logxor args 0))
-(def-source-transform logand (&rest args)
+(define-source-transform logand (&rest args)
(source-transform-transitive 'logand args -1))
-(def-source-transform logeqv (&rest args)
+(define-source-transform logeqv (&rest args)
(if (evenp (length args))
`(lognot (logxor ,@args))
`(logxor ,@args)))
;;; because when they are given one argument, they return its absolute
;;; value.
-(def-source-transform gcd (&rest args)
+(define-source-transform gcd (&rest args)
(case (length args)
(0 0)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
(t (associate-arguments 'gcd (first args) (rest args)))))
-(def-source-transform lcm (&rest args)
+(define-source-transform lcm (&rest args)
(case (length args)
(0 1)
(1 `(abs (the integer ,(first args))))
(1 `(,@inverse ,(first args)))
(t (associate-arguments function (first args) (rest args)))))
-(def-source-transform - (&rest args)
+(define-source-transform - (&rest args)
(source-transform-intransitive '- args '(%negate)))
-(def-source-transform / (&rest args)
+(define-source-transform / (&rest args)
(source-transform-intransitive '/ args '(/ 1)))
\f
;;;; transforming APPLY
;;; We convert APPLY into MULTIPLE-VALUE-CALL so that the compiler
;;; only needs to understand one kind of variable-argument call. It is
;;; more efficient to convert APPLY to MV-CALL than MV-CALL to APPLY.
-(def-source-transform apply (fun arg &rest more-args)
+(define-source-transform apply (fun arg &rest more-args)
(let ((args (cons arg more-args)))
`(multiple-value-call ,fun
,@(mapcar #'(lambda (x)
;;;;
;;;; See also VM dependent transforms.
-(def-source-transform atom (x)
+(define-source-transform atom (x)
`(not (consp ,x)))
\f
;;;; TYPEP source transform
;;; to that predicate. Otherwise, we dispatch off of the type's type.
;;; These transformations can increase space, but it is hard to tell
;;; when, so we ignore policy and always do them.
-(def-source-transform typep (object spec)
+(define-source-transform typep (object spec)
;; KLUDGE: It looks bad to only do this on explicitly quoted forms,
;; since that would overlook other kinds of constants. But it turns
;; out that the DEFTRANSFORM for TYPEP detects any constant
(move r x)
(inst and r y)))
-(def-source-transform 32bit-logical-nand (x y)
+(define-source-transform 32bit-logical-nand (x y)
`(32bit-logical-not (32bit-logical-and ,x ,y)))
(define-vop (32bit-logical-or 32bit-logical)
(move r x)
(inst or r y)))
-(def-source-transform 32bit-logical-nor (x y)
+(define-source-transform 32bit-logical-nor (x y)
`(32bit-logical-not (32bit-logical-or ,x ,y)))
(define-vop (32bit-logical-xor 32bit-logical)
(move r x)
(inst xor r y)))
-(def-source-transform 32bit-logical-eqv (x y)
+(define-source-transform 32bit-logical-eqv (x y)
`(32bit-logical-not (32bit-logical-xor ,x ,y)))
-(def-source-transform 32bit-logical-orc1 (x y)
+(define-source-transform 32bit-logical-orc1 (x y)
`(32bit-logical-or (32bit-logical-not ,x) ,y))
-(def-source-transform 32bit-logical-orc2 (x y)
+(define-source-transform 32bit-logical-orc2 (x y)
`(32bit-logical-or ,x (32bit-logical-not ,y)))
-(def-source-transform 32bit-logical-andc1 (x y)
+(define-source-transform 32bit-logical-andc1 (x y)
`(32bit-logical-and (32bit-logical-not ,x) ,y))
-(def-source-transform 32bit-logical-andc2 (x y)
+(define-source-transform 32bit-logical-andc2 (x y)
`(32bit-logical-and ,x (32bit-logical-not ,y)))
;;; Only the lower 5 bits of the shift amount are significant.
(defstruct (arg-state (:copier nil))
(stack-frame-size 0))
-(def-alien-type-method (integer :arg-tn) (type state)
+(define-alien-type-method (integer :arg-tn) (type state)
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(multiple-value-bind (ptype stack-sc)
(values 'unsigned-byte-32 'unsigned-stack))
(my-make-wired-tn ptype stack-sc stack-frame-size))))
-(def-alien-type-method (system-area-pointer :arg-tn) (type state)
+(define-alien-type-method (system-area-pointer :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
stack-frame-size)))
#!+long-float
-(def-alien-type-method (long-float :arg-tn) (type state)
+(define-alien-type-method (long-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (+ stack-frame-size 3))
(my-make-wired-tn 'long-float 'long-stack stack-frame-size)))
-(def-alien-type-method (double-float :arg-tn) (type state)
+(define-alien-type-method (double-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (+ stack-frame-size 2))
(my-make-wired-tn 'double-float 'double-stack stack-frame-size)))
-(def-alien-type-method (single-float :arg-tn) (type state)
+(define-alien-type-method (single-float :arg-tn) (type state)
(declare (ignore type))
(let ((stack-frame-size (arg-state-stack-frame-size state)))
(setf (arg-state-stack-frame-size state) (1+ stack-frame-size))
(0 eax-offset)
(1 edx-offset)))
-(def-alien-type-method (integer :result-tn) (type state)
+(define-alien-type-method (integer :result-tn) (type state)
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(multiple-value-bind (ptype reg-sc)
(values 'unsigned-byte-32 'unsigned-reg))
(my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
-(def-alien-type-method (system-area-pointer :result-tn) (type state)
+(define-alien-type-method (system-area-pointer :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(result-reg-offset num-results))))
#!+long-float
-(def-alien-type-method (long-float :result-tn) (type state)
+(define-alien-type-method (long-float :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'long-float 'long-reg (* num-results 2))))
-(def-alien-type-method (double-float :result-tn) (type state)
+(define-alien-type-method (double-float :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'double-float 'double-reg (* num-results 2))))
-(def-alien-type-method (single-float :result-tn) (type state)
+(define-alien-type-method (single-float :result-tn) (type state)
(declare (ignore type))
(let ((num-results (result-state-num-results state)))
(setf (result-state-num-results state) (1+ num-results))
(my-make-wired-tn 'single-float 'single-reg (* num-results 2))))
#+nil ;;pfw obsolete now?
-(def-alien-type-method (values :result-tn) (type state)
+(define-alien-type-method (values :result-tn) (type state)
(mapcar #'(lambda (type)
(invoke-alien-type-method :result-tn type state))
(alien-values-type-values type)))
;;; pfw - from alpha
-(def-alien-type-method (values :result-tn) (type state)
+(define-alien-type-method (values :result-tn) (type state)
(let ((values (alien-values-type-values type)))
(when (cdr values)
(error "Too many result values from c-call."))
;;; The closure function slot is a pointer to raw code on X86 instead
;;; of a pointer to the code function object itself. This VOP is used
;;; to reference the function object given the closure object.
-(def-source-transform %closure-fun (closure)
+(define-source-transform %closure-fun (closure)
`(%simple-fun-self ,closure))
-(def-source-transform %funcallable-instance-fun (fin)
+(define-source-transform %funcallable-instance-fun (fin)
`(%simple-fun-self ,fin))
(define-vop (%set-fun-self)
(t
`(typep (sb-kernel:layout-of object) 'sb-pcl::wrapper)))))
-(def-source-context defmethod (name &rest stuff)
+(define-source-context defmethod (name &rest stuff)
(let ((arg-pos (position-if #'listp stuff)))
(if arg-pos
`(defmethod ,name ,@(subseq stuff 0 arg-pos)
* Thus, when their signature changes, they don't need updates in a .h
* file somewhere, but they do need updates in the Lisp code. FIXME:
* It would be nice to enforce this at compile time. It mighn't even
- * be all that hard: make the cross-compiler versions of DEF-ALIEN-FOO
+ * be all that hard: make the cross-compiler versions of DEFINE-ALIEN-FOO
* macros accumulate strings in a list which then gets written out at
* the end of sbcl2.h at the end of cross-compilation, then rerun
* 'make' in src/runtime/ using the new sbcl2.h as sbcl.h (and make
(unless (fboundp 'load-foreign) ; not necessarily supported on all OSes..
(sb-ext:quit :unix-status 52)) ; successfully unsupported:-|
(load-foreign '("$testfilestem.so"))
- (def-alien-routine summish int (x int) (y int))
+ (define-alien-routine summish int (x int) (y int))
(assert (= (summish 10 20) 31))
(sb-ext:quit :unix-status 52) ; success convention for Lisp program
EOF
#include <unistd.h>
#define DEFTYPE(lispname,cname) { cname foo; \
- printf("(def-alien-type "##lispname##" (%s %d))\n", (((foo=-1)<0) ? "sb!alien:signed" : "unsigned"), (8 * (sizeof foo))); }
+ printf("(define-alien-type "##lispname##" (%s %d))\n", (((foo=-1)<0) ? "sb!alien:signed" : "unsigned"), (8 * (sizeof foo))); }
void
defconstant(char* lisp_name, long unix_number)
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre7.89"
+"0.pre7.90"
projects / sbcl.git / commitdiff