Commit 92757131 authored by jjgarcia's avatar jjgarcia

Several improvements related to inline of logical and cons functions,...

Several improvements related to inline of logical and cons functions, hardcoding frequently used symbols and a smaller version of TIME
parent d478dd88
......@@ -48,6 +48,8 @@ ECL 0.9g
- .LSP/.LISP are now recognized lisp source extensions.
- We now provide inline expansions for all logical operators.
* Errors fixed:
- Now .o files compiled with :SYSTEM-P T with dash in filename load
......
......@@ -264,8 +264,6 @@ static bignum_bit_operator bignum_operations[16] = {
mpz_b_set_op};
static cl_object log_op2(cl_object x, cl_object y, int op);
static cl_object
log_op(cl_narg narg, int op, cl_va_list ARGS)
{
......@@ -278,7 +276,7 @@ log_op(cl_narg narg, int op, cl_va_list ARGS)
} else {
do {
y = cl_va_arg(ARGS);
x = log_op2(x, y, op);
x = ecl_boole(op, x, y);
} while (--narg);
}
return x;
......@@ -344,8 +342,8 @@ BIG_OP:
#endif
}
static cl_object
log_op2(cl_object x, cl_object y, int op)
cl_object
ecl_boole(int op, cl_object x, cl_object y)
{
switch (type_of(x)) {
case t_fixnum:
......@@ -483,7 +481,7 @@ ecl_fixnum_bit_length(cl_fixnum i)
if (narg == 0)
@(return MAKE_FIXNUM(0))
/* INV: log_op() checks types and outputs first argument as default. */
@(return log_op(narg, BOOLIOR, nums))
@(return log_op(narg, ECL_BOOLIOR, nums))
@)
@(defun logxor (&rest nums)
......@@ -491,7 +489,7 @@ ecl_fixnum_bit_length(cl_fixnum i)
if (narg == 0)
@(return MAKE_FIXNUM(0))
/* INV: log_op() checks types and outputs first argument as default. */
@(return log_op(narg, BOOLXOR, nums))
@(return log_op(narg, ECL_BOOLXOR, nums))
@)
@(defun logand (&rest nums)
......@@ -499,7 +497,7 @@ ecl_fixnum_bit_length(cl_fixnum i)
if (narg == 0)
@(return MAKE_FIXNUM(-1))
/* INV: log_op() checks types and outputs first argument as default. */
@(return log_op(narg, BOOLAND, nums))
@(return log_op(narg, ECL_BOOLAND, nums))
@)
@(defun logeqv (&rest nums)
......@@ -507,43 +505,43 @@ ecl_fixnum_bit_length(cl_fixnum i)
if (narg == 0)
@(return MAKE_FIXNUM(-1))
/* INV: log_op() checks types and outputs first argument as default. */
@(return log_op(narg, BOOLEQV, nums))
@(return log_op(narg, ECL_BOOLEQV, nums))
@)
cl_object
cl_lognand(cl_object x, cl_object y)
{
@(return log_op2(x, y, BOOLNAND))
@(return ecl_boole(ECL_BOOLNAND, x, y))
}
cl_object
cl_lognor(cl_object x, cl_object y)
{
@(return log_op2(x, y, BOOLNOR))
@(return ecl_boole(ECL_BOOLNOR, x, y))
}
cl_object
cl_logandc1(cl_object x, cl_object y)
{
@(return log_op2(x, y, BOOLANDC1))
@(return ecl_boole(ECL_BOOLANDC1, x, y))
}
cl_object
cl_logandc2(cl_object x, cl_object y)
{
@(return log_op2(x, y, BOOLANDC2))
@(return ecl_boole(ECL_BOOLANDC2, x, y))
}
cl_object
cl_logorc1(cl_object x, cl_object y)
{
@(return log_op2(x, y, BOOLORC1))
@(return ecl_boole(ECL_BOOLORC1, x, y))
}
cl_object
cl_logorc2(cl_object x, cl_object y)
{
@(return log_op2(x, y, BOOLORC2))
@(return ecl_boole(ECL_BOOLORC2, x, y))
}
static int
......@@ -551,7 +549,7 @@ coerce_to_logical_operator(cl_object o)
{
cl_fixnum op;
op = fixint(o);
if (op < 0 || op > BOOLSET)
if (op < 0 || op > ECL_BOOLSET)
FEerror("~S is an invalid logical operator.", 1, o);
return op;
}
......@@ -560,7 +558,7 @@ cl_object
cl_boole(cl_object o, cl_object x, cl_object y)
{
/* INV: log_op2() checks types */
@(return log_op2(x, y, coerce_to_logical_operator(o)))
@(return ecl_boole(coerce_to_logical_operator(o), x, y))
}
cl_object
......
......@@ -173,22 +173,22 @@ cl_symbols[] = {
{"BIT-XOR", CL_ORDINARY, ECL_NAME(cl_bit_xor), -1, OBJNULL},
{"BLOCK", CL_FORM, NULL, -1, OBJNULL},
{"BOOLE", CL_ORDINARY, cl_boole, 3, OBJNULL},
{"BOOLE-1", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOL1)},
{"BOOLE-2", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOL2)},
{"BOOLE-AND", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLAND)},
{"BOOLE-ANDC1", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLANDC1)},
{"BOOLE-ANDC2", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLANDC2)},
{"BOOLE-C1", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLC1)},
{"BOOLE-C2", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLC2)},
{"BOOLE-CLR", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLCLR)},
{"BOOLE-EQV", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLEQV)},
{"BOOLE-IOR", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLIOR)},
{"BOOLE-NAND", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLNAND)},
{"BOOLE-NOR", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLNOR)},
{"BOOLE-ORC1", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLORC1)},
{"BOOLE-ORC2", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLORC2)},
{"BOOLE-SET", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLSET)},
{"BOOLE-XOR", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(BOOLXOR)},
{"BOOLE-1", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOL1)},
{"BOOLE-2", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOL2)},
{"BOOLE-AND", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLAND)},
{"BOOLE-ANDC1", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLANDC1)},
{"BOOLE-ANDC2", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLANDC2)},
{"BOOLE-C1", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLC1)},
{"BOOLE-C2", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLC2)},
{"BOOLE-CLR", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLCLR)},
{"BOOLE-EQV", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLEQV)},
{"BOOLE-IOR", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLIOR)},
{"BOOLE-NAND", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLNAND)},
{"BOOLE-NOR", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLNOR)},
{"BOOLE-ORC1", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLORC1)},
{"BOOLE-ORC2", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLORC2)},
{"BOOLE-SET", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLSET)},
{"BOOLE-XOR", CL_CONSTANT, NULL, -1, MAKE_FIXNUM(ECL_BOOLXOR)},
{"BOOLEAN", CL_ORDINARY, NULL, -1, OBJNULL},
{"BOTH-CASE-P", CL_ORDINARY, cl_both_case_p, 1, OBJNULL},
{"BOUNDP", CL_ORDINARY, cl_boundp, 1, OBJNULL},
......@@ -1025,7 +1025,6 @@ cl_symbols[] = {
{KEY_ "DIRECT-DEFAULT-INITARGS", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DIRECT-SLOTS", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DIRECT-SUPERCLASSES", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DOCUMENTATION", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "GENERIC-FUNCTION-CLASS", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "LAMBDA-LIST", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "METHOD-CLASS", KEYWORD, NULL, -1, OBJNULL},
......@@ -1290,6 +1289,7 @@ cl_symbols[] = {
{SYS_ "UNCATCH-BAD-SIGNALS", SI_ORDINARY, si_uncatch_bad_signals, 0, OBJNULL},
/* KEYWORD PACKAGE */
{KEY_ "ADJUSTABLE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "ABORT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "ABSOLUTE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "ALLOW-OTHER-KEYS", KEYWORD, NULL, -1, OBJNULL},
......@@ -1305,7 +1305,10 @@ cl_symbols[] = {
{KEY_ "CIRCLE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "COMPILE-TOPLEVEL", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "COMMON",KEYWORD,NULL,-1,OBJNULL},
{KEY_ "CONC-NAME", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CONSTRUCTOR", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CONTROL-STRING", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "COPIER", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "CREATE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DATUM", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DEFAULT", KEYWORD, NULL, -1, OBJNULL},
......@@ -1313,6 +1316,9 @@ cl_symbols[] = {
{KEY_ "DEVICE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DIRECTION", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DIRECTORY", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DISPLACED-INDEX-OFFSET", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DISPLACED-TO", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DOCUMENTATION", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "DOWNCASE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "ELEMENT-TYPE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "END", KEYWORD, NULL, -1, OBJNULL},
......@@ -1323,9 +1329,12 @@ cl_symbols[] = {
{KEY_ "ESCAPE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "EXECUTE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "EXPECTED-TYPE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "EXPORT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "EXPORT-FROM", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "EXTERNAL", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "EXTERNAL-FORMAT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "FILE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "FILL-POINTER", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "FORMAT-ARGUMENTS", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "FORMAT-CONTROL", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "FUNCTION", KEYWORD, NULL, -1, OBJNULL},
......@@ -1333,11 +1342,16 @@ cl_symbols[] = {
{KEY_ "HOST", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "IF-DOES-NOT-EXIST", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "IF-EXISTS", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "IMPORT-FROM", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INCLUDE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INHERITED", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INITIAL-ELEMENT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INITIAL-CONTENTS", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INITIAL-OFFSET", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INPUT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INTERACTIVE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INSTANCE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INTERN", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INTERNAL", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "INVERT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "IO", KEYWORD, NULL, -1, OBJNULL},
......@@ -1353,6 +1367,7 @@ cl_symbols[] = {
{KEY_ "LOAD-TOPLEVEL", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "MISER-WIDTH", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "NAME", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "NAMED", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "NEW-VERSION", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "NEWEST", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "NICKNAMES", KEYWORD, NULL, -1, OBJNULL},
......@@ -1365,9 +1380,12 @@ cl_symbols[] = {
{KEY_ "PACKAGE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PATHNAME", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PPRINT-DISPATCH", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PREDICATE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PRESERVE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PRETTY", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PRINT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PRINT-FUNCTION", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PRINT-OBJECT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PROBE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "PROTECT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "RADIX", KEYWORD, NULL, -1, OBJNULL},
......@@ -1377,9 +1395,12 @@ cl_symbols[] = {
{KEY_ "RELATIVE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "RENAME", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "RENAME-AND-DELETE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "REPORT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "RIGHT-MARGIN", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "SET-DEFAULT-PATHNAME", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "SEARCH-LIST", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "SHADOW", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "SHADOWING-IMPORT", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "SIZE", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "SPECIAL", KEYWORD, NULL, -1, OBJNULL},
{KEY_ "START", KEYWORD, NULL, -1, OBJNULL},
......
......@@ -1025,7 +1025,6 @@ cl_symbols[] = {
{KEY_ "DIRECT-DEFAULT-INITARGS",NULL},
{KEY_ "DIRECT-SLOTS",NULL},
{KEY_ "DIRECT-SUPERCLASSES",NULL},
{KEY_ "DOCUMENTATION",NULL},
{KEY_ "GENERIC-FUNCTION-CLASS",NULL},
{KEY_ "LAMBDA-LIST",NULL},
{KEY_ "METHOD-CLASS",NULL},
......@@ -1290,6 +1289,7 @@ cl_symbols[] = {
{SYS_ "UNCATCH-BAD-SIGNALS","si_uncatch_bad_signals"},
/* KEYWORD PACKAGE */
{KEY_ "ADJUSTABLE",NULL},
{KEY_ "ABORT",NULL},
{KEY_ "ABSOLUTE",NULL},
{KEY_ "ALLOW-OTHER-KEYS",NULL},
......@@ -1305,7 +1305,10 @@ cl_symbols[] = {
{KEY_ "CIRCLE",NULL},
{KEY_ "COMPILE-TOPLEVEL",NULL},
{KEY_ "COMMON",NULL},
{KEY_ "CONC-NAME",NULL},
{KEY_ "CONSTRUCTOR",NULL},
{KEY_ "CONTROL-STRING",NULL},
{KEY_ "COPIER",NULL},
{KEY_ "CREATE",NULL},
{KEY_ "DATUM",NULL},
{KEY_ "DEFAULT",NULL},
......@@ -1313,6 +1316,9 @@ cl_symbols[] = {
{KEY_ "DEVICE",NULL},
{KEY_ "DIRECTION",NULL},
{KEY_ "DIRECTORY",NULL},
{KEY_ "DISPLACED-INDEX-OFFSET",NULL},
{KEY_ "DISPLACED-TO",NULL},
{KEY_ "DOCUMENTATION",NULL},
{KEY_ "DOWNCASE",NULL},
{KEY_ "ELEMENT-TYPE",NULL},
{KEY_ "END",NULL},
......@@ -1323,9 +1329,12 @@ cl_symbols[] = {
{KEY_ "ESCAPE",NULL},
{KEY_ "EXECUTE",NULL},
{KEY_ "EXPECTED-TYPE",NULL},
{KEY_ "EXPORT",NULL},
{KEY_ "EXPORT-FROM",NULL},
{KEY_ "EXTERNAL",NULL},
{KEY_ "EXTERNAL-FORMAT",NULL},
{KEY_ "FILE",NULL},
{KEY_ "FILL-POINTER",NULL},
{KEY_ "FORMAT-ARGUMENTS",NULL},
{KEY_ "FORMAT-CONTROL",NULL},
{KEY_ "FUNCTION",NULL},
......@@ -1333,11 +1342,16 @@ cl_symbols[] = {
{KEY_ "HOST",NULL},
{KEY_ "IF-DOES-NOT-EXIST",NULL},
{KEY_ "IF-EXISTS",NULL},
{KEY_ "IMPORT-FROM",NULL},
{KEY_ "INCLUDE",NULL},
{KEY_ "INHERITED",NULL},
{KEY_ "INITIAL-ELEMENT",NULL},
{KEY_ "INITIAL-CONTENTS",NULL},
{KEY_ "INITIAL-OFFSET",NULL},
{KEY_ "INPUT",NULL},
{KEY_ "INTERACTIVE",NULL},
{KEY_ "INSTANCE",NULL},
{KEY_ "INTERN",NULL},
{KEY_ "INTERNAL",NULL},
{KEY_ "INVERT",NULL},
{KEY_ "IO",NULL},
......@@ -1353,6 +1367,7 @@ cl_symbols[] = {
{KEY_ "LOAD-TOPLEVEL",NULL},
{KEY_ "MISER-WIDTH",NULL},
{KEY_ "NAME",NULL},
{KEY_ "NAMED",NULL},
{KEY_ "NEW-VERSION",NULL},
{KEY_ "NEWEST",NULL},
{KEY_ "NICKNAMES",NULL},
......@@ -1365,9 +1380,12 @@ cl_symbols[] = {
{KEY_ "PACKAGE",NULL},
{KEY_ "PATHNAME",NULL},
{KEY_ "PPRINT-DISPATCH",NULL},
{KEY_ "PREDICATE",NULL},
{KEY_ "PRESERVE",NULL},
{KEY_ "PRETTY",NULL},
{KEY_ "PRINT",NULL},
{KEY_ "PRINT-FUNCTION",NULL},
{KEY_ "PRINT-OBJECT",NULL},
{KEY_ "PROBE",NULL},
{KEY_ "PROTECT",NULL},
{KEY_ "RADIX",NULL},
......@@ -1377,9 +1395,12 @@ cl_symbols[] = {
{KEY_ "RELATIVE",NULL},
{KEY_ "RENAME",NULL},
{KEY_ "RENAME-AND-DELETE",NULL},
{KEY_ "REPORT",NULL},
{KEY_ "RIGHT-MARGIN",NULL},
{KEY_ "SET-DEFAULT-PATHNAME",NULL},
{KEY_ "SEARCH-LIST",NULL},
{KEY_ "SHADOW",NULL},
{KEY_ "SHADOWING-IMPORT",NULL},
{KEY_ "SIZE",NULL},
{KEY_ "SPECIAL",NULL},
{KEY_ "START",NULL},
......
......@@ -286,45 +286,31 @@
(setf (symbol-function 'shift<<) #'ash)
(setf (symbol-function 'shift>>) #'ash)
;----------------------------------------------------------------------
;;;
;;; FIXME! We should replace this with a compiler macro + inliner for each
;;; logical operation.
;;;
(defun co1boole (args)
(and (not (endp (cddr args)))
(endp (cdddr args))
(let ((op-code (first args))
c1args string)
(and (constantp op-code)
(sys:fixnump (setq op-code (eval op-code)))
(setq c1args (c1args* (rest args)))
(eq 'FIXNUM (c1form-primary-type (first c1args)))
(eq 'FIXNUM (c1form-primary-type (second c1args)))
(c1expr `(c-inline ,(rest args) (FIXNUM FIXNUM) (FIXNUM)
,(boole-inline-string op-code)
:side-effects nil :one-liner t))))))
(defun boole-inline-string (op-code)
(ecase op-code
(#. boole-clr "(0)")
(#. boole-set "(-1)")
(#. boole-1 "(#0)")
(#. boole-2 "(#1)")
(#. boole-c1 "(~(#0))")
(#. boole-c2 "(~(#1))")
(#. boole-and "((#0) & (#1))")
(#. boole-ior "((#0) | (#1))")
(#. boole-xor "((#0) ^ (#1))")
(#. boole-eqv "(~((#0) ^ (#1)))")
(#. boole-nand "(~((#0) & (#1)))")
(#. boole-nor "(~((#0)|(#1)))")
(#. boole-andc1 "((~(#0))&(#1))")
(#. boole-andc2 "(((#0))&(~(#1)))")
(#. boole-orc1 "(~(#0) | (#1))")
(#. boole-orc2 "((#0) | (~(#1)))")))
;;----------------------------------------------------------------------
;; We transform BOOLE into the individual operations, which have
;; inliners
;;
(define-compiler-macro boole (&whole form op-code op1 op2)
(or (and (constantp op-code)
(case (eval op-code)
(#. boole-clr `(progn ,op1 ,op2 0))
(#. boole-set `(progn ,op1 ,op2 -1))
(#. boole-1 `(prog1 ,op1 ,op2))
(#. boole-2 `(progn ,op1 ,op2))
(#. boole-c1 `(prog1 (lognot ,op1) ,op2))
(#. boole-c2 `(progn ,op1 (lognot ,op2)))
(#. boole-and `(logand ,op1 ,op2))
(#. boole-ior `(logior ,op1 ,op2))
(#. boole-xor `(logxor ,op1 ,op2))
(#. boole-eqv `(logeqv ,op1 ,op2))
(#. boole-nand `(lognand ,op1 ,op2))
(#. boole-nor `(lognor ,op1 ,op2))
(#. boole-andc1 `(logandc1 ,op1 ,op2))
(#. boole-andc2 `(logandc2 ,op1 ,op2))
(#. boole-orc1 `(logorc1 ,op1 ,op2))
(#. boole-orc2 `(logorc2 ,op1 ,op2))))
form))
;----------------------------------------------------------------------
......@@ -439,8 +425,6 @@
(put-sysprop 'list-nth-immediate 'C2 'c2list-nth-immediate)
(put-sysprop 'ash 'C1CONDITIONAL 'co1ash)
(put-sysprop 'boole 'C2 'c2boole)
(put-sysprop 'boole 'C1CONDITIONAL 'co1boole)
(put-sysprop 'coerce 'C1CONDITIONAL 'co1coerce)
(put-sysprop 'cons 'C1CONDITIONAL 'co1cons)
(put-sysprop 'ldb 'C1CONDITIONAL 'co1ldb)
......
This diff is collapsed.
......@@ -907,6 +907,23 @@ extern int number_compare(cl_object x, cl_object y);
/* num_log.c */
#define ECL_BOOLCLR 0
#define ECL_BOOLAND 01
#define ECL_BOOLANDC2 02
#define ECL_BOOL1 03
#define ECL_BOOLANDC1 04
#define ECL_BOOL2 05
#define ECL_BOOLXOR 06
#define ECL_BOOLIOR 07
#define ECL_BOOLNOR 010
#define ECL_BOOLEQV 011
#define ECL_BOOLC2 012
#define ECL_BOOLORC2 013
#define ECL_BOOLC1 014
#define ECL_BOOLORC1 015
#define ECL_BOOLNAND 016
#define ECL_BOOLSET 017
extern cl_object cl_lognand(cl_object x, cl_object y);
extern cl_object cl_lognor(cl_object x, cl_object y);
extern cl_object cl_logandc1(cl_object x, cl_object y);
......@@ -925,6 +942,7 @@ extern cl_object cl_logxor _ARGS((cl_narg narg, ...));
extern cl_object cl_logand _ARGS((cl_narg narg, ...));
extern cl_object cl_logeqv _ARGS((cl_narg narg, ...));
extern cl_object ecl_boole(int op, cl_object x, cl_object y);
extern cl_object ecl_ash(cl_object x, cl_fixnum w);
extern int ecl_fixnum_bit_length(cl_fixnum l);
......
......@@ -81,25 +81,6 @@ extern cl_object si_formatter_aux _ARGS((cl_narg narg, cl_object strm, cl_object
/* hash.d */
extern void ecl_extend_hashtable(cl_object hashtable);
/* num_log.d */
#define BOOLCLR 0
#define BOOLAND 01
#define BOOLANDC2 02
#define BOOL1 03
#define BOOLANDC1 04
#define BOOL2 05
#define BOOLXOR 06
#define BOOLIOR 07
#define BOOLNOR 010
#define BOOLEQV 011
#define BOOLC2 012
#define BOOLORC2 013
#define BOOLC1 014
#define BOOLORC1 015
#define BOOLNAND 016
#define BOOLSET 017
/* gfun.d, kernel.lsp */
#define GFUN_NAME(x) ((x)->instance.slots[0])
......
......@@ -92,6 +92,7 @@ for the error message and ARGs are arguments to the format string."
(go ,tag)))))))
(defun accumulate-cases (macro-name cases list-is-atom-p)
(declare (si::c-local))
(do ((c cases (cdr c))
(l '()))
((null c) (nreverse l))
......
......@@ -181,6 +181,7 @@
(defun make-predicate (name type named name-offset)
(declare (si::c-local))
(cond ((null type)
#'(lambda (x)
(structure-subtype-p x name)))
......
......@@ -64,7 +64,6 @@
?: prints this.~%~%"))
(defun read-inspect-command (label object allow-recursive)
(declare (si::c-local))
(unless *inspect-mode*
(inspect-indent-1)
(if allow-recursive
......@@ -112,6 +111,7 @@
(inspect-read-line))
)))
#+ecl-min
(defmacro inspect-recursively (label object &optional place)
(if place
`(multiple-value-bind (update-flag new-value)
......@@ -121,6 +121,7 @@
(princ "Not updated.")
(terpri))))
#+ecl-min
(defmacro inspect-print (label object &optional place)
(if place
`(multiple-value-bind (update-flag new-value)
......@@ -468,7 +469,7 @@ inspect commands, or type '?' to the inspector."
"~&-----------------------------------------------------------------------------~%[email protected]~%~A"
symbol ind doc))
(good-package ()
(if (eq (symbol-package symbol) (find-package "LISP"))
(if (eq (symbol-package symbol) (find-package "CL"))
(find-package "SYSTEM")
*package*)))
......@@ -539,14 +540,14 @@ inspect commands, or type '?' to the inspector."
(format t "~&No documentation for ~:@(~S~)." symbol))
(values))))
(defun apropos-doc (string &optional (package 'LISP) &aux (f nil))
(defun apropos-doc (string &optional (package "CL") &aux (f nil))
(setq string (string string))
(if package
(do-symbols (symbol package)
(when (substringp string (string symbol))
(when (search string (string symbol))
(setq f (or (print-doc symbol t) f))))
(do-all-symbols (symbol)
(when (substringp string (string symbol))
(when (search string (string symbol))
(setq f (or (print-doc symbol t) f)))))
(if f
(format t "~&-----------------------------------------------------------------------------")
......
......@@ -298,16 +298,21 @@ SECOND-FORM."
;; Declarations
(defmacro declaim (&rest decl-specs)
(if (cdr decl-specs)
`(eval-when (compile load eval) (mapcar #'proclaim ',decl-specs))
`(eval-when (compile load eval) (proclaim ',(car decl-specs)))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(mapcar #'proclaim ',decl-specs))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(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)))))
`(eval-when (:compile-toplevel)
(mapcar #'proclaim ',decl-specs))
`(eval-when (:compile-toplevel)
(proclaim ',(car decl-specs)))))
(defmacro in-package (name)
`(eval-when (eval compile load) (si::select-package ,(string name))))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(si::select-package ,(string name))))
;; FIXME!
(defmacro the (type value)
......
......@@ -53,7 +53,7 @@
:test 'eq)))
(defmacro def-foreign-type (name definition)
`(eval-when (compile load eval)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (gethash ',name ffi::*ffi-types*) ',definition)))
(defmacro def-type (name definition)
......@@ -549,7 +549,7 @@
,(format nil "ecl_make_foreign_data(@~S, ~A, &~A)"
type (size-of-foreign-type type) c-name)
:side-effects t :one-liner t))
(eval-when (load compile eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-symbol-macro ,lisp-name
(ffi:deref-pointer (get-sysprop ',lisp-name 'ffi-foreign-var) ',type)
)))
......@@ -595,18 +595,20 @@
(defvar +loaded-libraries+ nil)
(defun do-load-foreign-library (tmp)
(let* ((filename (if (pathnamep tmp) (namestring tmp) (string tmp)))
(pack (find-package "COMPILER")))
(unless (find filename ffi::+loaded-libraries+ :test #'string-equal)
(setf (symbol-value (intern "*LD-FLAGS*" pack)) (concatenate 'string (symbol-value (intern "*LD-FLAGS*" pack)) " " filename))
(setf (symbol-value (intern "*LD-BUNDLE-FLAGS*" pack)) (concatenate 'string (symbol-value (intern "*LD-BUNDLE-FLAGS*" pack)) " " filename))
(setf (symbol-value (intern "*LD-SHARED-FLAGS*" pack)) (concatenate 'string (symbol-value (intern "*LD-SHARED-FLAGS*" pack)) " " filename))
(push filename ffi::+loaded-libraries+))
t))
(defmacro load-foreign-library (filename &key module supporting-libraries force-load)
(declare (ignore module force-load))
`(eval-when (compile)
(let* ((tmp ,filename)
(filename (if (pathnamep tmp) (namestring tmp) (string tmp)))
(pack (find-package "COMPILER")))
(unless (find filename ffi::+loaded-libraries+ :test #'string-equal)
(setf (symbol-value (intern "*LD-FLAGS*" pack)) (concatenate 'string (symbol-value (intern "*LD-FLAGS*" pack)) " " filename))
(setf (symbol-value (intern "*LD-BUNDLE-FLAGS*" pack)) (concatenate 'string (symbol-value (intern "*LD-BUNDLE-FLAGS*" pack)) " " filename))
(setf (symbol-value (intern "*LD-SHARED-FLAGS*" pack)) (concatenate 'string (symbol-value (intern "*LD-SHARED-FLAGS*" pack)) " " filename))
(push filename ffi::+loaded-libraries+))
t)))
(declare (ignore module force-load supporting-libraries))
`(eval-when (:compile-toplevel)
(do-load-foreign-library ,filename)))
;;;----------------------------------------------------------------------
;;; COMPATIBILITY WITH OLDER FFI
......
......@@ -282,7 +282,6 @@ the one defined in the ANSI standard. *print-base* is 10, *print-array* is t,
((object stream &key type identity) &body body)
(if body
`(flet ((.print-unreadable-object-body. () ,@body))
(declare (:dynamic-extent function))
(print-unreadable-object-function
,object ,stream ,type ,identity #'.print-unreadable-object-body.))
`(print-unreadable-object-function ,object ,stream ,type ,identity nil)))
......@@ -33,26 +33,19 @@
(setf (logical-pathname-translations host) (read in-str)))
t)))
(defmacro time (form)
"Syntax: (time form)
Evaluates FORM, outputs the realtime and runtime used for the evaluation to
*TRACE-OUTPUT*, and then returns all values of FORM."
(let*((real-start (gensym))
(real-end (gensym))
(run-start (gensym))
(run-end (gensym))
#-boehm-gc(gc-start (gensym))
(gc-end (gensym))
(x (gensym)))
`(let*((,real-start (get-internal-real-time))
(,run-start (get-internal-run-time))
#-boehm-gc(,gc-start (sys:gc-time))
,real-end ,run-end ,gc-end ,x)
(setq ,x (multiple-value-list ,form))
(setq ,run-end (get-internal-run-time))
(setq ,real-end (get-internal-real-time))
#-boehm-gc(setq ,gc-end (sys:gc-time))
(defun do-time (closure)
(let* ((real-start (get-internal-real-time))
(run-start (get-internal-run-time))
#-boehm-gc (gc-start (si::gc-time))
real-end
run-end
gc-end)
(multiple-value-prog1
(funcall closure)
(setq run-end (get-internal-run-time)
real-end (get-internal-real-time))
#-boehm-gc
(setq gc-end (si::gc-end))
(fresh-line *trace-output*)
(format *trace-output*
#-boehm-gc
......@@ -62,13 +55,15 @@ Evaluates FORM, outputs the realtime and runtime used for the evaluation to
#+boehm-gc
"real time : ~,3F secs~%~
run time : ~,3F secs~%"
(/ (- ,real-end ,real-start) internal-time-units-per-second)
(/ (- ,run-end ,run-start) internal-time-units-per-second)
#-boehm-gc(/ (- ,gc-end ,gc-start) internal-time-units-per-second))
(values-list ,x))))
(/ (- real-end real-start) internal-time-units-per-second)
(/ (- run-end run-start) internal-time-units-per-second)
#-boehm-gc(/ (- gc-end gc-start) internal-time-units-per-second)))))
(defconstant seconds-per-day #.(* 24 3600))
(defmacro time (form)
"Syntax: (time form)
Evaluates FORM, outputs the realtime and runtime used for the evaluation to
*TRACE-OUTPUT*, and then returns all values of FORM."
`(do-time #'(lambda () ,form)))
(defun leap-year-p (y)
(declare (si::c-local))
......
......@@ -110,7 +110,7 @@ is used."
Executes STATEMENTs once for each symbol in PACKAGE (which defaults to the
current package), with VAR bound to the symbol. Then evaluates RESULT (which
defaults to NIL) and returns all values."
(expand-do-symbols var package result-form body '(:external :internal :inherited)))
(expand-do-symbols var package result-form body '(:inherited :internal :external)))
(defmacro do-external-symbols
((var &optional (package '*package*) (result-form nil)) &rest body)
......@@ -127,17 +127,7 @@ values."
Establishes a NIL block and executes STATEMENTs once for each symbol in each
package, with VAR bound to the symbol. Then evaluates RESULT (which defaults
to NIL) and returns all values."
(expand-do-symbols var '(list-all-packages) result-form body '(:external :internal)))