From e33fb894f991b2926d8f3bace9058e4c0b2c3a37 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Wed, 12 Dec 2001 22:54:49 +0000 Subject: [PATCH] 0.pre7.90: changed publicly-visible DEF-FOO-style names to DEFINE-FOO: DEF-ALIEN-ROUTINE, DEF-ALIEN-TYPE, DEF-ALIEN-VARIABLE, DEF-SOURCE-CONTEXT (and a few other lexically-similar DEF-FOO-style names as well) defined deprecated wrappers using the old names defined DEPRECATION-WARNING to support this --- TODO | 3 - build-order.lisp-expr | 4 +- doc/compiler.sgml | 2 +- doc/ffi.sgml | 2 +- package-data-list.lisp-expr | 25 +++-- src/code/alpha-vm.lisp | 14 +-- src/code/debug-int.lisp | 8 +- src/code/early-extensions.lisp | 5 + src/code/float-trap.lisp | 2 +- src/code/foreign.lisp | 8 +- src/code/gc.lisp | 6 +- src/code/host-alieneval.lisp | 216 +++++++++++++++++++------------------ src/code/host-c-call.lisp | 12 +-- src/code/irrat.lisp | 2 +- src/code/misc-aliens.lisp | 4 +- src/code/purify.lisp | 2 +- src/code/run-program.lisp | 12 +-- src/code/save.lisp | 2 +- src/code/target-alieneval.lisp | 28 +++-- src/code/target-allocate.lisp | 16 +-- src/code/target-c-call.lisp | 22 ++-- src/code/target-signal.lisp | 12 +-- src/code/time.lisp | 2 +- src/code/typecheckfuns.lisp | 2 +- src/code/unix.lisp | 24 ++--- src/code/x86-vm.lisp | 6 +- src/compiler/alpha/c-call.lisp | 18 ++-- src/compiler/array-tran.lisp | 14 +-- src/compiler/generic/vm-tran.lisp | 14 +-- src/compiler/ir1-translators.lisp | 2 +- src/compiler/ir1report.lisp | 12 ++- src/compiler/macros.lisp | 2 +- src/compiler/seqtran.lisp | 12 +-- src/compiler/srctran.lisp | 156 ++++++++++++++------------- src/compiler/typetran.lisp | 4 +- src/compiler/x86/arith.lisp | 14 +-- src/compiler/x86/c-call.lisp | 24 ++--- src/compiler/x86/system.lisp | 4 +- src/pcl/compiler-support.lisp | 2 +- src/runtime/wrap.c | 2 +- tests/foreign.test.sh | 2 +- tools-for-build/grovel_headers.c | 2 +- version.lisp-expr | 2 +- 43 files changed, 382 insertions(+), 345 deletions(-) diff --git a/TODO b/TODO index 31dac18..b8c0638 100644 --- a/TODO +++ b/TODO @@ -9,9 +9,6 @@ for 0.7.0: 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/ diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 613951e..3595925 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -162,7 +162,7 @@ ("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) @@ -317,7 +317,7 @@ ;; 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") diff --git a/doc/compiler.sgml b/doc/compiler.sgml index 9fc61a2..a72bc1a 100644 --- a/doc/compiler.sgml +++ b/doc/compiler.sgml @@ -323,7 +323,7 @@ _ \code{3}. If null, the global values of \code{*print-level*} and _ \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 diff --git a/doc/ffi.sgml b/doc/ffi.sgml index cc33fe5..8db7573 100644 --- a/doc/ffi.sgml +++ b/doc/ffi.sgml @@ -13,7 +13,7 @@ difference is that the package names have changed 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. --> diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 881f3f0..4d1dc50 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -30,8 +30,14 @@ "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" @@ -74,8 +80,8 @@ "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" @@ -201,7 +207,7 @@ "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" @@ -528,7 +534,13 @@ like *STACK-TOP-HINT*" ;; 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 @@ -726,6 +738,7 @@ retained, possibly temporariliy, because it might be used internally." "PSXHASH" "%BREAK" "NTH-BUT-WITH-SANE-ARG-ORDER" + "DEPRECATION-WARNING" ;; ..and macros.. "COLLECT" diff --git a/src/code/alpha-vm.lisp b/src/code/alpha-vm.lisp index 6741975..44ec30e 100644 --- a/src/code/alpha-vm.lisp +++ b/src/code/alpha-vm.lisp @@ -15,7 +15,7 @@ (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)) ;;;; MACHINE-TYPE and MACHINE-VERSION @@ -37,7 +37,8 @@ (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)) @@ -57,7 +58,7 @@ (setf (sap-ref-8 sap offset) (ldb (byte 8 0) value)) (setf (sap-ref-8 sap (1+ offset)) (ldb (byte 8 8) value))))))) -;;;; "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 @@ -71,14 +72,14 @@ ;;;; ;;;; 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)) @@ -101,7 +102,8 @@ ;;; 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)) diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 2362e87..ba25763 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -538,7 +538,7 @@ (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 @@ -3049,19 +3049,19 @@ ;;; 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)) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 120d07b..e2782a2 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -954,3 +954,8 @@ (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)) diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index 2a772a5..8260291 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -134,7 +134,7 @@ ;; 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) #| diff --git a/src/code/foreign.lisp b/src/code/foreign.lisp index ac0df23..96b0cde 100644 --- a/src/code/foreign.lisp +++ b/src/code/foreign.lisp @@ -108,12 +108,12 @@ (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. @@ -146,7 +146,7 @@ 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) diff --git a/src/code/gc.lisp b/src/code/gc.lisp index f5cbc27..f66fbe1 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -239,13 +239,13 @@ function should notify the user that the system has finished GC'ing.") ;;;; 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 diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index ed5bbf3..7d52587 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -85,7 +85,8 @@ ;;; 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 @@ -117,7 +118,7 @@ ,@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 @@ -241,13 +242,13 @@ ;;;; 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) @@ -255,10 +256,10 @@ ,@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) @@ -267,7 +268,7 @@ (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 @@ -278,7 +279,10 @@ ,@(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) @@ -295,7 +299,7 @@ (: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)) @@ -328,49 +332,49 @@ ;;;; 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))) ;;;; 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)) @@ -461,90 +465,90 @@ ;;;; default methods -(def-alien-type-method (root :unparse) (type) +(define-alien-type-method (root :unparse) (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))) ;;;; 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) @@ -565,39 +569,39 @@ ;;;; 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)) ;;;; 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) @@ -673,7 +677,7 @@ 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) @@ -686,16 +690,16 @@ (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) @@ -706,7 +710,7 @@ `(,(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))) @@ -714,78 +718,78 @@ ;;;; 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))) ;;;; 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 @@ -794,7 +798,7 @@ 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))) @@ -804,7 +808,7 @@ 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 @@ -828,13 +832,13 @@ ;;;; 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)) @@ -842,11 +846,11 @@ ;;;; 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)) @@ -868,17 +872,17 @@ (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))) @@ -906,15 +910,15 @@ (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) @@ -987,7 +991,7 @@ (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) @@ -1054,7 +1058,7 @@ (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) @@ -1068,12 +1072,12 @@ (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)) @@ -1081,12 +1085,12 @@ :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)) @@ -1095,10 +1099,10 @@ (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)) @@ -1106,11 +1110,11 @@ :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-= diff --git a/src/code/host-c-call.lisp b/src/code/host-c-call.lisp index 440b8fa..b0b143b 100644 --- a/src/code/host-c-call.lisp +++ b/src/code/host-c-call.lisp @@ -11,28 +11,28 @@ (/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)) diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 7b18f5a..20be275 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -25,7 +25,7 @@ (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)) diff --git a/src/code/misc-aliens.lisp b/src/code/misc-aliens.lisp index 3fe8cdf..bf11807 100644 --- a/src/code/misc-aliens.lisp +++ b/src/code/misc-aliens.lisp @@ -12,12 +12,12 @@ (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\".") diff --git a/src/code/purify.lisp b/src/code/purify.lisp index f4d0811..15199fa 100644 --- a/src/code/purify.lisp +++ b/src/code/purify.lisp @@ -9,7 +9,7 @@ (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)) diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index 35f4583..6fcfa55 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -45,7 +45,7 @@ ;;;; 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. @@ -59,7 +59,7 @@ ;; 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 () @@ -108,7 +108,7 @@ ;;;; 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)) @@ -305,7 +305,7 @@ (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 @@ -313,7 +313,7 @@ (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)) @@ -435,7 +435,7 @@ ,@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)) diff --git a/src/code/save.lisp b/src/code/save.lisp index 74a6906..cb9956f 100644 --- a/src/code/save.lisp +++ b/src/code/save.lisp @@ -17,7 +17,7 @@ ;;;; 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))) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index eafe1e7..f399057 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -45,7 +45,7 @@ (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 @@ -57,13 +57,17 @@ `(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) @@ -547,7 +551,7 @@ (funcall (coerce (compute-deposit-lambda type) 'function) sap offset type value)) -;;;; ALIEN-FUNCALL, DEF-ALIEN-ROUTINE +;;;; ALIEN-FUNCALL, DEFINE-ALIEN-ROUTINE (defun alien-funcall (alien &rest args) #!+sb-doc @@ -579,9 +583,11 @@ (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. @@ -672,6 +678,10 @@ (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)) (defun alien-typep (object type) #!+sb-doc diff --git a/src/code/target-allocate.lisp b/src/code/target-allocate.lisp index 37d6540..71f5ad8 100644 --- a/src/code/target-allocate.lisp +++ b/src/code/target-allocate.lisp @@ -11,22 +11,22 @@ (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)) diff --git a/src/code/target-c-call.lisp b/src/code/target-c-call.lisp index 586956a..38b4cd1 100644 --- a/src/code/target-c-call.lisp +++ b/src/code/target-c-call.lisp @@ -14,20 +14,20 @@ ;;;; 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))) (defun %naturalize-c-string (sap) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 2d2a021..15f14be 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -18,7 +18,7 @@ ;;;; 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)) @@ -29,7 +29,7 @@ (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)) @@ -47,13 +47,13 @@ ;;; 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)) ;;;; 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)) diff --git a/src/code/time.lisp b/src/code/time.lisp index d416cdd..2d7b0f7 100644 --- a/src/code/time.lisp +++ b/src/code/time.lisp @@ -82,7 +82,7 @@ ;;; 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)) diff --git a/src/code/typecheckfuns.lisp b/src/code/typecheckfuns.lisp index e398b70..b36fe17 100644 --- a/src/code/typecheckfuns.lisp +++ b/src/code/typecheckfuns.lisp @@ -190,7 +190,7 @@ (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) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index eace65c..fbae021 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -90,7 +90,7 @@ ;;;; 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)) @@ -112,12 +112,12 @@ ;;; 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))))) @@ -152,7 +152,7 @@ ;; 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 @@ -163,7 +163,7 @@ (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. @@ -318,10 +318,10 @@ (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 @@ -512,7 +512,7 @@ ;;; 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) @@ -587,13 +587,13 @@ ;; 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] @@ -607,7 +607,7 @@ (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)) @@ -627,7 +627,7 @@ ;;; 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 diff --git a/src/code/x86-vm.lisp b/src/code/x86-vm.lisp index 6439c32..d0e88ad 100644 --- a/src/code/x86-vm.lisp +++ b/src/code/x86-vm.lisp @@ -32,7 +32,7 @@ ;;; 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)) ;;;; MACHINE-TYPE and MACHINE-VERSION @@ -183,7 +183,7 @@ ;;;; 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 *'.) @@ -195,7 +195,7 @@ (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 diff --git a/src/compiler/alpha/c-call.lisp b/src/compiler/alpha/c-call.lisp index 4b62741..b925788 100644 --- a/src/compiler/alpha/c-call.lisp +++ b/src/compiler/alpha/c-call.lisp @@ -19,7 +19,7 @@ (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 @@ -31,7 +31,7 @@ (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)) @@ -43,7 +43,7 @@ '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)) @@ -55,7 +55,7 @@ '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)) @@ -69,7 +69,7 @@ -(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) @@ -78,19 +78,19 @@ (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.")) diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index c6dae10..4b4337f 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -141,7 +141,7 @@ ;;; 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))) @@ -155,10 +155,10 @@ ,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)) @@ -595,9 +595,9 @@ ;;; 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) diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 56fa01a..0b81b5f 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -21,29 +21,29 @@ ;;; 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))) ;;;; 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)) ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 63bc884..021a7bf 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -459,7 +459,7 @@ ;;; 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))) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index 6143aee..5a77869 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -97,9 +97,9 @@ ;;; 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 @@ -109,13 +109,17 @@ #'(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))) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 54c4073..e51c8eb 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -100,7 +100,7 @@ ;;; 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)) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 8282341..81c943f 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -48,22 +48,22 @@ (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)) ;;;; mapping onto sequences: the MAP function diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index b858d5b..daa33b5 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -15,22 +15,22 @@ ;;; 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)) @@ -97,31 +97,31 @@ ;;; 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) @@ -145,21 +145,21 @@ ;;;; 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) @@ -171,29 +171,29 @@ #-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) @@ -2334,19 +2334,19 @@ `(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)))) @@ -3031,27 +3031,27 @@ ((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 @@ -3080,20 +3080,20 @@ (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) @@ -3130,16 +3130,18 @@ (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))) @@ -3148,14 +3150,14 @@ ;;; 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)))) @@ -3172,9 +3174,9 @@ (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))) ;;;; transforming APPLY @@ -3182,7 +3184,7 @@ ;;; 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) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 3abec13..03b4c0b 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -145,7 +145,7 @@ ;;;; ;;;; See also VM dependent transforms. -(def-source-transform atom (x) +(define-source-transform atom (x) `(not (consp ,x))) ;;;; TYPEP source transform @@ -485,7 +485,7 @@ ;;; 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 diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index a857524..a281608 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -1004,7 +1004,7 @@ (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) @@ -1013,7 +1013,7 @@ (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) @@ -1022,19 +1022,19 @@ (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. diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 794493a..4c098f9 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -25,7 +25,7 @@ (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) @@ -34,7 +34,7 @@ (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)) @@ -43,19 +43,19 @@ 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)) @@ -69,7 +69,7 @@ (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) @@ -78,7 +78,7 @@ (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)) @@ -86,32 +86,32 @@ (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.")) diff --git a/src/compiler/x86/system.lisp b/src/compiler/x86/system.lisp index 4dfe83b..753f218 100644 --- a/src/compiler/x86/system.lisp +++ b/src/compiler/x86/system.lisp @@ -229,10 +229,10 @@ ;;; 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) diff --git a/src/pcl/compiler-support.lisp b/src/pcl/compiler-support.lisp index 1553085..56fc271 100644 --- a/src/pcl/compiler-support.lisp +++ b/src/pcl/compiler-support.lisp @@ -47,7 +47,7 @@ (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) diff --git a/src/runtime/wrap.c b/src/runtime/wrap.c index 23bc881..bf6088c 100644 --- a/src/runtime/wrap.c +++ b/src/runtime/wrap.c @@ -6,7 +6,7 @@ * 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 diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh index 6b5a7cd..7a6ca2a 100644 --- a/tests/foreign.test.sh +++ b/tests/foreign.test.sh @@ -23,7 +23,7 @@ ${SBCL:-sbcl} < #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) diff --git a/version.lisp-expr b/version.lisp-expr index 6798103..2561f88 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; 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" -- 1.7.10.4