mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-15 15:21:03 -08:00
Add new declaration, si::c-export-fname, which produces lisp compiled files with
meaningful names for the exported functions. For instance, (proclaim '(si::c-export-fname union)) is used to produce a C function with name clLunion, which can be directly used in other compiled files. This feature has been applied to almost all functions in the Lisp runtime.
This commit is contained in:
jjgarcia
parent
f2da18a591
commit
ea010dee34
30 changed files with 129 additions and 93 deletions
|
|
@ -348,7 +348,7 @@ const struct function_info all_functions[] = {
|
|||
{"MEMBER", clLmember, cl},
|
||||
{"MEMBER-IF", clLmember_if, cl},
|
||||
{"MEMBER-IF-NOT", clLmember_if_not, cl},
|
||||
{"MEMBER1", clLmember1, si},
|
||||
{"MEMBER1", siLmember1, si},
|
||||
{"TAILP", clLtailp, cl},
|
||||
{"ADJOIN", clLadjoin, cl},
|
||||
|
||||
|
|
|
|||
|
|
@ -873,7 +873,7 @@ member(cl_object x, cl_object l)
|
|||
|
||||
PREDICATE2(@member)
|
||||
|
||||
@(defun member1 (item list &key test test_not key)
|
||||
@(defun si::member1 (item list &key test test_not key)
|
||||
saveTEST;
|
||||
@
|
||||
protectTEST;
|
||||
|
|
@ -905,7 +905,7 @@ cl_return
|
|||
|
||||
if (narg < 2)
|
||||
FEtoo_few_arguments(&narg);
|
||||
output = @member1(narg, item, list, k1, v1, k2, v2, k3, v3);
|
||||
output = @si::member1(narg, item, list, k1, v1, k2, v2, k3, v3);
|
||||
if (Null(output))
|
||||
output = CONS(item, list);
|
||||
else
|
||||
|
|
|
|||
|
|
@ -231,12 +231,14 @@
|
|||
(defun call-global (fname locs loc return-type narg &aux fd)
|
||||
(flet ((emit-linking-call (fname locs narg &aux i)
|
||||
(cond ((null *linking-calls*)
|
||||
(cmpwarn "Emitting linking call for ~a" fname)
|
||||
(push (list fname 0 (add-symbol fname))
|
||||
*linking-calls*)
|
||||
(setq i 0))
|
||||
((setq i (assoc fname *linking-calls*))
|
||||
(setq i (second i)))
|
||||
(t (setq i (1+ (cadar *linking-calls*)))
|
||||
(cmpwarn "Emitting linking call for ~a" fname)
|
||||
(push (list fname i (add-symbol fname))
|
||||
*linking-calls*)))
|
||||
(unwind-exit
|
||||
|
|
@ -249,15 +251,23 @@
|
|||
(setq loc (inline-function fname locs return-type)))
|
||||
(unwind-exit (fix-loc loc)))
|
||||
|
||||
;; Call to a function whose C language function name is known.
|
||||
((setq fd (get fname 'Lfun))
|
||||
(wt-h "cl_object " fd "();")
|
||||
(unwind-exit (call-loc fname fd locs narg)))
|
||||
|
||||
;; Call to a function defined in the same file.
|
||||
((setq fd (assoc fname *global-funs*))
|
||||
(unwind-exit (call-loc fname (format nil "L~d" (cdr fd))
|
||||
locs narg)))
|
||||
(let ((cfun (cdr fd)))
|
||||
(unwind-exit (call-loc fname
|
||||
(if (numberp cfun)
|
||||
(format nil "L~d" (cdr fd))
|
||||
cfun)
|
||||
locs narg))))
|
||||
|
||||
;; Call to a function whose C language function name is known,
|
||||
;; either because it has been proclaimed so, or because it belongs
|
||||
;; to the runtime.
|
||||
((or (setq fd (get fname 'Lfun))
|
||||
(and (car (setq fd (multiple-value-list (si::mangle-name fname t))))
|
||||
(setq fd (cadr fd))))
|
||||
(wt-h "extern cl_object " fd "();")
|
||||
(unwind-exit (call-loc fname fd locs narg)))
|
||||
|
||||
;; Linking call
|
||||
(*compile-to-linking-call* ; disabled within init_code
|
||||
|
|
|
|||
|
|
@ -260,6 +260,15 @@
|
|||
(if (symbolp x)
|
||||
(pushnew x *alien-declarations*)
|
||||
(warn "The declaration specifier ~s is not a symbol." x))))
|
||||
(SI::C-EXPORT-FNAME
|
||||
(dolist (x (cdr decl))
|
||||
(if (symbolp x)
|
||||
(multiple-value-bind (found fname)
|
||||
(si::mangle-name x t)
|
||||
(if found
|
||||
(warn "The function ~s is already in the runtime." x)
|
||||
(setf (get x 'Lfun) fname)))
|
||||
(warn "The function name ~ is not a symbol." x))))
|
||||
((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER COMMON COMPILED-FUNCTION
|
||||
COMPLEX CONS DOUBLE-FLOAT EXTENDED-CHAR FIXNUM FLOAT HASH-TABLE INTEGER KEYWORD LIST
|
||||
LONG-FLOAT NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO RATIONAL
|
||||
|
|
|
|||
|
|
@ -187,6 +187,10 @@
|
|||
|
||||
(defun t1progn (args) (dolist (form args) (t1expr form)))
|
||||
|
||||
(defun exported-fname (name)
|
||||
(or (get name 'Lfun)
|
||||
(next-cfun)))
|
||||
|
||||
(defun t1defun (args &aux (setjmps *setjmps*))
|
||||
(when (or (endp args) (endp (cdr args)))
|
||||
(too-few-args 'defun 2 (length args)))
|
||||
|
|
@ -194,10 +198,11 @@
|
|||
"The function name ~s is not a symbol." (car args))
|
||||
(when *compile-time-too* (cmp-eval (cons 'DEFUN args)))
|
||||
(setq *non-package-operation* t)
|
||||
(let ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) lambda-expr
|
||||
(*sharp-commas* nil) (*special-binding* nil)
|
||||
(cfun (next-cfun))
|
||||
(doc nil) (fname (car args)))
|
||||
(let* ((*vars* nil) (*funs* nil) (*blocks* nil) (*tags* nil) lambda-expr
|
||||
(*sharp-commas* nil) (*special-binding* nil)
|
||||
(fname (car args))
|
||||
(cfun (exported-fname fname))
|
||||
(doc nil))
|
||||
|
||||
(setq lambda-expr (c1lambda-expr (cdr args) fname))
|
||||
(unless (eql setjmps *setjmps*)
|
||||
|
|
@ -218,10 +223,10 @@
|
|||
(flet
|
||||
((make-inline-string (cfun args)
|
||||
(if (null args)
|
||||
(format nil "LI~d()" cfun)
|
||||
(format nil "LI~a()" cfun)
|
||||
(let ((o (make-array 100 :element-type 'BASE-CHAR
|
||||
:fill-pointer 0)))
|
||||
(format o "LI~d(" cfun)
|
||||
(format o "LI~a(" cfun)
|
||||
(do ((l args (cdr l))
|
||||
(n 0 (1+ n)))
|
||||
((endp (cdr l))
|
||||
|
|
@ -306,7 +311,9 @@
|
|||
(nkey (length (fifth (third lambda-expr)))))
|
||||
(declare (ignore sp funarg-vars))
|
||||
(when (get fname 'NO-GLOBAL-ENTRY) (return-from t2defun nil))
|
||||
(wt-nl "MF(" vv ",L" cfun ",Cblock);")
|
||||
(if (numberp cfun)
|
||||
(wt-nl "MF(" vv ",L" cfun ",Cblock);")
|
||||
(wt-nl "MF(" vv "," cfun ",Cblock);"))
|
||||
(when (< *space* 3)
|
||||
(when doc
|
||||
(wt-nl "(void)putprop(" vv "," doc ","
|
||||
|
|
@ -394,10 +401,10 @@
|
|||
(if (numberp cfun)
|
||||
(progn
|
||||
(wt-nl1 "static cl_object L" cfun "(int narg")
|
||||
(wt-h "static cl_object L" cfun "(int"))
|
||||
(wt-h "static cl_object L" cfun "(int narg"))
|
||||
(progn
|
||||
(wt-nl1 cfun "(int narg")
|
||||
(wt-h cfun "(int")))
|
||||
(wt-nl1 "cl_object " cfun "(int narg")
|
||||
(wt-h "cl_object " cfun "(int narg")))
|
||||
(do ((vl requireds (cdr vl))
|
||||
(lcl (1+ *lcl*) (1+ lcl)))
|
||||
((endp vl))
|
||||
|
|
|
|||
|
|
@ -8,14 +8,18 @@
|
|||
;;;
|
||||
(in-package "COMMON-LISP-USER")
|
||||
(load "lsp/defsys.lsp")
|
||||
(proclaim '(optimize (safety 2) (space 3)))
|
||||
(sbt::operate-on-system lsp :library)
|
||||
;(sbt::operate-on-system lsp :load)
|
||||
(sbt::operate-on-system lsp :load)
|
||||
(setq si::*system-directory* (namestring (sys::chdir "./")))
|
||||
(setq compiler::*cc-flags* (concatenate 'string compiler::*cc-flags* " -I@srcdir@/h -I@srcdir@/gmp -I@builddir@/h"))
|
||||
|
||||
#ifndef RUNTIME
|
||||
;;;
|
||||
;;; * Compile, load and link Common-Lisp to C compiler
|
||||
;;;
|
||||
(load "cmp/defsys.lsp")
|
||||
(proclaim '(optimize (safety 2) (space 3)))
|
||||
(sbt::operate-on-system cmp :library)
|
||||
;(sbt::operate-on-system cmp :load)
|
||||
#endif RUNTIME
|
||||
|
|
@ -25,6 +29,7 @@
|
|||
;;; * Compile, load and link PCL based Common-Lisp Object System
|
||||
;;;
|
||||
(load "clos/defsys.lsp")
|
||||
(proclaim '(optimize (safety 2) (space 3)))
|
||||
(sbt::operate-on-system clos :library)
|
||||
;(sbt::operate-on-system clos :load)
|
||||
#endif CLOS
|
||||
|
|
|
|||
|
|
@ -746,9 +746,13 @@ link_symbols(unsigned int length, char *string_table,
|
|||
case STB_GLOBAL:
|
||||
if (sym->st_shndx == SHN_UNDEF || sym->st_shndx == SHN_COMMON)
|
||||
set_symbol_address(sym, string_table + sym->st_name);
|
||||
else if (STT_FUNC == ELF32_ST_TYPE(sym->st_info))
|
||||
sym->st_value += (int)(start_address + section_start[sym->st_shndx]);
|
||||
else
|
||||
else if (STT_FUNC == ELF32_ST_TYPE(sym->st_info)) {
|
||||
const char *name = string_table + sym->st_name;
|
||||
sym->st_value += (int)(start_address + section_start[sym->st_shndx]);
|
||||
/* JJGR -- Add symbol if not initialization code */
|
||||
if (strncmp(name, "init_"))
|
||||
add_symbol(strdup(name), sym->st_value);
|
||||
} else
|
||||
printf("[unknown global sym %s]", string_table + sym->st_name);
|
||||
break;
|
||||
default:
|
||||
|
|
@ -813,6 +817,11 @@ link_symbols(unsigned int length, char *string_table,
|
|||
# else
|
||||
SYM_VALUE(*sym) = (int)start_address;
|
||||
# endif ECOFF
|
||||
/* JJGR -- Add symbol if not initialization code */
|
||||
if (strncmp(SYM_NAME(sym), "init_")) {
|
||||
printf("\nADD_SYMBOL %s", SYM_NAME(sym));
|
||||
add_symbol(strdup(SYM_NAME(sym)), (int)start_address);
|
||||
}
|
||||
/* we should add the symbol name, so it would be accessible by
|
||||
future loads (init_code should be an exception though. Beppe)
|
||||
printf("\nEXT_UNDEF %s", SYM_NAME(sym)); fflush(stdout);
|
||||
|
|
|
|||
|
|
@ -413,7 +413,7 @@ extern cl_object clLmember _ARGS((int narg, cl_object item, cl_object list, ...)
|
|||
extern cl_object siLmemq _ARGS((int narg, cl_object x, cl_object l));
|
||||
extern cl_object clLmember_if _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val));
|
||||
extern cl_object clLmember_if_not _ARGS((int narg, cl_object pred, cl_object arg, cl_object key, cl_object val));
|
||||
extern cl_object clLmember1 _ARGS((int narg, cl_object item, cl_object list, ...));
|
||||
extern cl_object siLmember1 _ARGS((int narg, cl_object item, cl_object list, ...));
|
||||
extern cl_object clLtailp _ARGS((int narg, cl_object y, cl_object x));
|
||||
extern cl_object clLadjoin _ARGS((int narg, cl_object item, cl_object list, cl_object k1, cl_object v1, cl_object k2, cl_object v2, cl_object k3, cl_object v3));
|
||||
extern cl_object clLacons _ARGS((int narg, cl_object x, cl_object y, cl_object z));
|
||||
|
|
|
|||
|
|
@ -14,8 +14,13 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
(c-declaim (si::c-export-fname make-array vector array-dimensions
|
||||
array-in-bounds-p array-row-major-index
|
||||
bit sbit bit-and bit-ior bit-xor bit-eqv
|
||||
bit-nand bit-nor bit-andc1 bit-andc2 bit-orc1
|
||||
bit-not
|
||||
vector-push vector-push-extend
|
||||
vector-pop adjust-array))
|
||||
|
||||
(defun make-array (dimensions
|
||||
&key (element-type t)
|
||||
|
|
@ -74,16 +79,6 @@
|
|||
(return nil)))))
|
||||
x))))
|
||||
|
||||
(defun type-for-array (element-type)
|
||||
(case element-type
|
||||
((t nil) t)
|
||||
((base-char standard-char extended-char character) 'base-char)
|
||||
(t (dolist (v '(BIT BASE-CHAR
|
||||
(SIGNED-BYTE 32) (UNSIGNED-BYTE 32)
|
||||
SHORT-FLOAT LONG-FLOAT) T)
|
||||
(when (subtypep element-type v)
|
||||
(return (if (symbolp v) v 'FIXNUM)))))))
|
||||
|
||||
(defun increment-cursor (cursor dimensions)
|
||||
(if (null cursor)
|
||||
t
|
||||
|
|
|
|||
|
|
@ -10,8 +10,7 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
(c-declaim (si::c-export-fname ecase-error ccase-error typecase-error-string))
|
||||
|
||||
(defmacro check-type (place typespec &optional (string nil s))
|
||||
`(do ((*print-level* 4)
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@
|
|||
;;; Go into LISP.
|
||||
(in-package "LISP")
|
||||
|
||||
(defun lisp-implementation-type () "ECoLisp")
|
||||
(defun lisp-implementation-type () "ECLS")
|
||||
|
||||
;;; Compiler functions.
|
||||
|
||||
|
|
@ -61,9 +61,6 @@
|
|||
(apply 'disassemble args))
|
||||
)
|
||||
|
||||
(defun get-decoded-time ()
|
||||
(decode-universal-time (get-universal-time)))
|
||||
|
||||
;;; Editor.
|
||||
|
||||
(defun ed (&optional filename)
|
||||
|
|
|
|||
|
|
@ -11,8 +11,6 @@
|
|||
|
||||
(si::select-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
#-ecls-min
|
||||
(defvar *dl*)
|
||||
#-ecls-min
|
||||
|
|
|
|||
|
|
@ -11,9 +11,6 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
|
||||
(defun make-access-function (name conc-name type named slot-descr)
|
||||
(declare (ignore named))
|
||||
(let* ((slot-name (nth 0 slot-descr))
|
||||
|
|
|
|||
|
|
@ -12,27 +12,27 @@
|
|||
(defmacro () () ())
|
||||
#-runtime
|
||||
(evalmacros () () ())
|
||||
#-runtime
|
||||
(top () () ())
|
||||
(module () () ())
|
||||
(autoload () () ())
|
||||
(describe () () ())
|
||||
(setf () () ())
|
||||
(predlib () () ())
|
||||
(arraylib () () ())
|
||||
(predlib () () ())
|
||||
(assert () () ())
|
||||
(defstruct () () ())
|
||||
(iolib () () ())
|
||||
(listlib () () ())
|
||||
(mislib () () ())
|
||||
(numlib () () ())
|
||||
(packlib () () ())
|
||||
(seq () () ())
|
||||
(seqlib () () ())
|
||||
(trace () () ())
|
||||
(iolib () () ())
|
||||
(ansi () () ())
|
||||
(loop () () ())
|
||||
(defpackage () () ())
|
||||
#-runtime
|
||||
(describe () () ())
|
||||
(top () () ())
|
||||
(trace () () ())
|
||||
(config () () ())
|
||||
#+threads
|
||||
(thread () () ())
|
||||
|
|
|
|||
|
|
@ -11,8 +11,6 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
(defvar *inspect-level* 0)
|
||||
(defvar *inspect-history* nil)
|
||||
(defvar *inspect-mode* nil)
|
||||
|
|
|
|||
|
|
@ -10,7 +10,6 @@
|
|||
|
||||
(si::select-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
(eval-when (eval compile) (defun sys:clear-compiler-properties (symbol)))
|
||||
(eval-when (eval compile) (setq sys:*inhibit-macro-special* nil))
|
||||
|
||||
|
|
@ -251,6 +250,11 @@
|
|||
`(eval-when (compile load) (mapcar #'proclaim ',decl-specs))
|
||||
`(eval-when (compile load) (proclaim ',(car decl-specs)))))
|
||||
|
||||
(defmacro c-declaim (&rest decl-specs)
|
||||
(if (cdr decl-specs)
|
||||
`(eval-when (compile) (mapcar #'proclaim ',decl-specs))
|
||||
`(eval-when (compile) (proclaim ',(car decl-specs)))))
|
||||
|
||||
(defmacro in-package (name)
|
||||
`(si::select-package ,(string name)))
|
||||
|
||||
|
|
|
|||
|
|
@ -198,6 +198,7 @@
|
|||
nsubstitute-if
|
||||
nsubstitute-if-not
|
||||
nunion
|
||||
open
|
||||
phase
|
||||
pop
|
||||
position
|
||||
|
|
|
|||
|
|
@ -11,7 +11,8 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
(c-declaim (si::c-export-fname read-from-string write-to-string
|
||||
prin1-to-string princ-to-string))
|
||||
|
||||
(defmacro with-open-stream ((var stream) &rest body)
|
||||
(multiple-value-bind (ds b)
|
||||
|
|
|
|||
|
|
@ -10,7 +10,10 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 0) (space 3))))
|
||||
(c-declaim (optimize (safety 0) (space 3))
|
||||
(si::c-export-fname union nunion intersection nintersection
|
||||
set-difference nset-difference set-exclusive-or
|
||||
nset-exclusive-or subsetp))
|
||||
|
||||
(defun union (list1 list2 &rest rest)
|
||||
(do ((x list1 (cdr x))
|
||||
|
|
|
|||
|
|
@ -10,7 +10,9 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
(c-declaim (si::c-export-fname logical-pathname-translations
|
||||
decode-universal-time encode-universal-time
|
||||
get-decoded-time))
|
||||
|
||||
(defun logical-pathname-translations (p) (si:pathname-translations p))
|
||||
(defsetf logical-pathname-translations si:pathname-translations)
|
||||
|
|
@ -108,3 +110,6 @@
|
|||
;; 12:01 UT (after the switch). We opt for the former.
|
||||
(setq dst -1)))
|
||||
(+ sec (* 60 (+ min (* 60 (+ tz dst hours)))))))
|
||||
|
||||
(defun get-decoded-time ()
|
||||
(decode-universal-time (get-universal-time)))
|
||||
|
|
|
|||
|
|
@ -12,12 +12,8 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
|
||||
(defvar *modules* nil)
|
||||
|
||||
|
||||
(defun provide (module-name)
|
||||
(setq *modules*
|
||||
(adjoin (string module-name) *modules* :test #'string=)))
|
||||
|
|
|
|||
|
|
@ -12,11 +12,16 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
(c-declaim (si::c-export-fname isqrt abs phase signum cis asin acos
|
||||
asinh acosh atanh rational
|
||||
ffloor fceiling ftruncate fround
|
||||
lognand lognor logandc1 logandc2 logorc1 logorc2
|
||||
lognot logtest
|
||||
byte byte-size byte-position
|
||||
ldb ldb-test mask-field dpb deposit-field))
|
||||
|
||||
(defconstant imag-one #C(0.0 1.0))
|
||||
|
||||
|
||||
(defun isqrt (i)
|
||||
(unless (and (integerp i) (>= i 0))
|
||||
(error "~S is not a non-negative integer." i))
|
||||
|
|
@ -162,7 +167,7 @@
|
|||
(defun logorc1 (x y) (boole boole-orc1 x y))
|
||||
(defun logorc2 (x y) (boole boole-orc2 x y))
|
||||
|
||||
(defun lognot (x) (logxor -1 x))
|
||||
;(defun lognot (x) (logxor -1 x))
|
||||
(defun logtest (x y) (not (zerop (logand x y))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -12,8 +12,6 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
(defmacro coerce-to-package (p)
|
||||
(if (eq p '*package*)
|
||||
p
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
(c-declaim (si::c-export-fname typep subtypep coerce type-for-array))
|
||||
|
||||
;;; DEFTYPE macro.
|
||||
(defmacro deftype (name lambda-list &rest body)
|
||||
|
|
@ -104,6 +104,16 @@
|
|||
(setf (get (car l) 'TYPE-PREDICATE) (cdr l)))
|
||||
|
||||
|
||||
(defun type-for-array (element-type)
|
||||
(case element-type
|
||||
((t nil) t)
|
||||
((base-char standard-char extended-char character) 'base-char)
|
||||
(t (dolist (v '(BIT BASE-CHAR
|
||||
(SIGNED-BYTE 32) (UNSIGNED-BYTE 32)
|
||||
SHORT-FLOAT LONG-FLOAT) T)
|
||||
(when (subtypep element-type v)
|
||||
(return (if (symbolp v) v 'FIXNUM)))))))
|
||||
|
||||
;;; TYPEP predicate.
|
||||
(defun typep (object type &aux tp i c)
|
||||
(cond ((symbolp type)
|
||||
|
|
|
|||
|
|
@ -12,7 +12,8 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
(c-declaim (si::c-export-fname make-sequence concatenate map some every
|
||||
notany notevery map-into))
|
||||
|
||||
(defun make-sequence (type size &key (initial-element nil iesp)
|
||||
&aux element-type sequence)
|
||||
|
|
|
|||
|
|
@ -13,7 +13,16 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
(c-declaim (si::c-export-fname reduce fill replace
|
||||
;remove remove-if remove-if-not
|
||||
;delete delete-if delete-if-not
|
||||
;count count-if count-if-not
|
||||
;substitute substitute-if substitute-if-not
|
||||
;nsubstitute nsubstitute-if nsubstitute-if-not
|
||||
;find find-if find-if-not
|
||||
;position position-if position-if-not
|
||||
remove-duplicates delete-duplicates
|
||||
mismatch search sort stable-sort merge))
|
||||
|
||||
(declaim (function seqtype (t) t))
|
||||
(defun seqtype (sequence)
|
||||
|
|
@ -650,20 +659,6 @@
|
|||
(setf (elt newseq j) (elt sequence2 i2))
|
||||
(incf i2)))))
|
||||
|
||||
(defun map-into (result-sequence function &rest sequences)
|
||||
(let ((nel (apply #'min (if (eq 'VECTOR (type-of result-sequence))
|
||||
(array-dimension result-sequence 0)
|
||||
(length result-sequence))
|
||||
(mapcar #'length sequences))))
|
||||
;; Set the fill pointer to the number of iterations
|
||||
(when (and (eq 'VECTOR (type-of result-sequence))
|
||||
(array-has-fill-pointer-p result-sequence))
|
||||
(setf (fill-pointer result-sequence) nel))
|
||||
;; Perform mapping
|
||||
(dotimes (k nel result-sequence)
|
||||
(setf (elt result-sequence k)
|
||||
(apply function (mapcar #'(lambda (v) (elt v k)) sequences))))))
|
||||
|
||||
(defun complement (f)
|
||||
#'(lambda (&rest x) (not (apply f x))))
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
(eval-when (eval compile) (defun sys::clear-compiler-properties (symbol)))
|
||||
(eval-when (eval compile) (setq sys:*inhibit-macro-special* nil))
|
||||
|
||||
|
|
|
|||
|
|
@ -36,8 +36,6 @@
|
|||
*scheduler-disabled-in-error*
|
||||
*break-level*))
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
;;; ----------------------------------------------------------------------
|
||||
;;; Top level
|
||||
|
||||
|
|
|
|||
|
|
@ -21,8 +21,6 @@
|
|||
(export '(*break-readtable* *break-on-warnings* *break-enable*
|
||||
*lisp-init-file-list* *tpl-evalhook*))
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
(defvar + nil)
|
||||
(defvar ++ nil)
|
||||
(defvar +++ nil)
|
||||
|
|
|
|||
|
|
@ -10,8 +10,6 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
|
||||
|
||||
(defvar *trace-level* 0)
|
||||
(defvar *trace-list* nil)
|
||||
(defconstant +tracing-block+ (gensym))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue