From 6a91d3b45a4b11bea8d51c385982dd8d152bcfbf Mon Sep 17 00:00:00 2001 From: Juan Jose Garcia Ripoll Date: Sat, 1 May 2010 11:07:34 +0200 Subject: [PATCH] Refactored code so that it is shared by cmp and new-cmp: * Use the new proclamations/sysfun.lsp files from the new compiler. * We split src/cmp/cmpdefs.lsp into cmpdefs, cmppackage, cmptypes and cmpglobals * Split cmpform.lsp out of cmpmac.lsp * Merged in {cmp,new-cmp}/cmpc-wt.lsp some of the cmpmac wt routines * Use functions instead of macros for the WT-* operations * Split out from *cmp/cmpenv.lsp a file cmppolicy.lsp * A single file, cmpenv-api.lsp for the manipulation of environments. * The type comparison functions go into cmptype-arith.lsp and are cached. * The code that propagates types in function calls goes into cmptype-prop.lsp. * The remainings of cmpenv go into cmpenv-{declare,proclaim,declaim}. Associated fixes: * Fixed typo and wrong proclamation for SI:GET-SYSPROP. * Fixed typo in SIMPLIFY-ARITHMETIC. * Explicitely set the debug level when building ECL * All declarations are stored in the compiler environment. * Each function and form stores the compilation environment. * Declaration POLICY-DEBUG-IHS-FRAME is acts only on the function environment. * Make the definition if ihs_env only happen when it is used. * Eliminated *notinline*, *inline-functions* and *function-declarations* * Slightly more efficient creation of accessors in kernel.lsp * Remove the proxy C2DECL-BODY * Fix the order of declarations in SI:PROCESS-DECLARATIONS * Reimplemented C1BODY using SI:PROCESS-DECLARATIONS * DECLAIM's proclamation do not propagate beyond the compiled file. --- src/CHANGELOG | 1 + src/bare.lsp.in | 2 +- src/c/compiler.d | 1 + src/clos/kernel.lsp | 11 +- src/{new-cmp => cmp}/cmpc-wt.lsp | 140 +- src/cmp/cmpcall.lsp | 4 +- src/cmp/cmpcatch.lsp | 5 +- src/cmp/cmpdefs.lsp | 521 +------ src/cmp/cmpenv-api.lsp | 200 +++ src/cmp/cmpenv-declaim.lsp | 52 + src/cmp/cmpenv-declare.lsp | 217 +++ src/cmp/cmpenv-fun.lsp | 147 ++ src/cmp/cmpenv-proclaim.lsp | 136 ++ src/cmp/cmpenv.lsp | 688 --------- src/cmp/cmpeval.lsp | 6 +- src/cmp/cmpflet.lsp | 19 +- src/cmp/cmpform.lsp | 89 ++ src/{new-cmp => cmp}/cmpglobals.lsp | 87 +- src/cmp/cmpinline.lsp | 4 - src/cmp/cmplam.lsp | 26 +- src/cmp/cmplet.lsp | 36 +- src/cmp/cmpmac.lsp | 195 +-- src/cmp/cmpmulti.lsp | 5 +- src/cmp/cmpnum.lsp | 4 +- src/cmp/cmppackage.lsp | 51 + src/cmp/cmppolicy.lsp | 105 ++ src/cmp/cmpprop.lsp | 2 +- src/cmp/cmptag.lsp | 2 +- src/cmp/cmptop.lsp | 60 +- src/cmp/cmptype-arith.lsp | 329 ++++ src/cmp/cmptype-prop.lsp | 80 + src/cmp/cmptype.lsp | 536 ------- src/{new-cmp => cmp}/cmptypes.lsp | 62 +- src/cmp/cmputil.lsp | 6 - src/cmp/cmpwt.lsp | 102 +- src/cmp/load.lsp.in | 16 +- src/cmp/proclamations.lsp | 29 +- src/compile.lsp.in | 6 +- src/configure | 3 +- src/configure.in | 1 - src/new-cmp/cmpc-inline.lsp | 4 - src/new-cmp/cmpdefs.lsp | 69 - src/new-cmp/cmpenv.lsp | 680 --------- src/new-cmp/cmplam.lsp | 1 - src/new-cmp/cmptype.lsp | 523 ------- src/new-cmp/load.lsp.in | 22 +- src/new-cmp/sysfun.lsp | 2208 --------------------------- 47 files changed, 1825 insertions(+), 5668 deletions(-) rename src/{new-cmp => cmp}/cmpc-wt.lsp (53%) create mode 100644 src/cmp/cmpenv-api.lsp create mode 100644 src/cmp/cmpenv-declaim.lsp create mode 100644 src/cmp/cmpenv-declare.lsp create mode 100644 src/cmp/cmpenv-fun.lsp create mode 100644 src/cmp/cmpenv-proclaim.lsp delete mode 100644 src/cmp/cmpenv.lsp create mode 100644 src/cmp/cmpform.lsp rename src/{new-cmp => cmp}/cmpglobals.lsp (81%) create mode 100644 src/cmp/cmppackage.lsp create mode 100644 src/cmp/cmppolicy.lsp create mode 100644 src/cmp/cmptype-arith.lsp create mode 100644 src/cmp/cmptype-prop.lsp rename src/{new-cmp => cmp}/cmptypes.lsp (87%) delete mode 100644 src/new-cmp/cmpdefs.lsp delete mode 100644 src/new-cmp/cmpenv.lsp delete mode 100644 src/new-cmp/sysfun.lsp diff --git a/src/CHANGELOG b/src/CHANGELOG index 90763e77d..c526cd585 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -41,6 +41,7 @@ ECL 10.4.2: - The compiler is now shipped as a single FASL file, cmp.fas, without extra files such as sysfun.lsp + - DECLAIM's proclamation do not propagate beyond the compiled file. ECL 10.4.1: =========== diff --git a/src/bare.lsp.in b/src/bare.lsp.in index 65188578f..6275024e9 100644 --- a/src/bare.lsp.in +++ b/src/bare.lsp.in @@ -145,7 +145,7 @@ (defun build-module (name sources &key additional-files (builtin nil) (dir "build:") ((:prefix si::*init-function-prefix*) "EXT")) - (proclaim '(optimize (safety 2) (speed 1))) + (proclaim '(optimize (safety 2) (speed 1) (debug 1))) (let* ((name (string-downcase name))) (when additional-files (setf *module-files* (append additional-files *module-files*))) diff --git a/src/c/compiler.d b/src/c/compiler.d index 19779b197..552f3a916 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -2418,6 +2418,7 @@ c_listA(cl_env_ptr env, cl_object args, int flags) } /* END: SEARCH DECLARE */ + declarations = cl_nreverse(declarations); @(return declarations body documentation specials) @) diff --git a/src/clos/kernel.lsp b/src/clos/kernel.lsp index 37043f901..7f1dc6f6b 100644 --- a/src/clos/kernel.lsp +++ b/src/clos/kernel.lsp @@ -31,9 +31,11 @@ (defun create-accessors (slotds type) (let ((i 0) (output '()) + (names '()) name) - (dolist (s slotds `(progn ,@output)) + (dolist (s slotds) (when (setf name (getf (cdr s) :accessor)) + (push name names) (setf output (append output `((defun ,name (obj) @@ -44,7 +46,12 @@ (define-compiler-macro ,name (obj) `(si:instance-ref ,obj ,,i)) )))) - (incf i)))) + (incf i)) + `(progn + #+nil + (eval-when (:compile-toplevel :execute) + (proclaim '(notinline ,@names))) + ,@output))) (defun remove-accessors (slotds) (loop for i in slotds for j = (copy-list i) diff --git a/src/new-cmp/cmpc-wt.lsp b/src/cmp/cmpc-wt.lsp similarity index 53% rename from src/new-cmp/cmpc-wt.lsp rename to src/cmp/cmpc-wt.lsp index 06d4be55f..1659412b8 100644 --- a/src/new-cmp/cmpc-wt.lsp +++ b/src/cmp/cmpc-wt.lsp @@ -1,7 +1,6 @@ ;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- ;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. -;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll. ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Library General Public @@ -9,43 +8,76 @@ ;;;; version 2 of the License, or (at your option) any later version. ;;;; ;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPC-WT -- Routines for writing code to C files. +;;;; -;;;; CMPWT -- Routines for writing code to C files. +(in-package #-new-cmp "COMPILER" #+new-cmp "C-BACKEND") -(in-package "C-BACKEND") +(defun wt1 (form) + (typecase form + ((or STRING INTEGER CHARACTER) + (princ form *compiler-output1*)) + ((or DOUBLE-FLOAT SINGLE-FLOAT) + (format *compiler-output1* "~10,,,,,,'eG" form)) + (LONG-FLOAT + (format *compiler-output1* "~,,,,,,'eEl" form)) + (VAR (wt-var form)) + (t (wt-loc form))) + nil) -(defvar *wt-string-size* 0) +(defun wt-h1 (form) + (if (consp form) + (let ((fun (get-sysprop (car form) 'wt-loc))) + (if fun + (let ((*compiler-output1* *compiler-output2*)) + (apply fun (cdr form))) + (cmperr "The location ~s is undefined." form))) + (princ form *compiler-output2*)) + nil) -;;; from cmpwt.lsp -(defmacro wt (&rest forms &aux (fl nil)) - (dolist (form forms `(progn ,@(nreverse (cons nil fl)))) - (if (stringp form) - (push `(princ ,form *compiler-output1*) fl) - (push `(wt1 ,form) fl)))) +(defun wt (&rest forms) + (mapc #'wt1 forms)) -(defmacro wt-h (&rest forms &aux (fl nil)) - (dolist (form forms `(progn ,@(nreverse (cons nil fl)))) - (if (stringp form) - (push `(princ ,form *compiler-output2*) fl) - (push `(wt-h1 ,form) fl)))) +(defun wt-h (&rest forms) + (mapc #'wt-h1 forms)) -(defmacro wt-nl-h (&rest forms) - `(progn (terpri *compiler-output2*) (wt-h ,@forms))) +(defun wt-nl-h (&rest forms) + (terpri *compiler-output2*) + (mapc #'wt-h1 forms)) -(defmacro princ-h (form) `(princ ,form *compiler-output2*)) +(defun princ-h (form) + (princ form *compiler-output2*)) -(defmacro wt-nl (&rest forms) - `(wt #\Newline #\Tab ,@forms)) +(defun wt-nl (&rest forms) + (wt1 #\Newline) + (wt1 #\Tab) + (mapc #'wt1 forms)) -(defmacro wt-nl1 (&rest forms) - `(wt #\Newline ,@forms)) +(defun wt-nl1 (&rest forms) + (wt1 #\Newline) + (mapc #'wt1 forms)) -(defmacro wt-go (label) - `(wt "goto L" ,label ";")) +;;; +;;; LABELS AND JUMPS +;;; + +(defun wt-go (label) + #-new-cmp + (setf (cdr label) t + label (car label)) + (wt "goto L" label ";")) (defun wt-label (label) + #-new-cmp + (when (cdr label) (wt-nl1 "L" (car label) ":;")) + #+new-cmp (wt-nl1 "L" label ":;")) +;;; +;;; C/C++ COMMENTS +;;; + (defun wt-filtered-comment (text stream single-line) (declare (string text)) (if single-line @@ -80,24 +112,42 @@ (defun wt-comment-nl (message &rest extra) (do-wt-comment message extra t)) -(defun wt1 (form) - (typecase form - ((or STRING INTEGER CHARACTER) - (princ form *compiler-output1*)) - ((or DOUBLE-FLOAT SINGLE-FLOAT) - (format *compiler-output1* "~10,,,,,,'eG" form)) - (LONG-FLOAT - (format *compiler-output1* "~,,,,,,'eEl" form)) - (VAR (wt-var form)) - (t (wt-loc form))) - nil) +;;; +;;; STRINGS +;;; +;;; This routine converts lisp data into C-strings. We have to take +;;; care of escaping special characteres with backslashes. We also have +;;; to split long lines using the fact that multiple strings are joined +;;; together by the compiler. +;;; + +(defvar *wt-string-size* 0) + +(defun wt-filtered-data (string stream &optional one-liner) + (let ((N (length string)) + (wt-data-column 80)) + (incf *wt-string-size* (1+ N)) ; 1+ accounts for a blank space + (format stream (if one-liner "\"" "~%\"")) + (dotimes (i N) + (decf wt-data-column) + (when (< wt-data-column 0) + (format stream "\"~% \"") + (setq wt-data-column 79)) + (let ((x (aref string i))) + (cond + ((or (< (char-code x) 32) + (> (char-code x) 127)) + (case x + ; We avoid a trailing backslash+newline because some preprocessors + ; remove them. + (#\Newline (princ "\\n" stream)) + (#\Tab (princ "\\t" stream)) + (t (format stream "\\~3,'0o" (char-code x))))) + ((char= x #\\) + (princ "\\\\" stream)) + ((char= x #\") + (princ "\\\"" stream)) + (t (princ x stream))))) + (princ (if one-liner "\"" " \"") stream) + string)) -(defun wt-h1 (form) - (if (consp form) - (let ((fun (get-sysprop (car form) 'wt-loc))) - (if fun - (let ((*compiler-output1* *compiler-output2*)) - (apply fun (cdr form))) - (cmperr "The location ~s is undefined." form))) - (princ form *compiler-output2*)) - nil) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index f8f066273..52ea50213 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -125,7 +125,7 @@ ;; Call to a function defined in the same file. Direct calls are ;; only emitted for low or neutral values of DEBUG is >= 2. - (when (and (<= (cmp-env-optimization 'debug) 1) + (when (and (policy-use-direct-C-call) (or (fun-p fun) (and (null fun) (setf fun (find fname *global-funs* :test #'same-fname-p @@ -139,7 +139,7 @@ ;; 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. - (when (and (<= (cmp-env-optimization 'debug) 1) + (when (and (policy-use-direct-C-call) (setf fd (get-sysprop fname 'Lfun))) (multiple-value-bind (minarg maxarg) (get-proclaimed-narg fname) (return-from call-global-loc diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index a52daf549..3e25a23c3 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -49,9 +49,8 @@ (defun c1unwind-protect (args) (check-args-number 'UNWIND-PROTECT args 1) (incf *setjmps*) - (let (form) - (let ((*cmp-env* (cmp-env-mark 'UNWIND-PROTECT))) - (setq form (c1expr (first args)))) + (let ((form (let ((*cmp-env* (cmp-env-mark 'UNWIND-PROTECT))) + (c1expr (first args))))) (make-c1form* 'UNWIND-PROTECT :type (c1form-type form) :sp-change t :args form (c1progn (rest args))))) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index 31abdcaac..d9b200abd 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -1,7 +1,6 @@ ;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- ;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. -;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Library General Public @@ -10,434 +9,10 @@ ;;;; ;;;; See file '../Copyright' for full details. -;;;; CMPDEF Definitions - -(si::package-lock "CL" nil) - -(defpackage "C" - (:nicknames "COMPILER") - (:use "FFI" "CL" #+threads "MP") - (:export "*COMPILER-BREAK-ENABLE*" - "*COMPILE-PRINT*" - "*COMPILE-TO-LINKING-CALL*" - "*COMPILE-VERBOSE*" - "*CC*" - "*CC-OPTIMIZE*" - "*USER-CC-FLAGS*" - "*USER-LD-FLAGS*" - "*SUPPRESS-COMPILER-NOTES*" - "*SUPPRESS-COMPILER-WARNINGS*" - "*SUPPRESS-COMPILER-MESSAGES*" - "BUILD-ECL" - "BUILD-PROGRAM" - "BUILD-FASL" - "BUILD-STATIC-LIBRARY" - "BUILD-SHARED-LIBRARY" - "COMPILER-WARNING" - "COMPILER-NOTE" - "COMPILER-MESSAGE" - "COMPILER-ERROR" - "COMPILER-FATAL-ERROR" - "COMPILER-INTERNAL-ERROR" - "COMPILER-UNDEFINED-VARIABLE" - "COMPILER-MESSAGE-FILE" - "COMPILER-MESSAGE-FILE-POSITION" - "COMPILER-MESSAGE-FORM" - "*SUPPRESS-COMPILER-WARNINGS*" - "*SUPPRESS-COMPILER-NOTES*" - "*SUPPRESS-COMPILER-MESSAGES*") - (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" - "*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET" - "COMPILER-LET")) +;;;; CMPDEF -- Definitions created at compile / configuration time (in-package "COMPILER") -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; COMPILER STRUCTURES -;;; - -;;; -;;; REF OBJECT -;;; -;;; Base object for functions, variables and statements. We use it to -;;; keep track of references to objects, how many times the object is -;;; referenced, by whom, and whether the references cross some closure -;;; boundaries. -;;; - -(defstruct (ref (:print-object print-ref)) - name ;;; Identifier of reference. - (ref 0 :type fixnum) ;;; Number of references. - ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the index into the closure env - ref-clb ;;; Cross local function reference. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the lex-address for the - ;;; block id, or NIL. - read-nodes ;;; Nodes (c1forms) in which the reference occurs -) - -(deftype OBJECT () `(not (or fixnum character float))) - -(defstruct (var (:include ref) (:constructor %make-var) (:print-object print-var)) -; name ;;; Variable name. -; (ref 0 :type fixnum) - ;;; Number of references to the variable (-1 means IGNORE). -; ref-ccb ;;; Cross closure reference: T or NIL. -; ref-clb ;;; Cross local function reference: T or NIL. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs - set-nodes ;;; Nodes in which the variable is modified - kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM, - ;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for - ;;; LET variables). - (function *current-function*) - ;;; For local variables, in which function it was created. - ;;; For global variables, it doesn't have a meaning. - (functions-setting nil) - (functions-reading nil) - ;;; Functions in which the variable has been modified or read. - (loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can - ;;; be allocated on the c-stack: OBJECT means - ;;; the variable is declared as OBJECT, and CLB means - ;;; the variable is referenced across Level Boundary and thus - ;;; cannot be allocated on the C stack. Note that OBJECT is - ;;; set during variable binding and CLB is set when the - ;;; variable is used later, and therefore CLB may supersede - ;;; OBJECT. - ;;; During Pass 2: - ;;; For REPLACED: the actual location of the variable. - ;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT: - ;;; the cvar for the C variable that holds the value. - ;;; For LEXICAL or CLOSURE: the frame-relative address for - ;;; the variable in the form of a cons '(lex-levl . lex-ndx) - ;;; lex-levl is the level of lexical environment - ;;; lex-ndx is the index within the array for this env. - ;;; For SPECIAL and GLOBAL: the vv-index for variable name. - (type t) ;;; Type of the variable. - (index -1) ;;; position in *vars*. Used by similar. - (ignorable nil) ;;; Whether there was an IGNORABLE/IGNORE declaration - ) - -;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE -;;; Here are examples of function FOO for the 3 cases: -;;; 1. (flet ((foo () (bar))) (foo)) CFUN -;;; 2. (flet ((foo () (bar))) #'foo) CFUN+LISP_CFUN -;;; 3. (flet ((foo () x)) #'(lambda () (foo))) CCLOSURE -;;; 4. (flet ((foo () x)) #'foo) CCLOSURE+LISP_CLOSURE - -;;; A function can be referred across a ccb without being a closure, e.g: -;;; (flet ((foo () (bar))) #'(lambda () (foo))) -;;; [the lambda also need not be a closure] -;;; and it can be a closure without being referred across ccb, e.g.: -;;; (flet ((foo () x)) #'foo) [ is this a mistake in local-function-ref?] -;;; Here instead the lambda must be a closure, but no closure is needed for foo -;;; (flet ((foo () x)) #'(lambda () (foo))) -;;; So we use two separate fields: ref-ccb and closure. -;;; A CCLOSURE must be created for a function when: -;;; 1. it appears within a FUNCTION construct and -;;; 2. it uses some ccb references (directly or indirectly). -;;; ref-ccb corresponds to the first condition, i.e. function is referred -;;; across CCB. It is computed during Pass 1. A value of 'RETURNED means -;;; that it is immediately within FUNCTION. -;;; closure corresponds to second condition and is computed in Pass 2 by -;;; looking at the info-referred-vars and info-local-referred of its body. - -;;; A LISP_CFUN or LISP_CLOSURE must be created when the function is returned. -;;; The LISP funob may then be referred locally or across LB or CB: -;;; (flet ((foo (z) (bar z))) (list #'foo))) -;;; (flet ((foo (z) z)) (flet ((bar () #'foo)) (bar))) -;;; (flet ((foo (z) (bar z))) #'(lambda () #'foo))) -;;; therefore we need field funob. - -(defstruct (fun (:include ref)) -; name ;;; Function name. -; (ref 0 :type fixnum) ;;; Number of references. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the vs-address for the - ;;; function closure, or NIL. -; ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL, depending on whether a - ;;; function object will be built. - ;;; During Pass2, the vs-address for the function - ;;; closure, or NIL. -; ref-clb ;;; Unused. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs - cfun ;;; The cfun for the function. - (level 0) ;;; Level of lexical nesting for a function. - (env 0) ;;; Size of env of closure. - (global nil) ;;; Global lisp function. - (exported nil) ;;; Its C name can be seen outside the module. - (no-entry nil) ;;; NIL if declared as C-LOCAL. Then we create no - ;;; function object and the C function is called - ;;; directly - (shares-with nil) ;;; T if this function shares the C code with another one. - ;;; In that case we need not emit this one. - closure ;;; During Pass2, T if env is used inside the function - var ;;; the variable holding the funob - description ;;; Text for the object, in case NAME == NIL. - lambda ;;; Lambda c1-form for this function. - (minarg 0) ;;; Min. number arguments that the function receives. - (maxarg call-arguments-limit) - ;;; Max. number arguments that the function receives. - (parent *current-function*) - ;;; Parent function, NIL if global. - (local-vars nil) ;;; List of local variables created here. - (referred-vars nil) ;;; List of external variables referenced here. - (referred-funs nil) ;;; List of external functions called in this one. - ;;; We only register direct calls, not calls via object. - (child-funs nil) ;;; List of local functions defined here. - (debug 0) ;;; Debug quality - (file (car ext:*source-location*)) - ;;; Source file or NIL - (file-position (or (cdr ext:*source-location*) *compile-file-position*)) - ;;; Top-level form number in source file - ) - -(defstruct (blk (:include ref)) -; name ;;; Block name. -; (ref 0 :type fixnum) ;;; Number of references. -; ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the ccb-lex for the - ;;; block id, or NIL. -; ref-clb ;;; Cross local function reference. - ;;; During Pass1, T or NIL. - ;;; During Pass2, the lex-address for the - ;;; block id, or NIL. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs - exit ;;; Where to return. A label. - destination ;;; Where the value of the block to go. - var ;;; Variable containing the block ID. - (type 'NIL) ;;; Estimated type. - ) - -(defstruct (tag (:include ref)) -; name ;;; Tag name. -; (ref 0 :type fixnum) ;;; Number of references. -; ref-ccb ;;; Cross closure reference. - ;;; During Pass1, T or NIL. -; ref-clb ;;; Cross local function reference. - ;;; During Pass1, T or NIL. -; read-nodes ;;; Nodes (c1forms) in which the reference occurs - label ;;; Where to jump: a label. - unwind-exit ;;; Where to unwind-no-exit. - var ;;; Variable containing frame ID. - index ;;; An integer denoting the label. - ) - -(defstruct (info) - (local-vars nil) ;;; List of var-objects created directly in the form. - (type t) ;;; Type of the form. - (sp-change nil) ;;; Whether execution of the form may change - ;;; the value of a special variable. - (volatile nil) ;;; whether there is a possible setjmp. Beppe - ) - -(defstruct (inline-info) - name ;;; Function name - arg-rep-types ;;; List of representation types for the arguments - return-rep-type ;;; Representation type for the output - arg-types ;;; List of lisp types for the arguments - return-type ;;; Lisp type for the output - exact-return-type ;;; Only use this expansion when the output is - ;;; declared to have a subtype of RETURN-TYPE - expansion ;;; C template containing the expansion - one-liner ;;; Whether the expansion spans more than one line -) - -;;; -;;; VARIABLES -;;; - -;;; --cmpinline.lsp-- -;;; -;;; Empty info struct -;;; -(defvar *info* (make-info)) - -(defvar *inline-functions* nil) -(defvar *inline-blocks* 0) -;;; *inline-functions* holds: -;;; (...( function-name . inline-info )...) -;;; -;;; *inline-blocks* holds the number of C blocks opened for declaring -;;; temporaries for intermediate results of the evaluation of inlined -;;; function calls. - -;;; --cmputil.lsp-- -;;; -;;; Variables and constants for error handling -;;; -(defvar *current-form* '|compiler preprocess|) -(defvar *current-toplevel-form* '|compiler preprocess|) -(defvar *current-c2form* nil) -(defvar *compile-file-position* -1) -(defvar *first-error* t) -(defconstant *cmperr-tag* (cons nil nil)) - -(defvar *active-handlers* nil) -(defvar *active-protection* nil) -(defvar *pending-actions* nil) - -(defvar *compiler-conditions* '() - "This variable determines whether conditions are printed or just accumulated.") - -(defvar *compile-print* nil - "This variable controls whether the compiler displays messages about -each form it processes. The default value is NIL.") - -(defvar *compile-verbose* nil - "This variable controls whether the compiler should display messages about its -progress. The default value is T.") - -(defvar *suppress-compiler-messages* 'compiler-debug-note - "A type denoting which compiler messages and conditions are _not_ displayed.") - -(defvar *suppress-compiler-notes* nil) ; Deprecated -(defvar *suppress-compiler-warnings* nil) ; Deprecated - -(defvar *compiler-break-enable* nil) - -(defvar *compiler-in-use* nil) -(defvar *compiler-input*) -(defvar *compiler-output1*) -(defvar *compiler-output2*) - -;;; --cmpcbk.lsp-- -;;; -;;; List of callbacks to be generated -;;; -(defvar *callbacks* nil) - -;;; --cmpcall.lsp-- -;;; -;;; Whether to use linking calls. -;;; -(defvar *compile-to-linking-call* t) -(defvar *compiler-declared-globals*) - -;;; --cmpenv.lsp-- -;;; -;;; These default settings are equivalent to (optimize (speed 3) (space 0) (safety 2)) -;;; -(defvar *safety* 2) -(defvar *speed* 3) -(defvar *space* 0) -(defvar *debug* 0) - -;;; Emit automatic CHECK-TYPE forms for function arguments in lambda forms. -(defvar *automatic-check-type-in-lambda* t) - -;;; -;;; Compiled code uses the following kinds of variables: -;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl) -;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp) -;;; 4. lexi[j], for lexical variables in local functions -;;; 5. CLVi, for lexical variables in closures - -(defvar *lcl* 0) ; number of local variables - -(defvar *temp* 0) ; number of temporary variables -(defvar *max-temp* 0) ; maximum *temp* reached - -(defvar *level* 0) ; nesting level for local functions - -(defvar *lex* 0) ; number of lexical variables in local functions -(defvar *max-lex* 0) ; maximum *lex* reached - -(defvar *env* 0) ; number of variables in current form -(defvar *max-env* 0) ; maximum *env* in whole function -(defvar *env-lvl* 0) ; number of levels of environments -(defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls - -(defvar *next-cmacro* 0) ; holds the last cmacro number used. -(defvar *next-cfun* 0) ; holds the last cfun used. - -(defvar *debug-fun* 0) ; Level of debugging of functions - -;;; -;;; *tail-recursion-info* holds NIL, if tail recursion is impossible. -;;; If possible, *tail-recursion-info* holds -;; ( c1-lambda-form required-arg .... required-arg ), -;;; where each required-arg is a var-object. -;;; -(defvar *tail-recursion-info* nil) - -;;; -;;; *function-declarations* holds : -;; (... ( { function-name | fun-object } arg-types return-type ) ...) -;;; Function declarations for global functions are ASSOCed by function names, -;;; whereas those for local functions are ASSOCed by function objects. -;;; -;;; The valid argment type declaration is: -;; ( {type}* [ &optional {type}* ] [ &rest type ] [ &key {type}* ] ) -;;; though &optional, &rest, and &key return types are simply ignored. -;;; -(defvar *function-declarations* nil) -(defvar *allow-c-local-declaration* t) -(defvar *notinline* nil) - -;;; --cmpexit.lsp-- -;;; -;;; *last-label* holds the label# of the last used label. -;;; *exit* holds an 'exit', which is -;; ( label# . ref-flag ) or one of RETURNs (i.e. RETURN, RETURN-FIXNUM, -;; RETURN-CHARACTER, RETURN-DOUBLE-FLOAT, RETURN-SINGLE-FLOAT, or -;; RETURN-OBJECT). -;;; *unwind-exit* holds a list consisting of: -;; ( label# . ref-flag ), one of RETURNs, TAIL-RECURSION-MARK, FRAME, -;; JUMP, BDS-BIND (each pushed for a single special binding), or a -;; LCL (which holds the bind stack pointer used to unbind). -;;; -(defvar *last-label* 0) -(defvar *exit*) -(defvar *unwind-exit*) - -(defvar *current-function* nil) - -(defvar *cmp-env* (cons nil nil) -"The compiler environment consists of a pair or cons of two -lists, one containing variable records, the other one macro and -function recors: - -variable-record = (:block block-name) | - (:tag ({tag-name}*)) | - (:function function-name) | - (var-name {:special | nil} bound-p) | - (symbol si::symbol-macro macro-function) | - CB | LB | UNWIND-PROTECT -macro-record = (function-name function) | - (macro-name si::macro macro-function) - CB | LB | UNWIND-PROTECT - -A *-NAME is a symbol. A TAG-ID is either a symbol or a number. A -MACRO-FUNCTION is a function that provides us with the expansion -for that local macro or symbol macro. BOUND-P is true when the -variable has been bound by an enclosing form, while it is NIL if -the variable-record corresponds just to a special declaration. -CB, LB and UNWIND-PROTECT are only used by the C compiler and -they denote closure, lexical environment and unwind-protect -boundaries. Note that compared with the bytecodes compiler, these -records contain an additional variable, block, tag or function -object at the end.") - -;;; --cmplog.lsp-- -;;; -;;; Destination of output of different forms. See cmploc.lsp for types -;;; of destinations. -;;; -(defvar *destination*) - -;;; --cmpmain.lsp-- -;;; -;;; Do we debug the compiler? Then we need files not to be deleted. - -(defvar *debug-compiler* nil) -(defvar *delete-files* t) -(defvar *files-to-be-deleted* '()) - ;;; This is copied into each .h file generated, EXCEPT for system-p calls. ;;; The constant string *include-string* is the content of file "ecl.h". ;;; Here we use just a placeholder: it will be replaced with sed. @@ -477,16 +52,6 @@ coprocessor).") (defvar *ld-bundle-flags* #-msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@" #+msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@") -(defvar *user-ld-flags* '() -"Flags and options to be passed to the linker when building FASL, shared libraries -and standalone programs. It is not required to surround values with quotes or use -slashes before special characters.") - -(defvar *user-cc-flags* '() -"Flags and options to be passed to the C compiler when building FASL, shared libraries -and standalone programs. It is not required to surround values with quotes or use -slashes before special characters.") - (defvar +shared-library-prefix+ "@SHAREDPREFIX@") (defvar +shared-library-extension+ "@SHAREDEXT@") (defvar +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@") @@ -503,85 +68,3 @@ slashes before special characters.") (let ((x "@ECL_LDRPATH@")) (and (plusp (length x)) (format nil x *ecl-library-directory*)))) - -;;; -;;; Compiler program and flags. -;;; - -;;; --cmptop.lsp-- -;;; -(defvar *do-type-propagation* nil - "Flag for switching on the type propagation phase. Use with care, experimental.") - -(defvar *compiler-phase* nil) - -(defvar *volatile*) -(defvar *setjmps* 0) - -(defvar *compile-toplevel* T - "Holds NIL or T depending on whether we are compiling a toplevel form.") - -(defvar *clines-string-list* '() - "List of strings containing C/C++ statements which are directly inserted -in the translated C/C++ file. Notice that it is unspecified where these -lines are inserted, but the order is preserved") - -(defvar *compile-time-too* nil) -(defvar *not-compile-time* nil) - -(defvar *permanent-data* nil) ; detemines whether we use *permanent-objects* - ; or *temporary-objects* -(defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }* -(defvar *temporary-objects* nil) ; holds { ( object (VV vv-index) ) }* -(defvar *load-objects* nil) ; hash with association object -> vv-location -(defvar *load-time-values* nil) ; holds { ( vv-index form ) }*, -;;; where each vv-index should be given an object before -;;; defining the current function during loading process. - -(defvar *use-static-constants-p* nil) ; T/NIL flag to determine whether one may - ; generate lisp constant values as C structs -(defvar *static-constants* nil) ; constants that can be built as C values - ; holds { ( object c-variable constant ) }* - -(defvar *compiler-constants* nil) ; a vector with all constants - ; only used in COMPILE - -(defvar *proclaim-fixed-args* nil) ; proclaim automatically functions - ; with fixed number of arguments. - ; watch out for multiple values. - -(defvar *global-var-objects* nil) ; var objects for global/special vars -(defvar *global-vars* nil) ; variables declared special -(defvar *global-funs* nil) ; holds { fun }* -(defvar *global-cfuns-array* nil) ; holds { fun }* -(defvar *linking-calls* nil) ; holds { ( global-fun-name fun symbol c-fun-name var-name ) }* -(defvar *local-funs* nil) ; holds { fun }* -(defvar *top-level-forms* nil) ; holds { top-level-form }* -(defvar *make-forms* nil) ; holds { top-level-form }* - -;;; -;;; top-level-form: -;;; ( 'DEFUN' fun-name cfun lambda-expr doc-vv sp ) -;;; | ( 'DEFMACRO' macro-name cfun lambda-expr doc-vv sp ) -;;; | ( 'ORDINARY' expr ) -;;; | ( 'DECLARE' var-name-vv ) -;;; | ( 'DEFVAR' var-name-vv expr doc-vv ) -;;; | ( 'CLINES' string* ) -;;; | ( 'LOAD-TIME-VALUE' vv ) - -(defvar *reservations* nil) -(defvar *reservation-cmacro* nil) - -;;; *reservations* holds (... ( cmacro . value ) ...). -;;; *reservation-cmacro* holds the cmacro current used as vs reservation. - -;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). -(defvar *global-entries* nil) - -(defvar *self-destructing-fasl* '() -"A value T means that, when a FASL module is being unloaded (for -instance during garbage collection), the associated file will be -deleted. We need this for #'COMPILE because windows DLLs cannot -be deleted if they have been opened with LoadLibrary.") - -(defvar *undefined-vars* nil) diff --git a/src/cmp/cmpenv-api.lsp b/src/cmp/cmpenv-api.lsp new file mode 100644 index 000000000..ba90cd285 --- /dev/null +++ b/src/cmp/cmpenv-api.lsp @@ -0,0 +1,200 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPENVAPI -- API for creating and manipulating environments +;;;; + +(in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV") + +(defmacro cmp-env-new () + '(cons nil nil)) + +(defun cmp-env-copy (&optional (env *cmp-env*)) + (cons (car env) (cdr env))) + +(defmacro cmp-env-variables (&optional (env '*cmp-env*)) + `(car ,env)) + +(defmacro cmp-env-functions (&optional (env '*cmp-env*)) + `(cdr ,env)) + +#-new-cmp +(defun cmp-env-cleanups (env) + (loop with specials = '() + with end = (cmp-env-variables env) + with cleanup-forms = '() + with aux + for records-list on (cmp-env-variables *cmp-env*) + until (eq records-list end) + do (let ((record (first records-list))) + (cond ((atom record)) + ((and (symbolp (first record)) + (eq (second record) :special)) + (push (fourth record) specials)) + ((eq (first record) :cleanup) + (push (second record) cleanup-forms)))) + finally (progn + (unless (eq records-list end) + (error "Inconsistency in environment.")) + (return (values specials + (apply #'nconc (mapcar #'copy-list cleanup-forms))))))) + +(defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t)) + (push (list (var-name var) + (if (member (var-kind var) '(special global)) + :special + t) + boundp + var) + (cmp-env-variables env)) + env) + +(defun cmp-env-declare-special (name &optional (env *cmp-env*)) + (cmp-env-register-var (c::c1make-global-variable name :warn nil :kind 'SPECIAL) + env nil) + env) + +(defun cmp-env-add-declaration (type arguments &optional (env *cmp-env*)) + (push (list* :declare type arguments) + (cmp-env-variables env)) + env) + +(defun cmp-env-extend-declaration (type arguments &optional (env *cmp-env*)) + (let ((x (cmp-env-search-declaration type))) + (cmp-env-add-declaration type (append arguments x) env) + env)) + +(defun cmp-env-register-function (fun &optional (env *cmp-env*)) + (push (list (fun-name fun) 'function fun) + (cmp-env-functions env)) + env) + +(defun cmp-env-register-macro (name function &optional (env *cmp-env*)) + (push (list name 'si::macro function) + (cmp-env-functions env)) + env) + +(defun cmp-env-register-ftype (name declaration &optional (env *cmp-env*)) + (push (list* :declare name declaration) + (cmp-env-functions env)) + env) + +(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*)) + (push (list name 'si::symbol-macro #'(lambda (whole env) form)) + (cmp-env-variables env)) + env) + +(defun cmp-env-register-block (blk &optional (env *cmp-env*)) + (push (list :block (blk-name blk) blk) + (cmp-env-variables env)) + env) + +(defun cmp-env-register-tag (name tag &optional (env *cmp-env*)) + (push (list :tag (list name) tag) + (cmp-env-variables env)) + env) + +(defun cmp-env-register-cleanup (form &optional (env *cmp-env*)) + (push (list :cleanup (copy-list form)) (cmp-env-variables env)) + env) + +(defun cmp-env-search-function (name &optional (env *cmp-env*)) + (let ((ccb nil) + (clb nil) + (unw nil) + (found nil)) + (dolist (record (cmp-env-functions env)) + (cond ((eq record 'CB) + (setf ccbb t)) + ((eq record 'LB) + (setf clb t)) + ((eq record 'UNWIND-PROTECT) + (setf unw t)) + ((atom record) + (baboon)) + ;; We have to use EQUAL because the name can be a list (SETF whatever) + ((equal (first record) name) + (setf found (first (last record))) + (return)))) + (values found ccb clb unw))) + +(defun cmp-env-search-variables (type name env) + (let ((ccb nil) + (clb nil) + (unw nil) + (found nil)) + (dolist (record (cmp-env-variables env)) + (cond ((eq record 'CB) + (setf ccb t)) + ((eq record 'LB) + (setf clb t)) + ((eq record 'UNWIND-PROTECT) + (setf unw t)) + ((atom record) + (baboon)) + ((not (eq (first record) type))) + ((eq type :block) + (when (eq name (second record)) + (setf found record) + (return))) + ((eq type :tag) + (when (member name (second record) :test #'eql) + (setf found record) + (return))) + ((eq (second record) 'si::symbol-macro) + (when (eq name 'si::symbol-macro) + (setf found record)) + (return)) + (t + (setf found record) + (return)))) + (values (first (last found)) ccb clb unw))) + +(defun cmp-env-search-block (name &optional (env *cmp-env*)) + (cmp-env-search-variables :block name env)) + +(defun cmp-env-search-tag (name &optional (env *cmp-env*)) + (cmp-env-search-variables :tag name env)) + +(defun cmp-env-search-symbol-macro (name &optional (env *cmp-env*)) + (cmp-env-search-variables name 'si::symbol-macro env)) + +(defun cmp-env-search-var (name &optional (env *cmp-env*)) + (cmp-env-search-variables name t env)) + +(defun cmp-env-search-macro (name &optional (env *cmp-env*)) + (let ((f (cmp-env-search-function name env))) + (if (functionp f) f nil))) + +(defun cmp-env-search-ftype (name &optional (env *cmp-env*)) + (dolist (i env nil) + (when (and (consp i) + (eq (pop i) :declare) + (same-fname-p (pop i) name)) + (return i)))) + +(defun cmp-env-mark (mark &optional (env *cmp-env*)) + (cons (cons mark (car env)) + (cons mark (cdr env)))) + +(defun cmp-env-new-variables (new-env old-env) + (loop for i in (ldiff (cmp-env-variables *cmp-env*) + (cmp-env-variables old-env)) + when (and (consp i) (var-p (fourth i))) + collect (fourth i))) + +(defun cmp-env-search-declaration (kind &optional (env *cmp-env*)) + (loop for i in (car env) + when (and (consp i) + (eq (first i) :declare) + (eq (second i) kind)) + return (cddr i))) + diff --git a/src/cmp/cmpenv-declaim.lsp b/src/cmp/cmpenv-declaim.lsp new file mode 100644 index 000000000..c9a259625 --- /dev/null +++ b/src/cmp/cmpenv-declaim.lsp @@ -0,0 +1,52 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPENV-DECLAIM -- Proclamations local to the current file +;;;; +;;;; One implementation of DECLAIM that uses the compiler environment +;;;; providing a "base" set of entries that all other environments +;;;; stem from. +;;;; + +(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV") + +(defun process-declaim-args (args) + (flet ((add-variables (env types specials) + (loop for name in specials + unless (assoc name types) + do (let ((v (c1make-global-variable name :kind 'special))) + (setf env (cmp-env-register-var v env)))) + (loop for (name . type) in types + for specialp = (or (sys:specialp name) (member name specials)) + for kind = (if specialp 'SPECIAL 'GLOBAL) + for v = (c1make-global-variable name :type type :kind kind) + do (setf env (cmp-env-register-var v env))) + env)) + (multiple-value-bind (body specials types ignored others doc all) + (c1body `((DECLARE ,@args)) nil) + (when ignored + (cmpwarn "IGNORE/IGNORABLE declarations in DECLAIM are ignored")) + (reduce #'add-one-declaration others + :initial-value (add-variables *cmp-env* types specials)) + (reduce #'add-one-declaration others + :initial-value (add-variables *cmp-env-root* types specials))))) + +(defmacro declaim (&rest declarations) + `(progn + (ext:with-backend + :c/c++ (eval-when (:compile-toplevel) + (c::process-declaim-args ',declarations)) + :bytecodes (eval-when (:compile-toplevel) + (proclaim ',declarations))) + (eval-when (:load-toplevel :execute) + (mapc 'proclaim ',declarations)))) diff --git a/src/cmp/cmpenv-declare.lsp b/src/cmp/cmpenv-declare.lsp new file mode 100644 index 000000000..b6023288b --- /dev/null +++ b/src/cmp/cmpenv-declare.lsp @@ -0,0 +1,217 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPENV-DECLARE -- Declarations for the compiler +;;;; +;;;; Extract, process and incorporate declarations into the compiler +;;;; environment. Unlike proclamations, these are local to the current +;;;; compiled file and do not propagate beyond it. +;;;; + +(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV") + +(defun proper-list-p (x &optional test) + (and (listp x) + (handler-case (list-length x) (type-error (c) nil)) + (or (null test) (every test x)))) + +(defun type-name-p (name) + (or (get-sysprop name 'SI::DEFTYPE-DEFINITION) + (find-class name nil) + (get-sysprop name 'SI::STRUCTURE-TYPE))) + +(defun validate-alien-declaration (names-list error) + (dolist (new-declaration names-list) + (unless (symbolp new-declaration) + (cmperr "The declaration ~s is not a symbol" new-declaration)) + (when (type-name-p new-declaration) + (cmperr "Symbol name ~S cannot be both the name of a type and of a declaration" + new-declaration)))) + +(defun alien-declaration-p (name &optional (env *cmp-env*)) + (or (member name si::*alien-declarations*) + (member name (cmp-env-search-declaration 'alien env)))) + +(defun parse-ignore-declaration (decl-args expected-ref-number tail) + (declare (si::c-local)) + (loop for name in decl-args + do (if (symbolp name) + (push (cons name expected-ref-number) tail) + (cmpassert (and (consp name) + (= (length name) 2) + (eq (first name) 'function)) + "Invalid argument to IGNORE/IGNORABLE declaration:~&~A" + name))) + tail) + +(defun collect-declared (type var-list tail) + (declare (si::c-local)) + (cmpassert (proper-list-p var-list #'symbolp) + "Syntax error in declaration ~s" decl) + (loop for var-name in var-list + do (push (cons var-name type) tail)) + tail) + +(defun c1body (body doc-p) + "Split a function body into a list of forms, a set of declarations, +and a possible documentation string (only accepted when DOC-P is true)." + (multiple-value-bind (all-declarations body doc specials) + (si:process-declarations body doc-p) + (loop with others = '() + with types = '() + with ignored = '() + for decl in all-declarations + for decl-name = (first decl) + for decl-args = (rest decl) + do (cmpassert (and (proper-list-p decl-args) (symbolp decl-name)) + "Syntax error in declaration ~s" decl) + do (case decl-name + (SPECIAL) + (IGNORE + (cmpassert (proper-list-p decl-args #'symbolp) + "Syntax error in declaration ~s" decl) + (setf ignored (parse-ignore-declaration decl-args -1 ignored))) + (IGNORABLE + (cmpassert (proper-list-p decl-args #'symbolp) + "Syntax error in declaration ~s" decl) + (setf ignored (parse-ignore-declaration decl-args 0 ignored))) + (TYPE + (cmpassert (and (consp decl-args) + (proper-list-p (rest decl-args) #'symbolp)) + "Syntax error in declaration ~s" decl) + (setf types (collect-declared (first decl-args) + (rest decl-args) + types))) + (OBJECT + (cmpassert (proper-list-p decl-args #'symbolp) + "Syntax error in declaration ~s" decl) + (setf types (collect-declared 'OBJECT decl-args types))) + ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL + SI::C-GLOBAL DYNAMIC-EXTENT IGNORABLE VALUES + SI::NO-CHECK-TYPE POLICY-DEBUG-IHS-FRAME :READ-ONLY) + (push decl others)) + (otherwise + (if (alien-declaration-p decl-name) + (push decl others) + (multiple-value-bind (ok type) + (valid-type-specifier decl-name) + (cmpassert ok "Unknown declaration specifier ~s" + decl-name) + (setf types (collect-declared type decl-args types)))))) + finally (return (values body specials types ignored + (nreverse others) doc all-declarations))))) + +(defun default-optimization (optimization) + (ecase optimization + (speed *speed*) + (safety *safety*) + (space *space*) + (debug *debug*))) + +(defun search-optimization-quality (declarations what) + (dolist (i (reverse declarations) + (default-optimization what)) + (when (and (consp i) (eq (first i) 'policy-debug-ihs-frame) + (eq what 'debug)) + (return 2)) + (when (and (consp i) (eq (first i) 'optimize)) + (dolist (j (rest i)) + (cond ((consp j) + (when (eq (first j) what) + (return-from search-optimization-quality (second j)))) + ((eq j what) + (return-from search-optimization-quality 3))))))) + +(defun compute-optimizations (arguments env) + (let ((optimizations (cmp-env-all-optimizations env))) + (dolist (x arguments) + (when (symbolp x) (setq x (list x 3))) + (unless optimizations + (setq optimizations (cmp-env-all-optimizations))) + (if (or (not (consp x)) + (not (consp (cdr x))) + (not (numberp (second x))) + (not (<= 0 (second x) 3))) + (cmpwarn "Illegal OPTIMIZE proclamation ~s" x) + (let ((value (second x))) + (case (car x) + (DEBUG (setf (first optimizations) value)) + (SAFETY (setf (second optimizations) value)) + (SPACE (setf (third optimizations) value)) + (SPEED (setf (fourth optimizations) value)) + (COMPILATION-SPEED) + (t (cmpwarn "Unknown OPTIMIZE quality ~s" (car x))))))) + optimizations)) + +(defun add-one-declaration (env decl) + "Add to the environment one declarations which is not type, ignorable or +special variable declarations, as these have been extracted before." + (case (car decl) + (OPTIMIZE + (let ((optimizations (compute-optimizations (rest decl) env))) + (cmp-env-add-declaration 'optimize optimizations env))) + (POLICY-DEBUG-IHS-FRAME + (let ((flag (or (rest decl) '(t)))) + (if *current-function* + (progn + (cmp-env-add-declaration 'policy-debug-ihs-frame flag + (fun-cmp-env *current-function*)) + env) + (cmp-env-add-declaration 'policy-debug-ihs-frame + flag env)))) + (FTYPE + (if (atom (rest decl)) + (cmpwarn "Syntax error in declaration ~a" decl) + (multiple-value-bind (type-name args) + (si::normalize-type (second decl)) + (if (eq type-name 'FUNCTION) + (dolist (v (cddr decl)) + (setf env (add-function-declaration v (first args) + (rest args) env))) + (cmpwarn "In an FTYPE declaration, found ~A which is not a function type." + (second decl))))) + env) + (INLINE + (declare-inline (rest decl) env)) + (NOTINLINE + (setf env (declare-notinline (rest decl) env))) + (DECLARATION + (validate-alien-declaration (rest decl) #'cmperr) + (setf env (cmp-env-extend-declaration 'alien (rest decl) env))) + ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE :READ-ONLY) + env) + ((DYNAMIC-EXTENT IGNORABLE) + ;; FIXME! SOME ARE IGNORED! + env) + (otherwise + (unless (alien-declaration-p (first decl) env) + (cmpwarn "Unknown declaration specifier ~s" (first decl))) + env))) + +(defun symbol-macro-declaration-p (name type) + (let* ((record (cmp-env-search-variables name 'si::symbol-macro *cmp-env*))) + (when (and record (functionp record)) + (let* ((expression (funcall record name nil))) + (cmp-env-register-symbol-macro name `(the ,type ,expression))) + t))) + +(defun check-vdecl (vnames ts is) + (loop for (var . type) in ts + unless (or (member var vnames :test #'eq) + (symbol-macro-declaration-p var type)) + do (cmpwarn "Declaration of type~&~4T~A~&was found for not bound variable ~s." + type var)) + (loop for (var . expected-uses) in is + unless (member var vnames :test #'eq) + do (cmpwarn (if (minusp expected-uses) + "IGNORE declaration was found for not bound variable ~s." + "IGNORABLE declaration was found for not bound variable ~s.") + var))) diff --git a/src/cmp/cmpenv-fun.lsp b/src/cmp/cmpenv-fun.lsp new file mode 100644 index 000000000..38b5771cb --- /dev/null +++ b/src/cmp/cmpenv-fun.lsp @@ -0,0 +1,147 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPTYPE-PROP -- Type propagation basic routines and database +;;;; + +(in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV") + +(defun function-arg-types (arg-types &aux (types nil)) + (do ((al arg-types (cdr al))) + ((or (endp al) + (member (car al) '(&optional &rest &key))) + (nreverse types)) + (declare (object al)) + (push (type-filter (car al)) types))) + +;;; The valid return type declaration is: +;;; (( VALUES {type}* )) or ( {type}* ). + +(defun function-return-type (return-types) + (cond ((endp return-types) t) + ((and (consp (car return-types)) + (eq (caar return-types) 'VALUES)) + (cond ((not (endp (cdr return-types))) + (warn "The function return types ~s is illegal." return-types) + t) + ((or (endp (cdar return-types)) + (member (cadar return-types) '(&optional &rest &key))) + t) + (t (type-filter (car return-types) t)))) + (t (#-new-cmp type-filter #+new-cmp c-types:type-filter + (car return-types))))) + +(defun proclaim-function (fname decl) + (if (si:valid-function-name-p fname) + (let* ((arg-types '*) + (return-types '*) + (l decl)) + (cond ((null l)) + ((consp l) + (setf arg-types (pop l))) + (t (warn "The function proclamation ~s ~s is not valid." + fname decl))) + (cond ((null l)) + ((and (consp l) (null (rest l))) + (setf return-types (function-return-type l))) + (t (warn "The function proclamation ~s ~s is not valid." + fname decl))) + (when (eq arg-types '()) + (setf arg-types '(&optional))) + (if (eq arg-types '*) + (rem-sysprop fname 'PROCLAIMED-ARG-TYPES) + (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types)) + (if (member return-types '(* (VALUES &rest t)) + :test #'equalp) + (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE) + (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types))) + (warn "The function proclamation ~s ~s is not valid." fname decl))) + +(defun add-function-declaration (fname arg-types return-types &optional (env *cmp-env*)) + (if (si::valid-function-name-p fname) + (let ((fun (cmp-env-search-function fname))) + (if (functionp fun) + (warn "Found function declaration for local macro ~A" fname) + (cmp-env-register-ftype fname (list arg-types return-types) env))) + (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)) + env) + +(defun get-arg-types (fname &optional (env *cmp-env*)) + (let ((x (cmp-env-search-ftype fname env))) + (if x + (values (first x) t) + (sys:get-sysprop fname 'PROCLAIMED-ARG-TYPES)))) + +(defun get-return-type (fname &optional (env *cmp-env*)) + (let ((x (cmp-env-search-ftype fname env))) + (if x + (values (second x) t) + (sys:get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))) + +(defun get-local-arg-types (fun &optional (env *cmp-env*)) + (let ((x (cmp-env-search-ftype (fun-name fun)))) + (if x + (values (first x) t) + (values nil nil)))) + +(defun get-local-return-type (fun &optional (env *cmp-env*)) + (let ((x (cmp-env-search-ftype (fun-name fun)))) + (if x + (values (second x) t) + (values nil nil)))) + +(defun get-proclaimed-narg (fun &optional (env *cmp-env*)) + (multiple-value-bind (arg-list found) + (get-arg-types fun env) + (if found + (loop for type in arg-list + with minarg = 0 + and maxarg = 0 + and in-optionals = nil + do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq) + (return (values minarg call-arguments-limit))) + ((eq type '&optional) + (setf in-optionals t maxarg minarg)) + (in-optionals + (incf maxarg)) + (t + (incf minarg) + (incf maxarg))) + finally (return (values minarg maxarg found))) + (values 0 call-arguments-limit found)))) + +;;; Proclamation and declaration handling. + +(defun declare-inline (fname-list &optional (env *cmp-env*)) + (unless (every #'si::valid-function-name-p fname-list) + (cmperr "Not a valid argument to INLINE declaration~%~4I~A" + fname-list)) + (cmp-env-extend-declaration 'INLINE + (loop for name in fname-list + collect (cons name t)))) + +(defun declare-notinline (fname-list &optional (env *cmp-env*)) + (unless (every #'symbolp fname-list) + (cmperr "Not a valid argument to NOTINLINE declaration~%~4I~A" + fname-list)) + (cmp-env-extend-declaration 'INLINE + (loop for name in fname-list + collect (cons name nil)))) + +(defun inline-possible (fname &optional (env *cmp-env*)) + (let* ((x (cmp-env-search-declaration 'inline env)) + (flag (assoc fname x :test #'same-fname-p))) + (if flag + (cdr flag) + (not (or ;; (compiler-= *debug* 2) Breaks compilation of STACK-PUSH-VALUES + (sys:get-sysprop fname 'CMP-NOTINLINE)))))) + diff --git a/src/cmp/cmpenv-proclaim.lsp b/src/cmp/cmpenv-proclaim.lsp new file mode 100644 index 000000000..3557ecb61 --- /dev/null +++ b/src/cmp/cmpenv-proclaim.lsp @@ -0,0 +1,136 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPENV-PROCLAIM -- Proclamations for the compiler +;;;; +;;;; One implementation of PROCLAIM that uses symbol properties to +;;;; store the proclamations. This has the disadvantage that +;;;; proclamations can not be easily cleaned up. +;;;; +;;;; The following code is to be coordinated with that in sysfun.lsp +;;;; and proclamations.lsp +;;;; + +(in-package #-ecl-new "COMPILER" #+ecl-new "C-ENV") + +#-:CCL +(defun proclaim (decl &aux decl-name) + (unless (listp decl) + (error "The proclamation specification ~s is not a list" decl)) + (case (setf decl-name (car decl)) + (SPECIAL + (dolist (var (cdr decl)) + (if (symbolp var) + (sys:*make-special var) + (error "Syntax error in proclamation ~s" decl)))) + (OPTIMIZE + (dolist (x (cdr decl)) + (when (symbolp x) (setq x (list x 3))) + (if (or (not (consp x)) + (not (consp (cdr x))) + (not (numberp (second x))) + (not (<= 0 (second x) 3))) + (warn "The OPTIMIZE proclamation ~s is illegal." x) + (case (car x) + (DEBUG (setq *debug* (second x))) + (SAFETY (setq *safety* (second x))) + (SPACE (setq *space* (second x))) + (SPEED (setq *speed* (second x))) + (COMPILATION-SPEED (setq *speed* (- 3 (second x)))) + (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) + (TYPE + (if (consp (cdr decl)) + (proclaim-var (second decl) (cddr decl)) + (error "Syntax error in proclamation ~s" decl))) + (FTYPE + (if (atom (rest decl)) + (error "Syntax error in proclamation ~a" decl) + (multiple-value-bind (type-name args) + (si::normalize-type (second decl)) + (if (eq type-name 'FUNCTION) + (dolist (v (cddr decl)) + (proclaim-function v args)) + (error "In an FTYPE proclamation, found ~A which is not a function type." + (second decl)))))) + (INLINE + (dolist (fun (cdr decl)) + (if (si::valid-function-name-p fun) + (rem-sysprop fun 'CMP-NOTINLINE) + (error "Not a valid function name ~s in proclamation ~s" fun decl)))) + (NOTINLINE + (dolist (fun (cdr decl)) + (if (si::valid-function-name-p fun) + (put-sysprop fun 'CMP-NOTINLINE t) + (error "Not a valid function name ~s in proclamation ~s" fun decl)))) + ((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE) + ;; FIXME! IGNORED! + (dolist (var (cdr decl)) + (unless (si::valid-function-name-p var) + (error "Not a valid function name ~s in ~s proclamation" fun decl-name)))) + (DECLARATION + (validate-alien-declaration (rest decl) #'error) + (setf si::*alien-declarations* + (append (rest decl) si:*alien-declarations*))) + (SI::C-EXPORT-FNAME + (dolist (x (cdr decl)) + (cond ((symbolp x) + (multiple-value-bind (found c-name) + (si::mangle-name x t) + (if found + (warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x) + (put-sysprop x 'Lfun c-name)))) + ((consp x) + (destructuring-bind (c-name lisp-name) x + (if (si::mangle-name lisp-name) + (warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name) + (put-sysprop lisp-name 'Lfun c-name)))) + (t + (error "Syntax error in proclamation ~s" decl))))) + ((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER 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 + READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR + SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING + SYMBOL T VECTOR SIGNED-BYTE UNSIGNED-BYTE FUNCTION) + (proclaim-var decl-name (cdr decl))) + (otherwise + (cond ((member (car decl) si:*alien-declarations*)) + ((multiple-value-bind (ok type) + (valid-type-specifier decl-name) + (when ok + (proclaim-var type (rest decl)) + t))) + ((let ((proclaimer (get-sysprop (car decl) :proclaim))) + (when (functionp proclaimer) + (mapc proclaimer (rest decl)) + t))) + (t + (warn "Unknown declaration specifier ~s" decl-name)))))) + +(defun proclaim-var (type vl) + (setq type (type-filter type)) + (dolist (var vl) + (if (symbolp var) + (let ((type1 (get-sysprop var 'CMP-TYPE)) + (v (sch-global var))) + (setq type1 (if type1 (type-and type1 type) type)) + (when v (setq type1 (type-and type1 (var-type v)))) + (unless type1 + (warn + "Inconsistent type declaration was found for the variable ~s." + var) + (setq type1 T)) + (put-sysprop var 'CMP-TYPE type1) + (when v (setf (var-type v) type1))) + (warn "The variable name ~s is not a symbol." var)))) + diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp deleted file mode 100644 index 2d2908d67..000000000 --- a/src/cmp/cmpenv.lsp +++ /dev/null @@ -1,688 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- -;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. -;;;; Copyright (c) 1990, Giuseppe Attardi. -;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. - -;;;; CMPENV Environments of the Compiler. - -(in-package "COMPILER") - -;;; Only these flags are set by the user. -;;; If (safe-compile) is ON, some kind of run-time checks are not -;;; included in the compiled code. The default value is OFF. - -(defconstant +init-env-form+ - '((*gensym-counter* 0) - (*compiler-in-use* t) - (*compiler-phase* 't1) - (*callbacks* nil) - (*max-temp* 0) - (*temp* 0) - (*next-cmacro* 0) - (*next-cfun* 0) - (*last-label* 0) - (*load-objects* (make-hash-table :size 128 :test #'equal)) - (*make-forms* nil) - (*static-constants* nil) - (*permanent-objects* nil) - (*temporary-objects* nil) - (*local-funs* nil) - (*global-var-objects* nil) - (*global-vars* nil) - (*global-funs* nil) - (*global-cfuns-array* nil) - (*linking-calls* nil) - (*global-entries* nil) - (*undefined-vars* nil) - (*reservations* nil) - (*top-level-forms* nil) - (*compile-time-too* nil) - (*clines-string-list* '()) - (*inline-functions* nil) - (*inline-blocks* 0) - (*notinline* nil) - (*debugger-hook* 'compiler-debugger))) - -(defun next-lcl () (list 'LCL (incf *lcl*))) - -(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) - (let ((code (incf *next-cfun*))) - (format nil prefix code (lisp-to-c-name lisp-name)))) - -(defun next-temp () - (prog1 *temp* - (incf *temp*) - (setq *max-temp* (max *temp* *max-temp*)))) - -(defun next-lex () - (prog1 (cons *level* *lex*) - (incf *lex*) - (setq *max-lex* (max *lex* *max-lex*)))) - -(defun next-env () (prog1 *env* - (incf *env*) - (setq *max-env* (max *env* *max-env*)))) - -(defun function-arg-types (arg-types &aux (types nil)) - (do ((al arg-types (cdr al))) - ((or (endp al) - (member (car al) '(&optional &rest &key))) - (nreverse types)) - (declare (object al)) - (push (type-filter (car al)) types))) - -;;; The valid return type declaration is: -;;; (( VALUES {type}* )) or ( {type}* ). - -(defun function-return-type (return-types) - (cond ((endp return-types) t) - ((and (consp (car return-types)) - (eq (caar return-types) 'VALUES)) - (cond ((not (endp (cdr return-types))) - (warn "The function return types ~s is illegal." return-types) - t) - ((or (endp (cdar return-types)) - (member (cadar return-types) '(&optional &rest &key))) - t) - (t (type-filter (car return-types) t)))) - (t (type-filter (car return-types))))) - -(defun add-function-proclamation (fname decl) - (if (si:valid-function-name-p fname) - (let* ((arg-types '*) - (return-types '*) - (l decl)) - (cond ((null l)) - ((consp l) - (setf arg-types (pop l))) - (t (warn "The function proclamation ~s ~s is not valid." - fname decl))) - (cond ((null l)) - ((and (consp l) (null (rest l))) - (setf return-types (function-return-type l))) - (t (warn "The function proclamation ~s ~s is not valid." - fname decl))) - (if (eq arg-types '*) - (rem-sysprop fname 'PROCLAIMED-ARG-TYPES) - (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types)) - (if (eq return-types '*) - (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE) - (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types))) - (warn "The function proclamation ~s ~s is not valid." fname decl))) - -(defun add-function-declaration (fname arg-types return-types) - (if (si::valid-function-name-p fname) - (let ((fun (cmp-env-search-function fname))) - (if (functionp fun) - (warn "Found function declaration for local macro ~A" fname) - (push (list fun - (function-arg-types arg-types) - (function-return-type return-types)) - *function-declarations*))) - (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname))) - -(defun get-arg-types (fname) - (let ((x (assoc fname *function-declarations*))) - (if x - (values (second x) t) - (get-sysprop fname 'PROCLAIMED-ARG-TYPES)))) - -(defun get-return-type (fname) - (let ((x (assoc fname *function-declarations*))) - (if x - (values (third x) t) - (get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))) - -(defun get-local-arg-types (fun &aux x) - (if (setq x (assoc fun *function-declarations*)) - (values (second x) t) - (values nil nil))) - -(defun get-local-return-type (fun &aux x) - (if (setq x (assoc fun *function-declarations*)) - (values (caddr x) t) - (values nil nil))) - -(defun get-proclaimed-narg (fun) - (multiple-value-bind (arg-list found) - (get-arg-types fun) - (if found - (loop for type in arg-list - with minarg = 0 - and maxarg = 0 - and in-optionals = nil - do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq) - (return (values minarg call-arguments-limit))) - ((eq type '&optional) - (setf in-optionals t maxarg minarg)) - (in-optionals - (incf maxarg)) - (t - (incf minarg) - (incf maxarg))) - finally (return (values minarg maxarg))) - (values 0 call-arguments-limit)))) - -;;; Proclamation and declaration handling. - -(defun inline-possible (fname) - (not (or ; (compiler-= *debug* 2) Breaks compilation of STACK-PUSH-VALUES - (member fname *notinline* :test #'same-fname-p) - (get-sysprop fname 'CMP-NOTINLINE)))) - -#-:CCL -(defun proclaim (decl &aux decl-name) - (unless (listp decl) - (error "The proclamation specification ~s is not a list" decl)) - (case (setf decl-name (car decl)) - (SPECIAL - (dolist (var (cdr decl)) - (if (symbolp var) - (sys:*make-special var) - (error "Syntax error in proclamation ~s" decl)))) - (OPTIMIZE - (dolist (x (cdr decl)) - (when (symbolp x) (setq x (list x 3))) - (if (or (not (consp x)) - (not (consp (cdr x))) - (not (numberp (second x))) - (not (<= 0 (second x) 3))) - (warn "The OPTIMIZE proclamation ~s is illegal." x) - (case (car x) - (DEBUG (setq *debug* (second x))) - (SAFETY (setq *safety* (second x))) - (SPACE (setq *space* (second x))) - (SPEED (setq *speed* (second x))) - (COMPILATION-SPEED (setq *speed* (- 3 (second x)))) - (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) - (TYPE - (if (consp (cdr decl)) - (proclaim-var (second decl) (cddr decl)) - (error "Syntax error in proclamation ~s" decl))) - (FTYPE - (if (atom (rest decl)) - (error "Syntax error in proclamation ~a" decl) - (multiple-value-bind (type-name args) - (si::normalize-type (second decl)) - (if (eq type-name 'FUNCTION) - (dolist (v (cddr decl)) - (add-function-proclamation v args)) - (error "In an FTYPE proclamation, found ~A which is not a function type." - (second decl)))))) - (INLINE - (dolist (fun (cdr decl)) - (if (si::valid-function-name-p fun) - (rem-sysprop fun 'CMP-NOTINLINE) - (error "Not a valid function name ~s in proclamation ~s" fun decl)))) - (NOTINLINE - (dolist (fun (cdr decl)) - (if (si::valid-function-name-p fun) - (put-sysprop fun 'CMP-NOTINLINE t) - (error "Not a valid function name ~s in proclamation ~s" fun decl)))) - ((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE) - ;; FIXME! IGNORED! - (dolist (var (cdr decl)) - (unless (si::valid-function-name-p var) - (error "Not a valid function name ~s in ~s proclamation" fun decl-name)))) - (DECLARATION - (do-declaration (rest decl) #'error)) - (SI::C-EXPORT-FNAME - (dolist (x (cdr decl)) - (cond ((symbolp x) - (multiple-value-bind (found c-name) - (si::mangle-name x t) - (if found - (warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x) - (put-sysprop x 'Lfun c-name)))) - ((consp x) - (destructuring-bind (c-name lisp-name) x - (if (si::mangle-name lisp-name) - (warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name) - (put-sysprop lisp-name 'Lfun c-name)))) - (t - (error "Syntax error in proclamation ~s" decl))))) - ((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER 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 - READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR - SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING - SYMBOL T VECTOR SIGNED-BYTE UNSIGNED-BYTE FUNCTION) - (proclaim-var decl-name (cdr decl))) - (otherwise - (cond ((member (car decl) si:*alien-declarations*)) - ((multiple-value-bind (ok type) - (valid-type-specifier decl-name) - (when ok - (proclaim-var type (rest decl)) - t))) - ((let ((proclaimer (get-sysprop (car decl) :proclaim))) - (when (functionp proclaimer) - (mapc proclaimer (rest decl)) - t))) - (t - (warn "The declaration specifier ~s is unknown." decl-name)))))) - -(defun type-name-p (name) - (or (get-sysprop name 'SI::DEFTYPE-DEFINITION) - (find-class name nil) - (get-sysprop name 'SI::STRUCTURE-TYPE))) - -(defun do-declaration (names-list error) - (declare (si::c-local)) - (dolist (new-declaration names-list) - (unless (symbolp new-declaration) - (cmperr "The declaration ~s is not a symbol" new-declaration)) - (when (type-name-p new-declaration) - (cmperr "Symbol name ~S cannot be both the name of a type and of a declaration" - new-declaration)) - (pushnew new-declaration si:*alien-declarations*))) - -(defun proclaim-var (type vl) - (setq type (type-filter type)) - (dolist (var vl) - (if (symbolp var) - (let ((type1 (get-sysprop var 'CMP-TYPE)) - (v (sch-global var))) - (setq type1 (if type1 (type-and type1 type) type)) - (when v (setq type1 (type-and type1 (var-type v)))) - (unless type1 - (warn - "Inconsistent type declaration was found for the variable ~s." - var) - (setq type1 T)) - (put-sysprop var 'CMP-TYPE type1) - (when v (setf (var-type v) type1))) - (warn "The variable name ~s is not a symbol." var)))) - -(defun parse-ignore-declaration (decl-args expected-ref-number) - (loop with output = '() - for name in decl-args - do (cond ((symbolp name) - (push (cons name expected-ref-number) output)) - (t - (cmpassert (and (consp name) - (= (length name) 2) - (eq (first name) 'function)) - "Invalid argument to IGNORE/IGNORABLE declaration:~&~A" - name))) - finally (return output))) - -(defun c1body (body doc-p &aux - (all-declarations nil) - (ss nil) ; special vars - (is nil) ; ignored vars - (ts nil) ; typed vars (var . type) - (others nil) ; all other vars - doc form) - (loop - (when (endp body) (return)) - (setq form (cmp-macroexpand (car body))) - (cond - ((stringp form) - (when (or (null doc-p) (endp (cdr body)) doc) (return)) - (setq doc form)) - ((and (consp form) (eq (car form) 'DECLARE)) - (push form all-declarations) - (dolist (decl (cdr form)) - (cmpassert (and (proper-list-p decl) (symbolp (first decl))) - "Syntax error in declaration ~s" form) - (let* ((decl-name (first decl)) - (decl-args (rest decl))) - (flet ((declare-variables (type var-list) - (cmpassert (proper-list-p var-list #'symbolp) - "Syntax error in declaration ~s" decl) - (when type - (dolist (var var-list) - (push (cons var type) ts))))) - (case decl-name - (SPECIAL - (cmpassert (proper-list-p decl-args #'symbolp) - "Syntax error in declaration ~s" decl) - (setf ss (append decl-args ss))) - (IGNORE - (setf is (nconc (parse-ignore-declaration decl-args -1) - is))) - (IGNORABLE - (setf is (nconc (parse-ignore-declaration decl-args 0) - is))) - (TYPE - (cmpassert decl-args "Syntax error in declaration ~s" decl) - (declare-variables (first decl-args) (rest decl-args))) - (OBJECT - (declare-variables 'OBJECT decl-args)) - ;; read-only variable treatment. obsolete! - (:READ-ONLY - (push decl others)) - ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL - DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE - POLICY-DEBUG-IHS-FRAME) - (push decl others)) - (otherwise - (if (member decl-name si::*alien-declarations*) - (push decl others) - (multiple-value-bind (ok type) - (valid-type-specifier decl-name) - (cmpassert ok "The declaration specifier ~s is unknown." decl-name) - (declare-variables type decl-args)))) - ))))) - (t (return))) - (pop body) - ) - (values body ss ts is others doc all-declarations) - ) - -(defun default-optimization (optimization) - (ecase optimization - (speed *speed*) - (safety *safety*) - (space *space*) - (debug *debug*))) - -(defun search-optimization-quality (declarations what) - (dolist (i (reverse declarations) - (default-optimization what)) - (when (and (consp i) (eq (first i) 'policy-debug-ihs-frame) - (eq what 'debug)) - (return 2)) - (when (and (consp i) (eq (first i) 'optimize)) - (dolist (j (rest i)) - (cond ((consp j) - (when (eq (first j) what) - (return-from search-optimization-quality (second j)))) - ((eq j what) - (return-from search-optimization-quality 3))))))) - -(defun c1add-declarations (decls &aux (dl nil) (optimizations)) - (dolist (decl decls) - (case (car decl) - (OPTIMIZE - (push decl dl) - (dolist (x (cdr decl)) - (when (symbolp x) (setq x (list x 3))) - (unless optimizations - (setq optimizations (cmp-env-all-optimizations))) - (if (or (not (consp x)) - (not (consp (cdr x))) - (not (numberp (second x))) - (not (<= 0 (second x) 3))) - (cmpwarn "The OPTIMIZE proclamation ~s is illegal." x) - (let ((value (second x))) - (case (car x) - (DEBUG (setf (first optimizations) value)) - (SAFETY (setf (second optimizations) value)) - (SPACE (setf (third optimizations) value)) - (SPEED (setf (fourth optimizations) value)) - (COMPILATION-SPEED) - (t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x)))))))) - (POLICY-DEBUG-IHS-FRAME - (unless optimizations - (setq optimizations (cmp-env-all-optimizations))) - (setf (first optimizations) (max 2 (first optimizations)))) - (FTYPE - (if (atom (rest decl)) - (cmpwarn "Syntax error in declaration ~a" decl) - (multiple-value-bind (type-name args) - (si::normalize-type (second decl)) - (if (eq type-name 'FUNCTION) - (dolist (v (cddr decl)) - (add-function-declaration v (first args) (rest args))) - (cmpwarn "In an FTYPE declaration, found ~A which is not a function type." - (second decl)))))) - (INLINE - (push decl dl) - (dolist (fun (cdr decl)) - (if (si::valid-function-name-p fun) - (setq *notinline* (remove fun *notinline*)) - (cmperr "Not a valid function name ~s in declaration ~s" fun decl)))) - (NOTINLINE - (push decl dl) - (dolist (fun (cdr decl)) - (if (si::valid-function-name-p fun) - (push fun *notinline*) - (cmperr "Not a valid function name ~s in declaration ~s" fun decl)))) - (DECLARATION - (do-declaration (rest decl) #'cmperr)) - ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE)) - ((DYNAMIC-EXTENT IGNORABLE) - ;; FIXME! SOME ARE IGNORED! - ) - (:READ-ONLY) - (otherwise - (unless (member (car decl) si:*alien-declarations*) - (cmpwarn "The declaration specifier ~s is unknown." (car decl)))))) - (when optimizations - (setf *cmp-env* - (cons (cons `(:declare optimize ,@optimizations) - (car *cmp-env*)) - (cdr *cmp-env*)))) - dl) - -(defun c1decl-body (decls body) - (if (null decls) - (c1progn body) - (let* ((*function-declarations* *function-declarations*) - (si:*alien-declarations* si:*alien-declarations*) - (*notinline* *notinline*) - (*cmp-env* *cmp-env*) - (dl (c1add-declarations decls))) - (setq body (c1progn body)) - (make-c1form 'DECL-BODY body dl body)))) - -(put-sysprop 'decl-body 'c2 'c2decl-body) - -(defun c2decl-body (decls body) - (let ((*cmp-env* *cmp-env*) - (*notinline* *notinline*)) - (c1add-declarations decls) - (c2expr body))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; COMPILER ENVIRONMENT -;;; - -(defmacro cmp-env-new () - '(cons nil nil)) - -(defun cmp-env-copy (&optional (env *cmp-env*)) - (cons (car env) (cdr env))) - -(defmacro cmp-env-variables (&optional (env '*cmp-env*)) - `(car ,env)) - -(defmacro cmp-env-functions (&optional (env '*cmp-env*)) - `(cdr ,env)) - -(defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t)) - (push (list (var-name var) - (if (member (var-kind var) '(special global)) - :special - t) - boundp - var) - (cmp-env-variables))) - -(defun cmp-env-declare-special (name &optional (env *cmp-env*)) - (cmp-env-register-var (c1make-global-variable name :warn nil :kind 'SPECIAL) - env nil)) - -(defun cmp-env-register-function (fun &optional (env *cmp-env*)) - (push (list (fun-name fun) 'function fun) - (cmp-env-functions env))) - -(defun cmp-env-register-macro (name function &optional (env *cmp-env*)) - (push (list name 'si::macro function) - (cmp-env-functions env))) - -(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*)) - (push (list name 'si::symbol-macro #'(lambda (whole env) form)) - (cmp-env-variables env))) - -(defun cmp-env-register-block (blk &optional (env *cmp-env*)) - (push (list :block (blk-name blk) blk) - (cmp-env-variables env))) - -(defun cmp-env-register-tag (tag &optional (env *cmp-env*)) - (push (list :tag (list (tag-name tag)) tag) - (cmp-env-variables env))) - -(defun cmp-env-search-function (name &optional (env *cmp-env*)) - (let ((ccb nil) - (clb nil) - (unw nil) - (found nil)) - (dolist (record (cmp-env-functions env)) - (cond ((eq record 'CB) - (setf ccb t)) - ((eq record 'LB) - (setf clb t)) - ((eq record 'UNWIND-PROTECT) - (setf unw t)) - ((atom record) - (baboon)) - ;; We have to use EQUAL because the name can be a list (SETF whatever) - ((equal (first record) name) - (setf found (first (last record))) - (return)))) - (values found ccb clb unw))) - -(defun cmp-env-search-variables (type name env) - (let ((ccb nil) - (clb nil) - (unw nil) - (found nil)) - (dolist (record (cmp-env-variables env)) - (cond ((eq record 'CB) - (setf ccb t)) - ((eq record 'LB) - (setf clb t)) - ((eq record 'UNWIND-PROTECT) - (setf unw t)) - ((atom record) - (baboon)) - ((not (eq (first record) type))) - ((eq type :block) - (when (eq name (second record)) - (setf found record) - (return))) - ((eq type :tag) - (when (member name (second record) :test #'eql) - (setf found record) - (return))) - ((eq name 'si::symbol-macro) - (when (eq (second record) 'si::symbol-macro) - (setf found record)) - (return)) - (t - (setf found record) - (return)))) - (values (first (last found)) ccb clb unw))) - -(defun cmp-env-search-block (name &optional (env *cmp-env*)) - (cmp-env-search-variables :block name env)) - -(defun cmp-env-search-tag (name &optional (env *cmp-env*)) - (cmp-env-search-variables :tag name env)) - -(defun cmp-env-search-symbol-macro (name &optional (env *cmp-env*)) - (cmp-env-search-variables name 'si::symbol-macro env)) - -(defun cmp-env-search-var (name &optional (env *cmp-env*)) - (cmp-env-search-variables name t env)) - -(defun cmp-env-search-macro (name &optional (env *cmp-env*)) - (let ((f (cmp-env-search-function name env))) - (if (functionp f) f nil))) - -(defun cmp-env-mark (mark &optional (env *cmp-env*)) - (cons (cons mark (car env)) - (cons mark (cdr env)))) - -(defun cmp-env-new-variables (new-env old-env) - (loop for i in (ldiff (cmp-env-variables *cmp-env*) - (cmp-env-variables old-env)) - when (and (consp i) (var-p (fourth i))) - collect (fourth i))) - -(defun symbol-macro-declaration-p (name type) - (let* ((record (cmp-env-search-variables name 'si::symbol-macro *cmp-env*))) - (when (and record (functionp record)) - (let* ((expression (funcall record name nil))) - (cmp-env-register-symbol-macro name `(the ,type ,expression))) - t))) - -(defun check-vdecl (vnames ts is) - (loop for (var . type) in ts - unless (or (member var vnames :test #'eq) - (symbol-macro-declaration-p var type)) - do (cmpwarn "Declaration of type~&~4T~A~&was found for not bound variable ~s." - type var)) - (loop for (var . expected-uses) in is - unless (member var vnames :test #'eq) - do (cmpwarn (if (minusp expected-uses) - "IGNORE declaration was found for not bound variable ~s." - "IGNORABLE declaration was found for not bound variable ~s.") - var))) - -(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) - (loop for i in (car env) - when (and (consp i) - (eq (first i) :declare) - (eq (second i) 'optimize)) - do (return (cddr i)) - finally (return (list *debug* *safety* *space* *speed*)))) - -(defun cmp-env-optimization (property &optional (env *cmp-env*)) - (let ((x (cmp-env-all-optimizations env))) - (case property - (debug (first x)) - (safety (second x)) - (space (third x)) - (speed (fourth x))))) - -(defun policy-assume-right-type (&optional (env *cmp-env*)) - (< (cmp-env-optimization 'safety env) 2)) - -(defun policy-check-stack-overflow (&optional (env *cmp-env*)) - "Do we add a stack check to every function?" - (>= (cmp-env-optimization 'safety env) 2)) - -(defun policy-inline-slot-access-p (&optional (env *cmp-env*)) - "Do we inline access to structures and sealed classes?" - (or (< (cmp-env-optimization 'safety env) 2) - (<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env)))) - -(defun policy-check-all-arguments-p (&optional (env *cmp-env*)) - "Do we assume that arguments are the right type?" - (> (cmp-env-optimization 'safety env) 1)) - -(defun policy-automatic-check-type-p (&optional (env *cmp-env*)) - "Do we generate CHECK-TYPE forms for function arguments with type declarations?" - (and *automatic-check-type-in-lambda* - (>= (cmp-env-optimization 'safety env) 1))) - -(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*)) - "Do we assume that type and class definitions will not change?" - (<= (cmp-env-optimization 'safety env) 1)) - -(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*)) - "Do we inline access to arrays?" - (< (cmp-env-optimization 'safety env) 2)) - -(defun policy-array-bounds-check-p (&optional (env *cmp-env*)) - "Check access to array bounds?" - (>= (cmp-env-optimization 'safety env) 1)) - -(defun policy-debug-ihs-frame (&optional (env *cmp-env*)) - "Shall we create an IHS frame so that this function shows up in backtraces?" - ;; Note that this is a prerequisite for registering variable bindings. Hence, - ;; it has to be recorded in a special variable. - (>= (fun-debug *current-function*) 2)) \ No newline at end of file diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index 003aa1a99..4cabbc3c2 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -103,7 +103,7 @@ |# (t (let* ((forms (c1args* args)) - (return-type (propagate-types fname forms args))) + (return-type (propagate-types fname forms))) (make-c1form* 'CALL-GLOBAL :sp-change (function-may-change-sp fname) :type return-type @@ -117,6 +117,7 @@ (*current-toplevel-form* (c1form-toplevel-form form)) (*current-form* (c1form-form form)) (*current-c2form* form) + (*cmp-env* (c1form-env form)) (name (c1form-name form)) (args (c1form-args form)) (dispatch (get-sysprop name 'C2))) @@ -197,4 +198,5 @@ (put-sysprop 'PROGN 'C1SPECIAL 'c1progn) (put-sysprop 'PROGN 'C2 'c2progn) -(put-sysprop 'EXT:WITH-BACKEND 'C1SPECIAL 'c1with-backend) \ No newline at end of file +(put-sysprop 'EXT:WITH-BACKEND 'C1SPECIAL 'c1with-backend) +(put-sysprop 'EXT:WITH-BACKEND 'T1 'c1with-backend) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index 4b54c0d85..3064cb5dd 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -200,17 +200,26 @@ (c2expr body) (when block-p (wt-nl "}"))) +(defun c1decl-body (decls body) + (if (null decls) + (c1progn body) + (let* ((*cmp-env* (reduce #'add-one-declaration decls + :initial-value (cmp-env-copy *cmp-env*)))) + (c1progn body)))) + (defun c1locally (args) (multiple-value-bind (body ss ts is other-decl) (c1body args t) - (c1declare-specials ss) - (check-vdecl nil ts is) - (c1decl-body other-decl body))) + (if (or ss ts is other-decl) + (let ((*cmp-env* (cmp-env-copy))) + (c1declare-specials ss) + (check-vdecl nil ts is) + (c1decl-body other-decl body)) + (c1progn body)))) (defun c1macrolet (args) (check-args-number 'MACROLET args 1) - (let ((*cmp-env* (cmp-env-copy))) - (cmp-env-register-macrolet (first args) *cmp-env*) + (let ((*cmp-env* (cmp-env-register-macrolet (first args) (cmp-env-copy)))) (c1locally (cdr args)))) (defun c1symbol-macrolet (args) diff --git a/src/cmp/cmpform.lsp b/src/cmp/cmpform.lsp new file mode 100644 index 000000000..12c2971b5 --- /dev/null +++ b/src/cmp/cmpform.lsp @@ -0,0 +1,89 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPFORM -- Internal representation of Lisp forms +;;;; + +(in-package "COMPILER") + +(defun print-c1form (form stream) + (format stream "#
" (c1form-name form) (ext::pointer form))) + +(defun make-c1form (name subform &rest args) + (let ((form (do-make-c1form :name name :args args + :type (info-type subform) + :sp-change (info-sp-change subform) + :volatile (info-volatile subform) + :form *current-form* + :toplevel-form *current-toplevel-form* + :file *compile-file-truename* + :file-position *compile-file-position*))) + (c1form-add-info form args) + form)) + +(defun make-c1form* (name &rest args) + (let ((info-args '()) + (form-args '())) + (do ((l args (cdr l))) + ((endp l)) + (let ((key (first l))) + (cond ((not (keywordp key)) + (baboon)) + ((eq key ':args) + (setf form-args (rest l)) + (return)) + (t + (setf info-args (list* key (second l) info-args) + l (cdr l)))))) + (let ((form (apply #'do-make-c1form :name name :args form-args + :form *current-form* + :toplevel-form *current-toplevel-form* + :file *compile-file-truename* + :file-position *compile-file-position* + info-args))) + (c1form-add-info form form-args) + form))) + +(defun c1form-add-info (form dependents) + (dolist (subform dependents form) + (cond ((c1form-p subform) + (when (info-sp-change subform) + (setf (info-sp-change form) t)) + (setf (c1form-parent subform) form)) + ((consp subform) + (c1form-add-info form subform))))) + +(defun copy-c1form (form) + (copy-structure form)) + +(defmacro c1form-arg (nth form) + (case nth + (0 `(first (c1form-args ,form))) + (1 `(second (c1form-args ,form))) + (otherwise `(nth ,nth (c1form-args ,form))))) + +(defun c1form-volatile* (form) + (if (c1form-volatile form) "volatile " "")) + +(defun c1form-primary-type (form) + (values-type-primary-type (c1form-type form))) + +#-new-cmp +(defun location-primary-type (form) + (c1form-primary-type form)) + +(defun find-node-in-list (home-node list) + (flet ((parent-node-p (node presumed-child) + (loop + (cond ((null presumed-child) (return nil)) + ((eq node presumed-child) (return t)) + (t (setf presumed-child (c1form-parent presumed-child))))))) + (member home-node list :test #'parent-node-p))) diff --git a/src/new-cmp/cmpglobals.lsp b/src/cmp/cmpglobals.lsp similarity index 81% rename from src/new-cmp/cmpglobals.lsp rename to src/cmp/cmpglobals.lsp index 630be3177..0ab055862 100644 --- a/src/new-cmp/cmpglobals.lsp +++ b/src/cmp/cmpglobals.lsp @@ -1,7 +1,6 @@ ;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- ;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. -;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Library General Public @@ -10,10 +9,10 @@ ;;;; ;;;; See file '../Copyright' for full details. ;;;; -;;;; CMPVARS -- Global variables and flag definitions +;;;; CMPGLOBALS -- Global variables and flag definitions ;;;; -(in-package "C-DATA") +(in-package #-new-cmp "COMPILER" #+new-cmp "C-DATA") ;;; ;;; VARIABLES @@ -23,11 +22,9 @@ ;;; ;;; Empty info struct ;;; -(defvar *inline-functions* nil) +#-new-cmp +(defvar *info* (make-info)) (defvar *inline-blocks* 0) -;;; *inline-functions* holds: -;;; (...( function-name . inline-info )...) -;;; ;;; *inline-blocks* holds the number of C blocks opened for declaring ;;; temporaries for intermediate results of the evaluation of inlined ;;; function calls. @@ -36,8 +33,8 @@ ;;; ;;; Variables and constants for error handling ;;; -(defvar *current-toplevel-form* '|compiler preprocess|) (defvar *current-form* '|compiler preprocess|) +(defvar *current-toplevel-form* '|compiler preprocess|) (defvar *current-c2form* nil) (defvar *compile-file-position* -1) (defvar *first-error* t) @@ -58,7 +55,7 @@ each form it processes. The default value is NIL.") "This variable controls whether the compiler should display messages about its progress. The default value is T.") -(defvar *suppress-compiler-messages* nil +(defvar *suppress-compiler-messages* 'compiler-debug-note "A type denoting which compiler messages and conditions are _not_ displayed.") (defvar *suppress-compiler-notes* nil) ; Deprecated @@ -70,7 +67,6 @@ progress. The default value is T.") (defvar *compiler-input*) (defvar *compiler-output1*) (defvar *compiler-output2*) -(defvar *dump-output*) ;;; --cmpcbk.lsp-- ;;; @@ -106,6 +102,11 @@ progress. The default value is T.") (defvar *lcl* 0) ; number of local variables +#-new-cmp +(defvar *temp* 0) ; number of temporary variables +#-new-cmp +(defvar *max-temp* 0) ; maximum *temp* reached + (defvar *level* 0) ; nesting level for local functions (defvar *lex* 0) ; number of lexical variables in local functions @@ -114,7 +115,13 @@ progress. The default value is T.") (defvar *env* 0) ; number of variables in current form (defvar *max-env* 0) ; maximum *env* in whole function (defvar *env-lvl* 0) ; number of levels of environments +#-new-cmp +(defvar *aux-closure* nil) ; stack allocated closure needed for indirect calls +#-new-cmp +(defvar *ihs-used-p* nil) ; function must be registered in IHS? +#-new-cmp +(defvar *next-cmacro* 0) ; holds the last cmacro number used. (defvar *next-cfun* 0) ; holds the last cfun used. ;;; @@ -126,7 +133,6 @@ progress. The default value is T.") (defvar *tail-recursion-info* nil) (defvar *allow-c-local-declaration* t) -(defvar *notinline* nil) ;;; --cmpexit.lsp-- ;;; @@ -146,7 +152,7 @@ progress. The default value is T.") (defvar *current-function* nil) -(defvar *cmp-env* (cons nil nil) +(defvar *cmp-env* nil "The compiler environment consists of a pair or cons of two lists, one containing variable records, the other one macro and function recors: @@ -172,6 +178,11 @@ boundaries. Note that compared with the bytecodes compiler, these records contain an additional variable, block, tag or function object at the end.") +(defvar *cmp-env-root* (cons nil nil) +"This is the common environment shared by all toplevel forms. It can +only be altered by DECLAIM forms and it is used to initialize the +value of *CMP-ENV*.") + ;;; --cmplog.lsp-- ;;; ;;; Destination of output of different forms. See cmploc.lsp for types @@ -187,6 +198,20 @@ object at the end.") (defvar *delete-files* t) (defvar *files-to-be-deleted* '()) +(defvar *user-ld-flags* '() +"Flags and options to be passed to the linker when building FASL, shared libraries +and standalone programs. It is not required to surround values with quotes or use +slashes before special characters.") + +(defvar *user-cc-flags* '() +"Flags and options to be passed to the C compiler when building FASL, shared libraries +and standalone programs. It is not required to surround values with quotes or use +slashes before special characters.") + +;;; +;;; Compiler program and flags. +;;; + ;;; --cmptop.lsp-- ;;; (defvar *do-type-propagation* nil @@ -195,16 +220,21 @@ object at the end.") (defvar *compiler-phase* nil) (defvar *volatile*) +#-new-cmp +(defvar *setjmps* 0) (defvar *compile-toplevel* T "Holds NIL or T depending on whether we are compiling a toplevel form.") -(defvar *compile-time-too* nil) (defvar *clines-string-list* '() "List of strings containing C/C++ statements which are directly inserted in the translated C/C++ file. Notice that it is unspecified where these lines are inserted, but the order is preserved") +(defvar *compile-time-too* nil) +#-new-cmp +(defvar *not-compile-time* nil) + (defvar *permanent-data* nil) ; detemines whether we use *permanent-objects* ; or *temporary-objects* (defvar *permanent-objects* nil) ; holds { ( object (VV vv-index) ) }* @@ -214,8 +244,10 @@ lines are inserted, but the order is preserved") ;;; where each vv-index should be given an object before ;;; defining the current function during loading process. -(defvar *use-static-constants-p* t) ; T/NIL flag to determine whether one may +(defvar *use-static-constants-p* nil) ; T/NIL flag to determine whether one may ; generate lisp constant values as C structs +(defvar *static-constants* nil) ; constants that can be built as C values + ; holds { ( object c-variable constant ) }* (defvar *compiler-constants* nil) ; a vector with all constants ; only used in COMPILE @@ -232,7 +264,6 @@ lines are inserted, but the order is preserved") (defvar *local-funs* nil) ; holds { fun }* (defvar *top-level-forms* nil) ; holds { top-level-form }* (defvar *make-forms* nil) ; holds { top-level-form }* -(defvar +init-function-name+ (gensym "ENTRY-POINT")) ;;; ;;; top-level-form: @@ -244,11 +275,16 @@ lines are inserted, but the order is preserved") ;;; | ( 'CLINES' string* ) ;;; | ( 'LOAD-TIME-VALUE' vv ) +#-new-cmp +(defvar *reservations* nil) (defvar *reservation-cmacro* nil) ;;; *reservations* holds (... ( cmacro . value ) ...). ;;; *reservation-cmacro* holds the cmacro current used as vs reservation. +;;; *global-entries* holds (... ( fname cfun return-types arg-type ) ...). +(defvar *global-entries* nil) + (defvar *self-destructing-fasl* '() "A value T means that, when a FASL module is being unloaded (for instance during garbage collection), the associated file will be @@ -266,8 +302,15 @@ be deleted if they have been opened with LoadLibrary.") (*compiler-in-use* t) (*compiler-phase* 't1) (*callbacks* nil) + (*cmp-env-root* (cmp-env-copy *cmp-env-root*)) + (*cmp-env* nil) + #-new-cmp + (*max-temp* 0) + #-new-cmp + (*temp* 0) + #-new-cmp + (*next-cmacro* 0) (*next-cfun* 0) - (*lcl* 0) (*last-label* 0) (*load-objects* (make-hash-table :size 128 :test #'equal)) (*make-forms* nil) @@ -282,16 +325,24 @@ be deleted if they have been opened with LoadLibrary.") (*linking-calls* nil) (*global-entries* nil) (*undefined-vars* nil) + #-new-cmp + (*reservations* nil) (*top-level-forms* nil) + (*compile-time-too* nil) (*clines-string-list* '()) - (*inline-functions* nil) (*inline-blocks* 0) (*debugger-hook* 'compiler-debugger) + #+new-cmp (*type-and-cache* (type-and-empty-cache)) + #+new-cmp (*type-or-cache* (type-or-empty-cache)) + #+new-cmp (*values-type-or-cache* (values-type-or-empty-cache)) + #+new-cmp (*values-type-and-cache* (values-type-and-empty-cache)) + #+new-cmp (*values-type-primary-type-cache* (values-type-primary-type-empty-cache)) + #+new-cmp (*values-type-to-n-types-cache* (values-type-to-n-types-empty-cache)) )) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 35a38ddc8..5cc3cca28 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -195,10 +195,6 @@ (defun get-inline-info (fname types return-type return-rep-type) (declare (si::c-local)) (let ((output nil)) - (dolist (x *inline-functions*) - (when (eq (car x) fname) - (let ((other (inline-type-matches (cdr x) types return-type))) - (setf output (choose-inline-info output other return-type return-rep-type))))) (unless (safe-compile) (dolist (x (get-sysprop fname ':INLINE-UNSAFE)) (let ((other (inline-type-matches x types return-type))) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 4aecf012c..ded28c90c 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -82,7 +82,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (when *current-function* (push fun (fun-child-funs *current-function*))) (let* ((*current-function* fun) - (*cmp-env* (cmp-env-mark CB/LB)) + (*cmp-env* (setf (fun-cmp-env fun) (cmp-env-mark CB/LB))) (setjmps *setjmps*) (decl (si::process-declarations (rest lambda-list-and-body))) (lambda-expr (c1lambda-expr lambda-list-and-body @@ -92,9 +92,9 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (debug (search-optimization-quality decl 'debug)) (no-entry (assoc 'SI::C-LOCAL decl)) cfun exported minarg maxarg) - (when (and no-entry (>= debug 2)) + (when (and no-entry (policy-debug-ihs-frame)) (setf no-entry nil) - (cmpnote "Ignoring SI::C-LOCAL declaration for ~A when DEBUG is ~D" name debug)) + (cmpnote "Ignoring SI::C-LOCAL declaration for~%~4I~A~%because the debug level is large" name)) (unless (eql setjmps *setjmps*) (setf (c1form-volatile lambda-expr) t)) (setf (fun-lambda fun) lambda-expr) @@ -122,8 +122,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (fun-minarg fun) minarg (fun-maxarg fun) maxarg (fun-description fun) name - (fun-no-entry fun) no-entry - (fun-debug fun) debug) + (fun-no-entry fun) no-entry) (reduce #'add-referred-variables-to-function (mapcar #'fun-referred-vars children) :initial-value fun) @@ -316,7 +315,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." |# (defun c2lambda-expr - (lambda-list body cfun fname use-narg fname-in-ihs-p + (lambda-list body cfun fname use-narg &optional closure-type local-entry-p &aux (requireds (first lambda-list)) (optionals (second lambda-list)) @@ -327,6 +326,9 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (nopt (/ (length optionals) 3)) (nkey (/ (length keywords) 4)) (varargs (or optionals rest keywords allow-other-keys)) + (fname-in-ihs-p (or (policy-debug-variable-bindings) + (and (policy-debug-ihs-frame) + fname))) simple-varargs (*permanent-data* t) (*unwind-exit* *unwind-exit*) @@ -433,14 +435,12 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts." (when fname-in-ihs-p (wt-nl "{") + (setf *ihs-used-p* t) (push 'IHS *unwind-exit*) - (cond ((>= *debug-fun* 3) - (build-debug-lexical-env (reverse requireds) t) - (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname) - ",_ecl_debug_env);")) - (t - (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname) - ",Cnil);")))) + (when (policy-debug-variable-bindings) + (build-debug-lexical-env (reverse requireds) t)) + (wt-nl "ecl_ihs_push(cl_env_copy,&ihs," (add-symbol fname) + ",_ecl_debug_env);")) (setq *lcl* lcl)) diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index 211ddf4d1..8e11efe9d 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -232,15 +232,15 @@ (dolist (binding (nreverse bindings)) (bind (cdr binding) (car binding))) - (if (and *debug-fun* (>= *debug-fun* 3)) - (let ((*unwind-exit* *unwind-exit*)) - (wt-nl "{") - (let* ((env (build-debug-lexical-env vars))) - (when env (push 'IHS-ENV *unwind-exit*)) - (c2expr body) - (wt-nl "}") - (when env (pop-debug-lexical-env)))) - (c2expr body)) + (if (policy-debug-variable-bindings) + (let ((*unwind-exit* *unwind-exit*)) + (wt-nl "{") + (let* ((env (build-debug-lexical-env vars))) + (when env (push 'IHS-ENV *unwind-exit*)) + (c2expr body) + (wt-nl "}") + (when env (pop-debug-lexical-env)))) + (c2expr body)) (when block-p (wt-nl "}")) ) @@ -452,15 +452,15 @@ (c2expr* form))) ) ) - (if (and *debug-fun* (>= *debug-fun* 3)) - (let ((*unwind-exit* *unwind-exit*)) - (wt-nl "{") - (let* ((env (build-debug-lexical-env vars))) - (when env (push 'IHS-ENV *unwind-exit*)) - (c2expr body) - (wt-nl "}") - (when env (pop-debug-lexical-env)))) - (c2expr body)) + (if (policy-debug-variable-bindings) + (let ((*unwind-exit* *unwind-exit*)) + (wt-nl "{") + (let* ((env (build-debug-lexical-env vars))) + (when env (push 'IHS-ENV *unwind-exit*)) + (c2expr body) + (wt-nl "}") + (when env (pop-debug-lexical-env)))) + (c2expr body)) (when block-p (wt-nl "}")) ) diff --git a/src/cmp/cmpmac.lsp b/src/cmp/cmpmac.lsp index d36f02926..68a910e85 100644 --- a/src/cmp/cmpmac.lsp +++ b/src/cmp/cmpmac.lsp @@ -3,8 +3,56 @@ ;;; ---------------------------------------------------------------------- ;;; Macros only used in the code of the compiler itself: +#-new-cmp (in-package "COMPILER") +#-new-cmp (import 'sys::arglist "COMPILER") +#+new-cmp +(in-package "C-DATA") + +;; ---------------------------------------------------------------------- +;; CACHED FUNCTIONS +;; +(defmacro defun-cached (name lambda-list test &body body) + (let* ((cache-name (intern (concatenate 'string "*" (string name) "-CACHE*") + (symbol-package name))) + (reset-name (intern (concatenate 'string (string name) "-EMPTY-CACHE") + (symbol-package name))) + (hash-function (case test + (EQ 'SI::HASH-EQ) + (EQL 'SI::HASH-EQL) + (EQUAL 'SI::HASH-EQUAL) + (t (setf test 'EQUALP) 'SI::HASH-EQUALP))) + (hash (gensym "HASH"))) + `(progn + (defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil)) + (defun ,reset-name () + (make-array 1024 :element-type t :adjustable nil)) + (defun ,name ,lambda-list + (flet ((,name ,lambda-list ,@body)) + (let* ((hash (logand (,hash-function ,@lambda-list) 1023)) + (elt (aref ,cache-name hash))) + (declare (type (integer 0 1023) hash) + (type (array t (*)) ,cache-name)) + (if (and elt ,@(loop for arg in lambda-list + collect `(,test (pop (the cons elt)) ,arg))) + (first (the cons elt)) + (let ((output (,name ,@lambda-list))) + (setf (aref ,cache-name hash) (list ,@lambda-list output)) + output)))))))) + +(defmacro defun-equal-cached (name lambda-list &body body) + `(defun-cached ,name ,lambda-list equal ,@body)) + +;;; ---------------------------------------------------------------------- +;;; CONVENIENCE FUNCTIONS / MACROS +;;; + +(defun-cached env-var-name (n) eql + (format nil "env~D" n)) + +(defun-cached lex-env-var-name (n) eql + (format nil "lex~D" n)) (defun same-fname-p (name1 name2) (equal name1 name2)) @@ -16,139 +64,22 @@ (defmacro next-label* () `(cons (incf *last-label*) t)) -(defmacro wt-go (label) - `(progn (rplacd ,label t) (wt "goto L" (car ,label) ";"))) +(defun next-lcl () (list 'LCL (incf *lcl*))) -;;; from cmplam.lsp -(defmacro ck-spec (condition) - `(unless ,condition - (cmperr "The parameter specification ~s is illegal." spec))) +(defun next-cfun (&optional (prefix "L~D~A") (lisp-name nil)) + (let ((code (incf *next-cfun*))) + (format nil prefix code (lisp-to-c-name lisp-name)))) -(defmacro ck-vl (condition) - `(unless ,condition - (cmperr "The lambda list ~s is illegal." vl))) +(defun next-temp () + (prog1 *temp* + (incf *temp*) + (setq *max-temp* (max *temp* *max-temp*)))) -;;; fromcmputil.sp -(defmacro cmpck (condition string &rest args) - `(if ,condition (cmperr ,string ,@args))) +(defun next-lex () + (prog1 (cons *level* *lex*) + (incf *lex*) + (setq *max-lex* (max *lex* *max-lex*)))) -(defmacro cmpassert (condition string &rest args) - `(unless ,condition (cmperr ,string ,@args))) - -;;; from cmpwt.lsp -(defmacro wt (&rest forms &aux (fl nil)) - (dolist (form forms `(progn ,@(nreverse (cons nil fl)))) - (if (stringp form) - (push `(princ ,form *compiler-output1*) fl) - (push `(wt1 ,form) fl)))) - -(defmacro wt-h (&rest forms &aux (fl nil)) - (dolist (form forms `(progn ,@(nreverse (cons nil fl)))) - (if (stringp form) - (push `(princ ,form *compiler-output2*) fl) - (push `(wt-h1 ,form) fl)))) - -(defmacro wt-nl-h (&rest forms) - `(progn (terpri *compiler-output2*) (wt-h ,@forms))) - -(defmacro princ-h (form) `(princ ,form *compiler-output2*)) - -(defmacro wt-nl (&rest forms) - `(wt #\Newline #\Tab ,@forms)) - -(defmacro wt-nl1 (&rest forms) - `(wt #\Newline ,@forms)) - -(defmacro safe-compile () - `(>= (cmp-env-optimization 'safety) 2)) - -(defmacro compiler-check-args () - `(>= (cmp-env-optimization 'safety) 1)) - -(defmacro compiler-push-events () - `(>= (cmp-env-optimization 'safety) 3)) - -;; ---------------------------------------------------------------------- -;; C1-FORMS -;; - -(defstruct (c1form (:include info) - (:print-object print-c1form) - (:constructor do-make-c1form)) - (name nil) - (parent nil) - (args '()) - (form nil) - (toplevel-form nil) - (file nil) - (file-position 0)) - -(defun print-c1form (form stream) - (format stream "#" (c1form-name form) (ext::pointer form))) - -(defun make-c1form (name subform &rest args) - (let ((form (do-make-c1form :name name :args args - :type (info-type subform) - :sp-change (info-sp-change subform) - :volatile (info-volatile subform) - :form *current-form* - :toplevel-form *current-toplevel-form* - :file *compile-file-truename* - :file-position *compile-file-position*))) - (c1form-add-info form args) - form)) - -(defun make-c1form* (name &rest args) - (let ((info-args '()) - (form-args '())) - (do ((l args (cdr l))) - ((endp l)) - (let ((key (first l))) - (cond ((not (keywordp key)) - (baboon)) - ((eq key ':args) - (setf form-args (rest l)) - (return)) - (t - (setf info-args (list* key (second l) info-args) - l (cdr l)))))) - (let ((form (apply #'do-make-c1form :name name :args form-args - :form *current-form* - :toplevel-form *current-toplevel-form* - :file *compile-file-truename* - :file-position *compile-file-position* - info-args))) - (c1form-add-info form form-args) - form))) - -(defun c1form-add-info (form dependents) - (dolist (subform dependents form) - (cond ((c1form-p subform) - (when (info-sp-change subform) - (setf (info-sp-change form) t)) - (setf (c1form-parent subform) form)) - ((consp subform) - (c1form-add-info form subform))))) - -(defun copy-c1form (form) - (copy-structure form)) - -(defmacro c1form-arg (nth form) - (case nth - (0 `(first (c1form-args ,form))) - (1 `(second (c1form-args ,form))) - (otherwise `(nth ,nth (c1form-args ,form))))) - -(defun c1form-volatile* (form) - (if (c1form-volatile form) "volatile " "")) - -(defun c1form-primary-type (form) - (values-type-primary-type (c1form-type form))) - -(defun find-node-in-list (home-node list) - (flet ((parent-node-p (node presumed-child) - (loop - (cond ((null presumed-child) (return nil)) - ((eq node presumed-child) (return t)) - (t (setf presumed-child (c1form-parent presumed-child))))))) - (member home-node list :test #'parent-node-p))) +(defun next-env () (prog1 *env* + (incf *env*) + (setq *max-env* (max *env* *max-env*)))) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 3ec9cf0a4..47969754c 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -238,9 +238,10 @@ (c2expr* form) (do-m-v-setq-any min-values max-values vars nil)))))) -(defun c1multiple-value-bind (args &aux (*cmp-env* (cmp-env-copy))) +(defun c1multiple-value-bind (args) (check-args-number 'MULTIPLE-VALUE-BIND args 2) - (let* ((variables (pop args)) + (let* ((*cmp-env* (cmp-env-copy)) + (variables (pop args)) (init-form (pop args))) (when (= (length variables) 1) (return-from c1multiple-value-bind diff --git a/src/cmp/cmpnum.lsp b/src/cmp/cmpnum.lsp index 66e5e44d6..bcb4b657e 100644 --- a/src/cmp/cmpnum.lsp +++ b/src/cmp/cmpnum.lsp @@ -38,8 +38,8 @@ (t (error 'simple-program-error :format-error "Wrong number of arguments for operator ~a in ~a" - :format-arguments (list operators (or whole - (list* operator args))))))))) + :format-arguments (list operator (or whole + (list* operator args))))))))) (define-compiler-macro * (&whole all &rest args) (simplify-arithmetic '* args all)) diff --git a/src/cmp/cmppackage.lsp b/src/cmp/cmppackage.lsp new file mode 100644 index 000000000..5cecc5bd7 --- /dev/null +++ b/src/cmp/cmppackage.lsp @@ -0,0 +1,51 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPPACKAGE -- Package definitions and exported symbols +;;;; + +(si::package-lock "CL" nil) + +(defpackage "C" + (:nicknames "COMPILER") + (:use "FFI" "CL" #+threads "MP") + (:export "*COMPILER-BREAK-ENABLE*" + "*COMPILE-PRINT*" + "*COMPILE-TO-LINKING-CALL*" + "*COMPILE-VERBOSE*" + "*CC*" + "*CC-OPTIMIZE*" + "*USER-CC-FLAGS*" + "*USER-LD-FLAGS*" + "*SUPPRESS-COMPILER-NOTES*" + "*SUPPRESS-COMPILER-WARNINGS*" + "*SUPPRESS-COMPILER-MESSAGES*" + "BUILD-ECL" + "BUILD-PROGRAM" + "BUILD-FASL" + "BUILD-STATIC-LIBRARY" + "BUILD-SHARED-LIBRARY" + "COMPILER-WARNING" + "COMPILER-NOTE" + "COMPILER-MESSAGE" + "COMPILER-ERROR" + "COMPILER-FATAL-ERROR" + "COMPILER-INTERNAL-ERROR" + "COMPILER-UNDEFINED-VARIABLE" + "COMPILER-MESSAGE-FILE" + "COMPILER-MESSAGE-FILE-POSITION" + "COMPILER-MESSAGE-FORM" + "*SUPPRESS-COMPILER-WARNINGS*" + "*SUPPRESS-COMPILER-NOTES*" + "*SUPPRESS-COMPILER-MESSAGES*") + (:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP" "MACRO" + "*COMPILER-CONSTANTS*" "REGISTER-GLOBAL" "CMP-ENV-REGISTER-MACROLET" + "COMPILER-LET")) diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp new file mode 100644 index 000000000..9863a666e --- /dev/null +++ b/src/cmp/cmppolicy.lsp @@ -0,0 +1,105 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPPOLICY -- Code generation choices +;;;; + +(in-package #-new-cmp "COMPILER" #+new-cmp "C-ENV") + +(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) + (or (cmp-env-search-declaration 'optimize) + (list *debug* *safety* *space* *speed*))) + +(defun cmp-env-optimization (property &optional (env *cmp-env*)) + (let ((x (cmp-env-all-optimizations env))) + (case property + (debug (first x)) + (safety (second x)) + (space (third x)) + (speed (fourth x))))) + +(defun policy-assume-right-type (&optional (env *cmp-env*)) + (< (cmp-env-optimization 'safety env) 2)) + +(defun policy-check-stack-overflow (&optional (env *cmp-env*)) + "Do we add a stack check to every function?" + (>= (cmp-env-optimization 'safety env) 2)) + +(defun policy-inline-slot-access-p (&optional (env *cmp-env*)) + "Do we inline access to structures and sealed classes?" + (or (< (cmp-env-optimization 'safety env) 2) + (<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env)))) + +(defun policy-check-all-arguments-p (&optional (env *cmp-env*)) + "Do we assume that arguments are the right type?" + (> (cmp-env-optimization 'safety env) 1)) + +(defun policy-automatic-check-type-p (&optional (env *cmp-env*)) + "Do we generate CHECK-TYPE forms for function arguments with type declarations?" + (and *automatic-check-type-in-lambda* + (>= (cmp-env-optimization 'safety env) 1))) + +(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*)) + "Do we assume that type and class definitions will not change?" + (<= (cmp-env-optimization 'safety env) 1)) + +(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*)) + "Do we inline access to arrays?" + (< (cmp-env-optimization 'debug env) 2)) + +(defun policy-open-code-accessors (&optional (env *cmp-env*)) + "Do we inline access to object slots, including conses and arrays?" + (< (cmp-env-optimization 'debug env) 2)) + +(defun policy-array-bounds-check-p (&optional (env *cmp-env*)) + "Check access to array bounds?" + (>= (cmp-env-optimization 'safety env) 1)) + +(defun policy-evaluate-forms (&optional (env *cmp-env*)) + "Pre-evaluate a function that takes constant arguments?" + (<= (cmp-env-optimization 'debug env) 1)) + +(defun policy-use-direct-C-call (&optional (env *cmp-env*)) + "Emit direct calls to a function whose C name is known" + (<= (cmp-env-optimization 'debug env) 1)) + +(defun policy-global-var-checking (&optional (env *cmp-env*)) + "Do we have to read the value of a global variable even if it is discarded? +Also, when reading the value of a global variable, should we ensure it is bound?" + (>= (cmp-env-optimization 'safety env) 1)) + +(defun policy-global-function-checking (&optional (env *cmp-env*)) + "Do we have to read the binding of a global function even if it is discarded?" + (>= (cmp-env-optimization 'safety env) 1)) + +(defun policy-debug-variable-bindings (&optional (env *cmp-env*)) + "Shall we create a vector with the bindings of each LET/LET*/LAMBDA form?" + ;; We can only create variable bindings when the function has an IHS frame!!! + (and (policy-debug-ihs-frame env) + (>= (cmp-env-optimization 'debug env) 3))) + +(defun policy-debug-ihs-frame (&optional (env *cmp-env*)) + "Shall we create an IHS frame so that this function shows up in backtraces?" + ;; Note that this is a prerequisite for registering variable bindings. + (or (>= (cmp-env-optimization 'debug env) 2) + (first (cmp-env-search-declaration 'policy-debug-ihs-frame)))) + +(defun policy-check-nargs (&optional (env *cmp-env*)) + (>= (cmp-env-optimization 'safety) 1)) + +(defun safe-compile () + (>= (cmp-env-optimization 'safety) 2)) + +(defun compiler-check-args () + (>= (cmp-env-optimization 'safety) 1)) + +(defun compiler-push-events () + (>= (cmp-env-optimization 'safety) 3)) diff --git a/src/cmp/cmpprop.lsp b/src/cmp/cmpprop.lsp index 2e82e8a6b..7a77e8866 100644 --- a/src/cmp/cmpprop.lsp +++ b/src/cmp/cmpprop.lsp @@ -215,7 +215,7 @@ of the occurrences in those lists." do (multiple-value-bind (arg-type local-ass) (p1propagate v assumptions) (setf assumptions local-ass)) - finally (let ((type (propagate-types fname args nil))) + finally (let ((type (propagate-types fname args))) (prop-message "~&;;; Computing output of function ~A with args~&;;; ~{ ~A~}~&;;; gives ~A, while before ~A" fname (mapcar #'c1form-type args) type (c1form-type c1form)) (return (values type assumptions))))) diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index 9dc90a2a8..8abe5843d 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -78,7 +78,7 @@ collect (if (consp x) x (let ((tag (make-tag :name x :var tag-var :index tag-index))) - (cmp-env-register-tag tag) + (cmp-env-register-tag (tag-name tag) tag) (incf tag-index) tag)))) ;; Split forms according to the tag they are preceded by and compile diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 4693c07c7..1a2e2c8f2 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -16,7 +16,7 @@ (defun t1expr (form) (let* ((*current-toplevel-form* nil) - (*cmp-env* (cmp-env-new))) + (*cmp-env* (cmp-env-copy (or *cmp-env* *cmp-env-root*)))) (push (t1expr* form) *top-level-forms*))) (defvar *toplevel-forms-to-print* @@ -67,8 +67,17 @@ (defun t2expr (form) (when form - (let ((def (get-sysprop (c1form-name form) 'T2))) - (when def (apply def (c1form-args form)))))) + (let* ((def (get-sysprop (c1form-name form) 'T2))) + (if def + (let ((*compile-file-truename* (c1form-file form)) + (*compile-file-position* (c1form-file-position form)) + (*current-toplevel-form* (c1form-form form)) + (*current-form* (c1form-form form)) + (*current-c2form* form) + (*cmp-env* (c1form-env form))) + (apply def (c1form-args form))) + (cmperr "Unhandled T2FORM found at the toplevel:~%~4I~A" + form))))) (defvar *emitted-local-funs* nil) @@ -280,7 +289,7 @@ (progv symbols values (c2expr body))) (defun t2progn (args) - (mapcar #'t2expr args)) + (mapc #'t2expr args)) (defun exported-fname (name) (let (cname) @@ -376,7 +385,10 @@ (wt-h "T" i) (unless (= (1+ i) *max-temp*) (wt-h ","))) (wt-h ";")) -; (wt-nl-h "#define VU" *reservation-cmacro*) + (when *ihs-used-p* + (wt-h " \\") + (wt-nl-h "struct ihs_frame ihs; \\") + (wt-nl-h "const cl_object _ecl_debug_env = Cnil;")) (wt-nl-h "#define VLEX" *reservation-cmacro*) ;; There should be no need to mark lex as volatile, since we ;; are going to pass pointers of this array around and the compiler @@ -509,12 +521,6 @@ (c2expr form) (wt-label *exit*))) -(defun t2decl-body (decls body) - (let ((*cmp-env* *cmp-env*) - (*notinline* *notinline*)) - (c1add-declarations decls) - (t2expr body))) - (defun parse-cvspecs (x &aux (cvspecs nil)) (dolist (cvs x (nreverse cvspecs)) (cond ((symbolp cvs) @@ -533,8 +539,6 @@ (t (cmperr "The C variable specification ~s is illegal." cvs)))) ) -(defvar *debug-fun* nil) - (defun locative-type-from-var-kind (kind) (cdr (assoc kind '((:object . "_ecl_object_loc") @@ -545,11 +549,6 @@ ((special global closure replaced lexical) . NIL))))) (defun build-debug-lexical-env (var-locations &optional first) - #+:msvc - (if first - (wt-nl "cl_object _ecl_debug_env = Cnil;") - (wt-nl "ihs.lex_env = _ecl_debug_env = Cnil;")) - #-:msvc ;; FIXME! Problem with initialization of statically defined vectors (let* ((filtered-locations '()) (filtered-codes '())) @@ -569,6 +568,7 @@ ;; variables, including name and type, and dynamic one, which is ;; a vector of pointer to the variables. (when filtered-codes + (setf *ihs-used-p* t) (wt-nl "static const struct ecl_var_debug_info _ecl_descriptors[]={") (loop for (name . code) in filtered-codes for i from 0 @@ -582,12 +582,9 @@ (wt "};") (wt-nl "ecl_def_ct_vector(_ecl_debug_env,aet_index,_ecl_debug_info_raw," (+ 2 (length filtered-locations)) - ",,);")) - (if first - (if (not filtered-codes) - (wt-nl "cl_object _ecl_debug_env = Cnil;")) - (if filtered-codes - (wt-nl "ihs.lex_env=_ecl_debug_env;"))) + ",,);") + (unless first + (wt-nl "ihs.lex_env=_ecl_debug_env;"))) filtered-codes)) (defun pop-debug-lexical-env () @@ -605,8 +602,7 @@ (*volatile* (c1form-volatile* lambda-expr)) (*tail-recursion-info* fun) (lambda-list (c1form-arg 0 lambda-expr)) - (requireds (car lambda-list)) - (*debug-fun* *debug-fun*)) + (requireds (car lambda-list))) (declare (fixnum level nenvs)) (print-emitting fun) (wt-comment-nl (cond ((fun-global fun) "function definition for ~a") @@ -652,8 +648,10 @@ (*level* level) (*exit* 'RETURN) (*unwind-exit* '(RETURN)) (*destination* 'RETURN) + (*ihs-used-p* nil) (*reservation-cmacro* (next-cmacro)) - (*inline-blocks* 1)) + (*inline-blocks* 1) + (*cmp-env* (cmp-env-copy (fun-cmp-env fun)))) (wt-nl1 "{") (wt " VT" *reservation-cmacro* " VLEX" *reservation-cmacro* @@ -663,9 +661,6 @@ (when (eq (fun-closure fun) 'CLOSURE) (wt "cl_object " *volatile* "env0 = cl_env_copy->function->cclosure.env;")) (wt-nl *volatile* "cl_object value0;") - (when (>= (fun-debug fun) 2) - (setq *debug-fun* (fun-debug fun)) - (wt-nl "struct ihs_frame ihs;")) (when (policy-check-stack-overflow) (wt-nl "ecl_cs_check(cl_env_copy,value0);")) (when (eq (fun-closure fun) 'CLOSURE) @@ -706,11 +701,11 @@ (c1form-arg 2 lambda-expr) (fun-cfun fun) (fun-name fun) narg - (>= (fun-debug fun) 2) (fun-closure fun)) (wt-nl1) (close-inline-blocks) - (wt-function-epilogue (fun-closure fun))) ; we should declare in CLSR only those used + ;; we should declare in CLSR only those used + (wt-function-epilogue (fun-closure fun))) ) ;;; ---------------------------------------------------------------------- @@ -819,7 +814,6 @@ ;;; Pass 2 initializers. (put-sysprop 'COMPILER-LET 'T2 't2compiler-let) -(put-sysprop 'DECL-BODY 't2 't2decl-body) (put-sysprop 'PROGN 'T2 't2progn) (put-sysprop 'ORDINARY 'T2 't2ordinary) (put-sysprop 'LOAD-TIME-VALUE 'T2 't2load-time-value) diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp new file mode 100644 index 000000000..19fac19ae --- /dev/null +++ b/src/cmp/cmptype-arith.lsp @@ -0,0 +1,329 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. +;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. + +;;;; CMPTYPE-ARITH -- Operations upon and among types + +(in-package #-new-cmp "COMPILER" #+new-cmp "C-TYPES") + +;;; CL-TYPE is any valid type specification of Common Lisp. +;;; +;;; TYPE is a representation type used by ECL. TYPE is one of: +;;; +;;; T(BOOLEAN) +;;; +;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT +;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM) +;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT) +;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT) +;;; (ARRAY FIXNUM) +;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) +;;; STANDARD-OBJECT STRUCTURE-OBJECT +;;; SYMBOL +;;; UNKNOWN +;;; +;;; NIL +;;; +;;; +;;; immediate-type: +;;; FIXNUM int +;;; CHARACTER char +;;; SINGLE-FLOAT float +;;; DOUBLE-FLOAT double + +(deftype any () 't) + +(defun member-type (type disjoint-supertypes) + (member type disjoint-supertypes :test #'subtypep)) + +;;; Check if THING is an object of the type TYPE. +;;; Depends on the implementation of TYPE-OF. +;;; (only used for saving constants?) +#-new-cmp +(defun object-type (thing) + (let ((type (if thing (type-of thing) 'SYMBOL))) + (case type + ((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL) type) + ((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER) + ((STRING BASE-STRING BIT-VECTOR) type) + (VECTOR (list 'VECTOR (array-element-type thing))) + (ARRAY (list 'ARRAY (array-element-type thing))) + #+clos + (STANDARD-OBJECT 'STANDARD-OBJECT) + #+clos + (STRUCTURE-OBJECT 'STRUCTURE-OBJECT) + (t t)))) + +(defun type-filter (type &optional values-allowed) + (multiple-value-bind (type-name type-args) (sys::normalize-type type) + (case type-name + ((FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT SYMBOL) type-name) + (SHORT-FLOAT #-short-float 'SINGLE-FLOAT #+short-float 'SHORT-FLOAT) + (LONG-FLOAT #-long-float 'DOUBLE-FLOAT #+long-float 'LONG-FLOAT) + ((SIMPLE-STRING STRING) 'STRING) + ((SIMPLE-BIT-VECTOR BIT-VECTOR) 'BIT-VECTOR) + ((NIL T) t) + ((SIMPLE-ARRAY ARRAY) + (cond ((endp type-args) '(ARRAY *)) ; Beppe + ((eq '* (car type-args)) t) + (t (let ((element-type (upgraded-array-element-type (car type-args))) + (dimensions (if (cdr type-args) (second type-args) '*))) + (if (and (not (eq dimensions '*)) + (or (numberp dimensions) + (= (length dimensions) 1))) + (case element-type + (BASE-CHAR 'STRING) + (BIT 'BIT-VECTOR) + (t (list 'VECTOR element-type))) + (list 'ARRAY element-type)))))) + (INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t)) + ((STREAM CONS) type-name) ; Juanjo + (FUNCTION type-name) + (t (cond ((eq type-name 'VALUES) + (unless values-allowed + (error "VALUES type found in a place where it is not allowed.")) + `(VALUES ,@(mapcar #'(lambda (x) + (if (or (eq x '&optional) + (eq x '&rest)) + x + (type-filter x))) + type-args))) + #+clos + ((subtypep type 'STANDARD-OBJECT) type) + #+clos + ((subtypep type 'STRUCTURE-OBJECT) type) + ((dolist (v '(FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT + #+short-float SHORT-FLOAT #+long-float LONG-FLOAT + (VECTOR T) STRING BIT-VECTOR + (VECTOR FIXNUM) (VECTOR SINGLE-FLOAT) + (VECTOR DOUBLE-FLOAT) (ARRAY BASE-CHAR) + (ARRAY BIT) (ARRAY FIXNUM) + (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) + (ARRAY T))) ; Beppe + (when (subtypep type v) (return v)))) + ((and (eq type-name 'SATISFIES) ; Beppe + (symbolp (car type-args)) + (sys:get-sysprop (car type-args) 'TYPE-FILTER))) + (t t)))))) + +(defun valid-type-specifier (type) + (handler-case + (if (subtypep type 'T) + (values t (type-filter type)) + (values nil nil)) + (error (c) (values nil nil)))) + +(defun known-type-p (type) + (subtypep type 'T)) + +(defun-equal-cached type-and (t1 t2) + ;; FIXME! Should we allow "*" as type name??? + (when (or (eq t1 t2) (eq t2 '*)) + (return-from type-and t1)) + (when (eq t1 '*) + (return-from type-and t2)) + (let* ((si::*highest-type-tag* si::*highest-type-tag*) + (si::*save-types-database* t) + (si::*member-types* si::*member-types*) + (si::*elementary-types* si::*elementary-types*) + (tag1 (si::safe-canonical-type t1)) + (tag2 (si::safe-canonical-type t2))) + (cond ((and (numberp tag1) (numberp tag2)) + (setf tag1 (si::safe-canonical-type t1) + tag2 (si::safe-canonical-type t2)) + (cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL + NIL) + ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 + t1) + ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 + t2) + (t + `(AND ,t1 ,t2)))) + ((eq tag1 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) + t2) + ((eq tag2 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) + t1) + ((null tag1) + (setf c::*compiler-break-enable* t) + ;(error "foo") + (cmpnote "Unknown type ~S. Assuming it is T." t1) + t2) + (t + (setf c::*compiler-break-enable* t) + ;(error "foo") + (cmpnote "Unknown type ~S. Assuming it is T." t2) + t1)))) + +(defun-equal-cached values-type-primary-type (type) + (when (and (consp type) (eq (first type) 'VALUES)) + (let ((subtype (second type))) + (when (or (eq subtype '&optional) (eq subtype '&rest)) + (setf type (cddr type)) + (when (or (null type) + (eq (setf subtype (first type)) '&optional) + (eq subtype '&rest)) + (cmperr "Syntax error in type expression ~S" type)) + ;; An &optional or &rest output value might be missing + ;; If this is the case, the the value will be NIL. + (setf subtype (type-or 'null subtype))) + (setf type subtype))) + type) + +(defun-equal-cached values-type-to-n-types (type length) + (if (or (atom type) (not (eql (first type) 'values))) + (list* type (make-list (1- length) :initial-element 'NULL)) + (do* ((l (rest type)) + (output '()) + (n length (1- n))) + ((or (null l) (zerop n)) (nreverse output)) + (let ((type (pop l))) + (case type + (&optional + (when (null l) + (cmperr "Syntax error in type expression ~S" type)) + (setf type (pop l))) + (&rest + (when (null l) + (cmperr "Syntax error in type expression ~S" type)) + (return-from values-type-to-n-types + (nreconc output (make-list n :initial-element (first l)))))) + (push type output))))) + +(defun split-values-type (type) + (if (or (atom type) (not (eq (first type) 'VALUES))) + (values (list type) nil nil) + (let ((rest (member '&rest type)) + (opt (member '&optional type))) + (values (ldiff (rest type) (or rest opt)) + (ldiff (rest (member '&optional type)) rest) + (rest (member '&rest type)))))) + +(defun-equal-cached values-type-or (t1 t2) + (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) + (return-from values-type-or t2)) + (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) + (return-from values-type-or t1)) + (unless t1 + (return-from values-type-or t2)) + (unless t2 + (return-from values-type-or t1)) + (multiple-value-bind (req1 opt1 rest1) + (split-values-type t1) + (multiple-value-bind (req2 opt2 rest2) + (split-values-type t2) + (let ((req '()) + (opt '()) + (rest '())) + (loop for t1 in req1 + do (cond (req2 + (push (type-or t1 (pop req2)) req)) + (opt2 + (push (type-or t1 (pop opt2)) opt)) + (rest2 + (push (type-or t1 (first rest2)) opt)) + (t + (push t1 opt)))) + (loop for t1 in opt1 + do (cond (req2 + (push (type-or t1 (pop req2)) opt)) + (opt2 + (push (type-or t1 (pop opt2)) opt)) + (rest2 + (push (type-or t1 (first rest2)) opt)) + (t + (push t1 opt)))) + (let ((t1 (if rest1 (first rest1) t))) + (loop for t2 in req2 + do (push (type-or t1 t2) opt)) + (loop for t2 in opt2 + do (push (type-or t1 t2) opt)) + (if rest2 + (setf rest (list (type-or t1 (first rest2)))) + (setf rest rest1))) + `(VALUES ,@(nreverse req) + ,@(and opt (cons '&optional (nreverse opt))) + ,@(and rest (cons '&optional rest))))))) + +(defun-equal-cached values-type-and (t1 t2) + (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) + (return-from values-type-and t1)) + (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) + (return-from values-type-and t2)) + (when (or (null t1) (null t2)) + (return-from values-type-and nil)) + (multiple-value-bind (req1 opt1 rest1) + (split-values-type t1) + (multiple-value-bind (req2 opt2 rest2) + (split-values-type t2) + (let ((req '()) + (opt '()) + (rest '())) + (loop for t1 in req1 + do (cond (req2 (push (type-and t1 (pop req2)) req)) + (opt2 (push (type-and t1 (pop opt2)) req)) + (rest2 (push (type-and t1 (first rest2)) req)) + (t (setf opt1 nil rest1 nil) (return)))) + (loop for t1 in opt1 + do (cond (req2 (push (type-and t1 (pop req2)) req)) + (opt2 (push (type-and t1 (pop opt2)) opt)) + (rest2 (push (type-and t1 (first rest2)) opt)) + (t (setf opt1 nil rest1 nil) (return)))) + (when rest + (let ((t1 (first rest))) + (loop for t2 in req2 + do (push (type-and t1 t2) req)) + (loop for t2 in opt2 + do (push (type-and t1 t2) opt)) + (when rest2 + (setf rest (list (type-and t1 (first rest2))))))) + `(VALUES ,@(nreverse req) + ,@(and opt (cons '&optional (nreverse opt))) + ,@(and rest (cons '&optional rest))))))) + +(defun-equal-cached type-or (t1 t2) + ;; FIXME! Should we allow "*" as type name??? + (when (or (eq t1 t2) (eq t2 '*)) + (return-from type-or t1)) + (when (eq t1 '*) + (return-from type-or t2)) + (let* ((si::*highest-type-tag* si::*highest-type-tag*) + (si::*save-types-database* t) + (si::*member-types* si::*member-types*) + (si::*elementary-types* si::*elementary-types*) + (tag1 (si::safe-canonical-type t1)) + (tag2 (si::safe-canonical-type t2))) + (cond ((and (numberp tag1) (numberp tag2)) + (setf tag1 (si::safe-canonical-type t1) + tag2 (si::safe-canonical-type t2)) + (cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 + t2) + ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 + t1) + (t + `(OR ,t1 ,t2)))) + ((eq tag1 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) + T) + ((eq tag2 'CONS) + (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) + T) + ((null tag1) + (cmpnote "Unknown type ~S" t1) + T) + (t + (cmpnote "Unknown type ~S" t2) + T)))) + +(defun type>= (type1 type2) + (subtypep type2 type1)) + diff --git a/src/cmp/cmptype-prop.lsp b/src/cmp/cmptype-prop.lsp new file mode 100644 index 000000000..468cc30f2 --- /dev/null +++ b/src/cmp/cmptype-prop.lsp @@ -0,0 +1,80 @@ +;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- +;;;; +;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll. +;;;; +;;;; This program is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Library General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2 of the License, or (at your option) any later version. +;;;; +;;;; See file '../Copyright' for full details. +;;;; +;;;; CMPTYPE-PROP -- Type propagation basic routines and database +;;;; + +(in-package #-new-cmp "COMPILER" #+new-cmp "C-TYPES") + +(defun infer-arg-and-return-types (fname forms &optional (env *cmp-env*)) + (let ((found (sys:get-sysprop fname 'C1TYPE-PROPAGATOR)) + arg-types + (return-type '(VALUES &REST T))) + (cond (found + (multiple-value-setq (arg-types return-type) + (apply found fname (mapcar #'location-primary-type forms)))) + ((multiple-value-setq (arg-types found) + (get-arg-types fname env)) + (setf return-type (or (get-return-type fname) return-type)))) + (values arg-types return-type found))) + +(defun enforce-types (fname arg-types arguments) + (do* ((types arg-types (rest types)) + (args arguments (rest args)) + (i 1 (1+ i)) + (in-optionals nil)) + ((endp types) + (when types + (cmpwarn "Too many arguments passed to ~A" fname))) + (let ((expected-type (first types))) + (when (member expected-type '(* &rest &key &allow-other-keys) :test #'eq) + (return)) + (when (eq expected-type '&optional) + (when (or in-optionals (null (rest types))) + (cmpwarn "Syntax error in type proclamation for function ~A.~&~A" + fname arg-types)) + (setf in-optionals t + types (rest types) + expected-type (first types))) + (when (endp args) + (unless in-optionals + (cmpwarn "Too few arguments for proclaimed function ~A" fname)) + (return)) + (let* ((value (first args)) + (actual-type (location-primary-type value)) + (intersection (type-and actual-type expected-type))) + (unless intersection + (cmperr "The argument ~d of function ~a has type~&~4T~A~&instead of expected~&~4T~A" + i fname actual-type expected-type)) + #-new-cmp + (when (zerop (cmp-env-optimization 'safety)) + (setf (c1form-type value) intersection)))))) + +(defun propagate-types (fname forms) + (multiple-value-bind (arg-types return-type found) + (infer-arg-and-return-types fname forms) + (when found + (enforce-types fname arg-types forms)) + return-type)) + +(defmacro def-type-propagator (fname lambda-list &body body) + (unless (member '&rest lambda-list) + (let ((var (gensym))) + (setf lambda-list (append lambda-list (list '&rest var)) + body (list* `(declare (ignorable ,var)) body))) + `(sys:put-sysprop ',fname 'C1TYPE-PROPAGATOR + #'(ext:lambda-block ,fname ,lambda-list ,@body)))) + +(defun copy-type-propagator (orig dest-list) + (loop with function = (sys:get-sysprop orig 'C1TYPE-PROPAGATOR) + for name in dest-list + do (sys:put-sysprop name 'C1TYPE-PROPAGATOR function))) + diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp index 42949d2aa..d9106d309 100644 --- a/src/cmp/cmptype.lsp +++ b/src/cmp/cmptype.lsp @@ -14,316 +14,6 @@ (in-package "COMPILER") -;;; CL-TYPE is any valid type specification of Common Lisp. -;;; -;;; TYPE is a representation type used by ECL. TYPE is one of: -;;; -;;; T(BOOLEAN) -;;; -;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT -;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM) -;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT) -;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT) -;;; (ARRAY FIXNUM) -;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) -;;; STANDARD-OBJECT STRUCTURE-OBJECT -;;; SYMBOL -;;; UNKNOWN -;;; -;;; NIL -;;; -;;; -;;; immediate-type: -;;; FIXNUM int -;;; CHARACTER char -;;; SINGLE-FLOAT float -;;; DOUBLE-FLOAT double - -(defun member-type (type disjoint-supertypes) - (member type disjoint-supertypes :test #'subtypep)) - -;;; Check if THING is an object of the type TYPE. -;;; Depends on the implementation of TYPE-OF. -;;; (only used for saving constants?) -(defun object-type (thing) - (let ((type (if thing (type-of thing) 'SYMBOL))) - (case type - ((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL) type) - ((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER) - ((STRING BASE-STRING BIT-VECTOR) type) - (VECTOR (list 'VECTOR (array-element-type thing))) - (ARRAY (list 'ARRAY (array-element-type thing))) - #+clos - (STANDARD-OBJECT 'STANDARD-OBJECT) - #+clos - (STRUCTURE-OBJECT 'STRUCTURE-OBJECT) - (t t)))) - -(defun type-filter (type &optional values-allowed) - (multiple-value-bind (type-name type-args) (sys::normalize-type type) - (case type-name - ((FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT SYMBOL) type-name) - (SHORT-FLOAT #-short-float 'SINGLE-FLOAT #+short-float 'SHORT-FLOAT) - (LONG-FLOAT #-long-float 'DOUBLE-FLOAT #+long-float 'LONG-FLOAT) - ((SIMPLE-STRING STRING) 'STRING) - ((SIMPLE-BIT-VECTOR BIT-VECTOR) 'BIT-VECTOR) - ((NIL T) t) - ((SIMPLE-ARRAY ARRAY) - (cond ((endp type-args) '(ARRAY *)) ; Beppe - ((eq '* (car type-args)) t) - (t (let ((element-type (upgraded-array-element-type (car type-args))) - (dimensions (if (cdr type-args) (second type-args) '*))) - (if (and (not (eq dimensions '*)) - (or (numberp dimensions) - (= (length dimensions) 1))) - (case element-type - (BASE-CHAR 'STRING) - (BIT 'BIT-VECTOR) - (t (list 'VECTOR element-type))) - (list 'ARRAY element-type)))))) - (INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t)) - ((STREAM CONS) type-name) ; Juanjo - (FUNCTION type-name) - (t (cond ((eq type-name 'VALUES) - (unless values-allowed - (error "VALUES type found in a place where it is not allowed.")) - `(VALUES ,@(mapcar #'(lambda (x) - (if (or (eq x '&optional) - (eq x '&rest)) - x - (type-filter x))) - type-args))) - #+clos - ((subtypep type 'STANDARD-OBJECT) type) - #+clos - ((subtypep type 'STRUCTURE-OBJECT) type) - ((dolist (v '(FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT - #+short-float SHORT-FLOAT #+long-float LONG-FLOAT - (VECTOR T) STRING BIT-VECTOR - (VECTOR FIXNUM) (VECTOR SINGLE-FLOAT) - (VECTOR DOUBLE-FLOAT) (ARRAY BASE-CHAR) - (ARRAY BIT) (ARRAY FIXNUM) - (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) - (ARRAY T))) ; Beppe - (when (subtypep type v) (return v)))) - ((and (eq type-name 'SATISFIES) ; Beppe - (symbolp (car type-args)) - (get-sysprop (car type-args) 'TYPE-FILTER))) - (t t)))))) - -(defun valid-type-specifier (type) - (handler-case - (if (subtypep type 'T) - (values t (type-filter type)) - (values nil nil)) - (error (c) (values nil nil)))) - -(defun known-type-p (type) - (subtypep type 'T)) - -(defun type-and (t1 t2) - ;; FIXME! Should we allow "*" as type name??? - (when (or (eq t1 t2) (eq t2 '*)) - (return-from type-and t1)) - (when (eq t1 '*) - (return-from type-and t2)) - (let* ((si::*highest-type-tag* si::*highest-type-tag*) - (si::*save-types-database* t) - (si::*member-types* si::*member-types*) - (si::*elementary-types* si::*elementary-types*) - (tag1 (si::safe-canonical-type t1)) - (tag2 (si::safe-canonical-type t2))) - (cond ((and (numberp tag1) (numberp tag2)) - (setf tag1 (si::safe-canonical-type t1) - tag2 (si::safe-canonical-type t2)) - (cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL - NIL) - ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 - t1) - ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 - t2) - (t - `(AND ,t1 ,t2)))) - ((eq tag1 'CONS) - (cmpnote "Unsupported CONS type ~S. Replacing it with T." t1) - t2) - ((eq tag2 'CONS) - (cmpnote "Unsupported CONS type ~S. Replacing it with T." t2) - t1) - ((null tag1) - (setf c::*compiler-break-enable* t) - ;(error "foo") - (cmpnote "Unknown type ~S. Assuming it is T." t1) - t2) - (t - (setf c::*compiler-break-enable* t) - ;(error "foo") - (cmpnote "Unknown type ~S. Assuming it is T." t2) - t1)))) - -(defun values-type-primary-type (type) - (when (and (consp type) (eq (first type) 'VALUES)) - (let ((subtype (second type))) - (when (or (eq subtype '&optional) (eq subtype '&rest)) - (setf type (cddr type)) - (when (or (null type) - (eq (setf subtype (first type)) '&optional) - (eq subtype '&rest)) - (cmperr "Syntax error in type expression ~S" type)) - ;; An &optional or &rest output value might be missing - ;; If this is the case, the the value will be NIL. - (setf subtype (type-or 'null subtype))) - (setf type subtype))) - type) - -(defun values-type-to-n-types (type length) - (if (or (atom type) (not (eql (first type) 'values))) - (list* type (make-list (1- length) :initial-element 'NULL)) - (do* ((l (rest type)) - (output '()) - (n length (1- n))) - ((or (null l) (zerop n)) (nreverse output)) - (let ((type (pop l))) - (case type - (&optional - (when (null l) - (cmperr "Syntax error in type expression ~S" type)) - (setf type (pop l))) - (&rest - (when (null l) - (cmperr "Syntax error in type expression ~S" type)) - (setf type (pop l)) - (return-from values-type-to-n-types - (nreconc output (make-list n :initial-element l))))) - (push type output))))) - -(defun values-type-and (t1 t2) - (labels ((values-type-p (type) - (and (consp type) (eq (first type) 'VALUES))) - (values-and-ordinary (v type) - (let* ((v (rest v)) - (first-type (first v))) - (cond ((or (eq first-type '&optional) (eq first-type '&rest)) - (type-and (second v) type)) - ((null (rest v)) - (type-and first-type type)) - (t - (return-from values-type-and nil))))) - (type-error (type) - (error "Invalid type ~A" type)) - (do-values-type-and (t1-orig t2-orig) - (do* ((t1 (rest t1-orig)) - (t2 (rest t2-orig)) - (i1 (first t1)) - (i2 (first t2)) - (phase1 nil) - (phase2 nil) - (phase3 nil) - (output (list 'VALUES))) - ((or (null t1) (null t2)) - (if (or (eq t1 t2) - (eq i1 '&rest) (eq i1 '&optional) - (eq i2 '&rest) (eq i2 '&optional)) - (nreverse output) - nil)) - (cond ((eq i1 '&optional) - (when phase1 (type-error t1-orig)) - (setf phase1 '&optional) - (setf t1 (rest t1) i1 (first t1)) - (unless t1 (type-error t1-orig))) - ((eq i1 '&rest) - (when (eq phase1 '&rest) (type-error t1-orig)) - (setf phase1 '&rest) - (setf t1 (rest t1) i1 (first t1)) - (when (or (null t1) (rest t1)) (type-error t1-orig)))) - (cond ((eq i2 '&optional) - (when phase2 (type-error t2-orig)) - (setf phase2' &optional) - (setf t2 (rest t2) i2 (first t2)) - (unless t2 (type-error t2-orig))) - ((eq i2 '&rest) - (when (eq phase2 '&rest) (type-error t2-orig)) - (setf phase2 '&rest) - (setf t2 (rest t2) i2 (first t2)) - (when (or (null t2) (rest t2)) (type-error t2-orig)))) - (cond ((and (null phase1) (null phase2)) - (push (type-and i1 i2) output) - (setf t1 (rest t1) i1 (first t1) - t2 (rest t2) i2 (first t2))) - ((null phase2) - (push (type-and i1 i2) output) - (unless (eq phase1 '&rest) - (setf t1 (rest t1) i1 (first t1))) - (setf t2 (rest t2) i2 (first t2))) - ((null phase1) - (push (type-and i1 i2) output) - (unless (eq phase2 '&rest) - (setf t2 (rest t2) i2 (first t2))) - (setf t1 (rest t1) i1 (first t1))) - ((eq phase1 phase2) - (unless (eq phase3 phase2) - (push (setf phase3 phase2) output)) - (push (type-and i1 i2) output) - (cond ((eq phase1 '&rest) (setf t1 nil t2 nil)) - (t (setf t1 (rest t1) i1 (first t1) - t2 (rest t2) i2 (first t2))))) - ((eq phase1 '&optional) - (unless (eq phase3 phase1) - (push (setf phase3 phase1) output)) - (push (type-and i1 i2) output) - (setf t1 (rest t1) i1 (first t1))) - ((eq phase2 '&optional) - (unless (eq phase3 phase2) - (push (setf phase3 phase2) output)) - (push (type-and i1 i2) output) - (setf t2 (rest t2) i2 (first t2))))))) - (if (equal t1 t2) - t1 - (if (values-type-p t1) - (if (values-type-p t2) - (do-values-type-and t1 t2) - (values-and-ordinary t1 t2)) - (if (values-type-p t2) - (values-and-ordinary t2 t1) - (type-and t1 t2)))))) - -(defun type-or (t1 t2) - ;; FIXME! Should we allow "*" as type name??? - (when (or (eq t1 t2) (eq t2 '*)) - (return-from type-or t1)) - (when (eq t1 '*) - (return-from type-or t2)) - (let* ((si::*highest-type-tag* si::*highest-type-tag*) - (si::*save-types-database* t) - (si::*member-types* si::*member-types*) - (si::*elementary-types* si::*elementary-types*) - (tag1 (si::safe-canonical-type t1)) - (tag2 (si::safe-canonical-type t2))) - (cond ((and (numberp tag1) (numberp tag2)) - (setf tag1 (si::safe-canonical-type t1) - tag2 (si::safe-canonical-type t2)) - (cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 - t2) - ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 - t1) - (t - `(OR ,t1 ,t2)))) - ((eq tag1 'CONS) - (cmpnote "Unsupported CONS type ~S. Replacing it with T." t1) - T) - ((eq tag2 'CONS) - (cmpnote "Unsupported CONS type ~S. Replacing it with T." t2) - T) - ((null tag1) - (cmpnote "Unknown type ~S" t1) - T) - (t - (cmpnote "Unknown type ~S" t2) - T)))) - -(defun type>= (type1 type2) - (subtypep type2 type1)) - ;;; ;;; and-form-type ;;; returns a copy of form whose type is the type-and of type and the form's @@ -351,232 +41,6 @@ (c1constant-value new-value :only-small-values t) (c1nil)))) -;;---------------------------------------------------------------------- -;; (FUNCTION ...) types. This code is a continuation of predlib.lsp. -;; It implements function types and a SUBTYPEP relationship between them. -;; - -(in-package "SI") - -(defstruct function-type - required - optional - rest - key-p - keywords - keyword-types - allow-other-keys-p - output) - -(defun canonical-function-type (ftype) - (when (function-type-p ftype) - (return-from canonical-function-type ftype)) - (flet ((ftype-error () - (error "Syntax error in FUNCTION type definition ~S" ftype))) - (let (o k k-t values) - (unless (and (= (length ftype) 3) (eql (first ftype) 'FUNCTION)) - (ftype-error)) - (multiple-value-bind (requireds optionals rest key-flag keywords - allow-other-keys-p auxs) - (si::process-lambda-list (second ftype) 'FTYPE) - (dotimes (i (pop optionals)) - (let ((type (first optionals)) - (init (second optionals)) - (flag (third optionals))) - (setq optionals (cdddr optionals)) - (when (or init flag) (ftype-error)) - (push type o))) - (dotimes (i (pop keywords)) - (let ((keyword (first keywords)) - (var (second keywords)) - (type (third keywords)) - (flag (fourth keywords))) - (setq keywords (cddddr keywords)) - (when (or var flag) (ftype-error)) - (push keyword k) - (push type k-t))) - (setf values (third ftype)) - (cond ((atom values) (setf values (list 'VALUES values))) - ((and (listp values) (eql (first values) 'VALUES))) - (t (ftype-error))) - (when (and rest key-flag - (not (subtypep 'keyword rest))) - (ftype-error)) - (make-function-type :required (rest requireds) - :optional o - :rest rest - :key-p key-flag - :keywords k - :keyword-types k-t - :allow-other-keys-p allow-other-keys-p - :output (canonical-values-type values)))))) - -(defconstant +function-type-tag+ (cdr (assoc 'FUNCTION *elementary-types*))) - -(defun register-function-type (type) - (or (find-registered-tag type) - (find-registered-tag (setq ftype (canonical-function-type type))) - (let ((tag (register-type ftype #'function-type-p #'function-type-<=))) - (update-types +function-type-tag+ tag) - tag))) - -(defun function-type-<= (f1 f2) - (unless (and (every* #'subtypep - (function-type-required f2) - (function-type-required f1)) - (do* ((o1 (function-type-optional f1) (cdr o1)) - (o2 (function-type-optional f2) (cdr o2)) - (r1 (function-type-rest f1)) - (r2 (function-type-rest f2)) - t1 t2) - ((and (endp o1) (endp o2)) t) - (setf t1 (cond ((consp o1) (first o1)) - (r1 r1) - (t (return nil))) - t2 (cond ((consp o2) (first o2)) - (r2 r2) - (t (return nil)))) - (unless (subtypep t1 t2) - (return nil))) - (subtypep (function-type-output f1) - (function-type-output f2)) - (eql (function-type-key-p f1) (function-type-key-p f2)) - (or (function-type-allow-other-keys-p f2) - (not (function-type-allow-other-keys-p f1)))) - (return-from function-type-<= nil)) - (do* ((k2 (function-type-keywords f2)) - (k-t2 (function-type-keyword-types f2)) - (k1 (function-type-keywords f1) (cdr k1)) - (k-t1 (function-type-keyword-types f1) (cdr k1))) - ((endp k1) - t) - (unless - (let* ((n (position (first k1) k2))) - (when n - (let ((t2 (nth n k-t2))) - (subtypep (first k-t1) t2)))) - (return-from function-type-<= nil)))) - -;;---------------------------------------------------------------------- -;; (VALUES ...) type - -(defstruct values-type - min-values - max-values - required - optional - rest) - -(defun register-values-type (vtype) - (or (find-registered-tag vtype) - (find-registered-tag (setf vtype (canonical-values-type vtype))) - (register-type vtype #'values-type-p #'values-type-<=))) - -(defun canonical-values-type (vtype) - (when (values-type-p vtype) - (return-from canonical-values-type vtype)) - (flet ((vtype-error () - (error "Syntax error in VALUES type definition ~S" vtype))) - (unless (and (listp vtype) (eql (pop vtype) 'VALUES)) - (vtype-error)) - (let ((required '()) - (optional '()) - (rest nil)) - (do () - ((endp vtype) - (make-values-type :min-values (length required) - :max-values (if rest multiple-values-limit - (+ (length required) - (length optional))) - :required (nreverse required) - :optional (nreverse optional) - :rest rest)) - - (let ((type (pop vtype))) - (if (eql type '&optional) - (do () - ((endp vtype)) - (let ((type (pop vtype))) - (if (eql type '&rest) - (if (endp vtype) - (ftype-error) - (setf rest (first vtype))) - (push type optional)))) - (push type required))))))) - -(defun values-type-<= (v1 v2) - (and (= (values-type-min-values v1) (values-type-min-values v2)) - (= (values-type-max-values v1) (values-type-max-values v2)) - (every* #'subtypep (values-type-required v1) (values-type-required v2)) - (every* #'subtypep (values-type-optional v1) (values-type-optional v2)) - (subtypep (values-type-rest v1) (values-type-rest v2)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; TYPE PROPAGATORS -;;; - -(in-package "COMPILER") - -(defun simple-type-propagator (fname) - (let ((arg-types (get-arg-types fname)) - (return-type (or (get-return-type fname) '(VALUES &REST T)))) - (values arg-types return-type))) - -(defun propagate-types (fname forms lisp-forms) - (multiple-value-bind (arg-types return-type) - (let ((propagator (get-sysprop fname 'C1TYPE-PROPAGATOR))) - (if propagator - (apply propagator fname (mapcar #'c1form-primary-type forms)) - (simple-type-propagator fname))) - (when arg-types - (do* ((types arg-types (rest types)) - (fl forms (rest fl)) - (al lisp-forms (rest al)) - (i 1 (1+ i)) - (in-optionals nil)) - ((endp types) - (when types - (cmpwarn "Too many arguments passed to ~A" fname))) - (let ((expected-type (first types))) - (when (member expected-type '(* &rest &key &allow-other-keys) :test #'eq) - (return)) - (when (eq expected-type '&optional) - (when in-optionals - (cmpwarn "Syntax error in type proclamation for function ~A.~&~A" - fname arg-types)) - (setf in-optionals t - types (rest types) - expected-type (first types))) - (when (endp fl) - (unless in-optionals - (cmpwarn "Too few arguments for proclaimed function ~A" fname)) - (return)) - (when lisp-forms - (let* ((form (first fl)) - (lisp-form (first al)) - (old-type (c1form-type form))) - (and-form-type expected-type form lisp-form - :safe "In the argument ~d of a call to ~a" i fname) - ;; In safe mode, we cannot assume that the type of the - ;; argument is going to be the right one. - (unless (zerop (cmp-env-optimization 'safety)) - (setf (c1form-type form) old-type))))))) - return-type)) - -(defmacro def-type-propagator (fname lambda-list &body body) - (unless (member '&rest lambda-list) - (let ((var (gensym))) - (setf lambda-list (append lambda-list (list '&rest var)) - body (list* `(declare (ignorable ,var)) body))) - `(put-sysprop ',fname 'C1TYPE-PROPAGATOR - #'(ext:lambda-block ,fname ,lambda-list ,@body)))) - -(defun copy-type-propagator (orig dest-list) - (loop with function = (get-sysprop orig 'C1TYPE-PROPAGATOR) - for name in dest-list - do (put-sysprop name 'C1TYPE-PROPAGATOR function))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; TYPE CHECKING diff --git a/src/new-cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp similarity index 87% rename from src/new-cmp/cmptypes.lsp rename to src/cmp/cmptypes.lsp index 356352593..139fd4715 100644 --- a/src/new-cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -1,7 +1,6 @@ ;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- ;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. -;;;; Copyright (c) 1990, Giuseppe Attardi. +;;;; Copyright (c) 2010, Juan Jose Garcia-Ripoll ;;;; ;;;; This program is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Library General Public @@ -13,7 +12,7 @@ ;;;; CMPTYPES -- Data types for the Lisp core structures ;;;; -(in-package "C-DATA") +(in-package #-new-cmp "COMPILER" #+new-cmp "C-DATA") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -53,7 +52,8 @@ ; read-nodes ;;; Nodes (c1forms) in which the reference occurs set-nodes ;;; Nodes in which the variable is modified kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM, - ;;; :CHAR, :DOUBLE, :FLOAT, REPLACED or DISCARDED + ;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for + ;;; LET variables). (function *current-function*) ;;; For local variables, in which function it was created. ;;; For global variables, it doesn't have a meaning. @@ -78,6 +78,11 @@ ;;; lex-ndx is the index within the array for this env. ;;; For SPECIAL and GLOBAL: the vv-index for variable name. (type t) ;;; Type of the variable. + #-new-cmp + (index -1) ;;; position in *vars*. Used by similar. + #-new-cmp + (ignorable nil) ;;; Whether there was an IGNORABLE/IGNORE declaration + #+new-cmp read-only-p ;;; T for variables that are assigned only once. ) @@ -126,7 +131,9 @@ ; ref-clb ;;; Unused. ; read-nodes ;;; Nodes (c1forms) in which the reference occurs cfun ;;; The cfun for the function. + #+new-cmp (last-lcl 0) ;;; Number of local variables (just to bookkeep names) + #+new-cmp (last-label 0) ;;; Number of generated labels (same as last-lcl) (level 0) ;;; Level of lexical nesting for a function. (env 0) ;;; Size of env of closure. @@ -140,12 +147,14 @@ closure ;;; During Pass2, T if env is used inside the function var ;;; the variable holding the funob description ;;; Text for the object, in case NAME == NIL. + #+new-cmp lambda-list ;;; List of (requireds optionals rest-var keywords-p ;;; keywords allow-other-keys-p) + lambda ;;; Lambda c1-form for this function. (minarg 0) ;;; Min. number arguments that the function receives. (maxarg call-arguments-limit) ;;; Max. number arguments that the function receives. - lambda ;;; Lambda c1-form for this function. + #+new-cmp doc ;;; Documentation (parent *current-function*) ;;; Parent function, NIL if global. @@ -154,13 +163,17 @@ (referred-funs nil) ;;; List of external functions called in this one. ;;; We only register direct calls, not calls via object. (child-funs nil) ;;; List of local functions defined here. + #+new-cmp (debug 0) ;;; Debug quality - (file *compile-file-truename*) + (file (car ext:*source-location*)) ;;; Source file or NIL - (file-position *compile-file-position*) + (file-position (or (cdr ext:*source-location*) *compile-file-position*)) ;;; Top-level form number in source file + #+new-cmp (toplevel-form *current-toplevel-form*) + #+new-cmp code-gen-props ;;; Extra properties for code generation + (cmp-env (cmp-env-copy)) ;;; Environment ) (defstruct (blk (:include ref)) @@ -178,7 +191,10 @@ exit ;;; Where to return. A label. destination ;;; Where the value of the block to go. var ;;; Variable containing the block ID. - env ;;; Block environment + #-new-cmp + (type 'NIL) ;;; Estimated type. + #+new-cmp + env ;;; Block environment. ) (defstruct (tag (:include ref)) @@ -193,10 +209,17 @@ unwind-exit ;;; Where to unwind-no-exit. var ;;; Variable containing frame ID. index ;;; An integer denoting the label. - env ;;; Tag environment + #+new-cmp + env ;;; Tag environment. ) (defstruct (info) + (local-vars nil) ;;; List of var-objects created directly in the form. + #-new-cmp + (type t) ;;; Type of the form. + (sp-change nil) ;;; Whether execution of the form may change + ;;; the value of a special variable. + (volatile nil) ;;; whether there is a possible setjmp. Beppe ) (defstruct (inline-info) @@ -214,15 +237,14 @@ (defstruct (c1form (:include info) (:print-object print-c1form) (:constructor do-make-c1form)) - (name nil) ;; See cmptables.lsp for all valid form names - (args '()) ;; Arguments - (env (c-env:cmp-env-copy)) ;; Environment in which this form was compiled - (local-vars nil) ;; List of var-objects created directly in the form. - (sp-change nil) ;; Whether execution of the form may change - ;; the value of a special variable. - (volatile nil) ;; whether there is a possible setjmp. Beppe - - (form nil) ;; Origin of this form - (toplevel-form) ;; ... including toplevel form in which it appears - (file nil) ;; ... and source file and position + (name nil) + (parent nil) + #+new-cmp + (env (c-env:cmp-env-copy)) ;; Environment in which this form was compiled + #-new-cmp + (env (cmp-env-copy)) ;; Environment in which this form was compiled + (args '()) + (form nil) + (toplevel-form nil) + (file nil) (file-position 0)) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 9380f0c41..5ef669957 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -347,9 +347,3 @@ (<= #.(char-code #\0) cc #.(char-code #\9))) c #\_))) (string-downcase (prin1-to-string obj))))) - -#-new-cmp -(defun proper-list-p (x &optional test) - (and (listp x) - (handler-case (list-length x) (type-error (c) nil)) - (or (null test) (every test x)))) diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp index 16f5f72cc..9dab633be 100644 --- a/src/cmp/cmpwt.lsp +++ b/src/cmp/cmpwt.lsp @@ -14,110 +14,16 @@ (in-package "COMPILER") -(defvar *wt-string-size* 0) - +;;; ====================================================================== +;;; +;;; DATA FILES +;;; ;;; Each lisp compiled file consists on code and a data section. Whenever an ;;; #'in-package toplevel form is found, a read-time evaluated expression is ;;; inserted in the data section which changes the current package for the ;;; rest of it. This way it is possible to save some space by writing the ;;; symbol's package only when it does not belong to the current package. -(defun wt-label (label) - (when (cdr label) (wt-nl1 "L" (car label) ":;"))) - -(defun wt-filtered-comment (text stream single-line) - (declare (string text)) - (if single-line - (progn - (fresh-line stream) - (princ "/* " stream)) - (format stream "~50T/* ")) - (let* ((l (1- (length text)))) - (declare (fixnum l)) - (dotimes (n l) - (let ((c (schar text n))) - (princ c stream) - (when (and (char= c #\*) (char= (schar text (1+ n)) #\/)) - (princ #\\ stream)))) - (princ (schar text l) stream)) - (format stream "~70T*/") - ) - -(defun do-wt-comment (message-or-format args single-line-p) - (unless (and (symbolp message-or-format) (not (symbol-package message-or-format))) - (wt-filtered-comment (if (stringp message-or-format) - (if args - (apply #'format nil message-or-format args) - message-or-format) - (princ-to-string message-or-format)) - *compiler-output1* - single-line-p))) - -(defun wt-comment (message &rest extra) - (do-wt-comment message extra nil)) - -(defun wt-comment-nl (message &rest extra) - (do-wt-comment message extra t)) - -(defun wt1 (form) - (typecase form - ((or STRING INTEGER CHARACTER) - (princ form *compiler-output1*)) - ((or DOUBLE-FLOAT SINGLE-FLOAT) - (format *compiler-output1* "~10,,,,,,'eG" form)) - (LONG-FLOAT - (format *compiler-output1* "~,,,,,,'eEl" form)) - (VAR (wt-var form)) - (t (wt-loc form))) - nil) - -(defun wt-h1 (form) - (if (consp form) - (let ((fun (get-sysprop (car form) 'wt-loc))) - (if fun - (let ((*compiler-output1* *compiler-output2*)) - (apply fun (cdr form))) - (cmperr "The location ~s is undefined." form))) - (princ form *compiler-output2*)) - nil) - -;;; This routine converts lisp data into C-strings. We have to take -;;; care of escaping special characteres with backslashes. We also have -;;; to split long lines using the fact that multiple strings are joined -;;; together by the compiler. -;;; -(defun wt-filtered-data (string stream &optional one-liner) - (let ((N (length string)) - (wt-data-column 80)) - (incf *wt-string-size* (1+ N)) ; 1+ accounts for a blank space - (format stream (if one-liner "\"" "~%\"")) - (dotimes (i N) - (decf wt-data-column) - (when (< wt-data-column 0) - (format stream "\"~% \"") - (setq wt-data-column 79)) - (let ((x (aref string i))) - (cond - ((or (< (char-code x) 32) - (> (char-code x) 127)) - (case x - ; We avoid a trailing backslash+newline because some preprocessors - ; remove them. - (#\Newline (princ "\\n" stream)) - (#\Tab (princ "\\t" stream)) - (t (format stream "\\~3,'0o" (char-code x))))) - ((char= x #\\) - (princ "\\\\" stream)) - ((char= x #\") - (princ "\\\"" stream)) - (t (princ x stream))))) - (princ (if one-liner "\"" " \"") stream) - string)) - -;;; ====================================================================== -;;; -;;; DATA FILES -;;; (defun data-permanent-storage-size () (length *permanent-objects*)) diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index 44741913f..e62863819 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -1,16 +1,28 @@ ;;; @configure_input@ (defconstant +cmp-module-files+ -'("build:cmp;cmpdefs.lsp" +'("src:cmp;cmppackage.lsp" + "src:cmp;cmptypes.lsp" + "src:cmp;cmpglobals.lsp" + "build:cmp;cmpdefs.lsp" "src:cmp;cmpmac.lsp" + "src:cmp;cmpform.lsp" + "src:cmp;cmpc-wt.lsp" "src:cmp;cmpinline.lsp" "src:cmp;cmputil.lsp" + "src:cmp;cmptype-arith.lsp" + "src:cmp;cmptype-prop.lsp" "src:cmp;cmptype.lsp" "src:cmp;cmpbind.lsp" "src:cmp;cmpblock.lsp" "src:cmp;cmpcall.lsp" "src:cmp;cmpcatch.lsp" - "src:cmp;cmpenv.lsp" + "src:cmp;cmpenv-api.lsp" + "src:cmp;cmpenv-fun.lsp" + "src:cmp;cmpenv-declare.lsp" + "src:cmp;cmpenv-proclaim.lsp" + "src:cmp;cmpenv-declaim.lsp" + "src:cmp;cmppolicy.lsp" "src:cmp;cmpeval.lsp" "src:cmp;cmpexit.lsp" "src:cmp;cmpflet.lsp" diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp index eecc886dc..2c354c82a 100644 --- a/src/cmp/proclamations.lsp +++ b/src/cmp/proclamations.lsp @@ -42,15 +42,12 @@ (in-package "C") -(defun proclaim-function (name arg-types return-type &rest properties) +(defun parse-function-proclamation + (name arg-types return-type &rest properties) (when (sys:get-sysprop name 'proclaimed-arg-types) (warn "Duplicate proclamation for ~A" name)) - (when (eq arg-types '()) - (setf arg-types '(&optional))) - (unless (or (equal arg-types '(*))) - (sys:put-sysprop name 'proclaimed-arg-types arg-types)) - (when (and return-type (not (eq 'T return-type))) - (sys:put-sysprop name 'proclaimed-return-type return-type)) + (#-new-cmp proclaim-function #+new-cmp c-env::proclaim-function + name (list arg-types return-type)) (loop for p in properties do (case p (:no-sp-change @@ -61,8 +58,8 @@ ((:no-side-effects :reader) (sys:put-sysprop name 'no-side-effects t)) (otherwise - (error "Unknown property ~S in function proclamation ~S" - p form))))) + (error "Unknown property ~S in function proclamation for ~S" + p name))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; AUXILIARY TYPES @@ -351,12 +348,12 @@ (proclamation si:*make-special (symbol) symbol) (proclamation si:*make-constant (symbol t) symbol) (proclamation si:put-f (list t t) list) -(proclamation si:rem-f (list t) boolean) +(proclamation si:rem-f (list t) (values list boolean)) (proclamation si:set-symbol-plist (symbol list) list) (proclamation si:putprop (symbol t t) t) (proclamation si:put-sysprop (t t t) t) -(proclamation si:get-sysprop (t t t) t) -(proclamation si:rem-sysprop (t t) gen-bool) +(proclamation si:get-sysprop (t t) (values t boolean)) +(proclamation si:rem-sysprop (t t) boolean) (proclamation si:put-properties (symbol &rest t) symbol :no-sp-change) @@ -526,7 +523,7 @@ ;; (proclamation arithmetic-error-operation (condition) t) ;; ECL extensions -(proclamation si:bit-array-op (t t t t) t) +(proclamation si:bit-array-op (t t t t) (array bit)) (proclamation si:fixnump (t) gen-book :pure) ;; Virtual functions added by the compiler @@ -699,8 +696,8 @@ (proclamation nunion (proper-list proper-list &key) proper-list) ;; ECL extensions -(proclamation member1 (t proper-list t t t) t) -(proclamation si:memq (t proper-list) t) +(proclamation si:member1 (t proper-list t t t) list) +(proclamation si:memq (t proper-list) list) ;;; ;;; 15. ARRAYS @@ -1314,5 +1311,5 @@ ))) ; eval-when (loop for i in '#.(mapcar #'rest +proclamations+) - do (apply #'proclaim-function i)) + do (apply #'parse-function-proclamation i)) diff --git a/src/compile.lsp.in b/src/compile.lsp.in index cd39ff22f..8d02acf2b 100755 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -71,7 +71,7 @@ ;;; * Compile and link Common-Lisp base library ;;; (setq si::*keep-documentation* nil) -(proclaim '(optimize (safety 2) (space 3))) +(proclaim '(optimize (safety 2) (space 3) (debug 1))) (let* ((c::*cc-flags* (concatenate 'string "-DECL_API -I\"@true_builddir@/c\" " c::*cc-flags*)) (lsp-objects (compile-if-old "build:lsp;" +lisp-module-files+ :system-p t :c-file t :data-file t :h-file t @@ -79,7 +79,7 @@ ))) #+CLOS (let* ((c::*compile-to-linking-call* nil)) - (proclaim '(optimize (safety 2) (space 3))) + (proclaim '(optimize (safety 2) (space 3) (debug 1))) (setq lsp-objects (append lsp-objects (compile-if-old "build:clos;" +clos-module-files+ :system-p t :c-file t :data-file t :h-file t @@ -128,7 +128,7 @@ ;;; ;;; * Compile and link Common-Lisp to C compiler ;;; -(proclaim '(optimize (safety 2) (space 3))) +(proclaim '(optimize (safety 2) (space 3) (debug 1))) (si::pathname-translations "SYS" '(("**;*.*.*" "@ecldir\@/**/*.*"))) diff --git a/src/configure b/src/configure index 70b68f7c4..38a20b5b7 100755 --- a/src/configure +++ b/src/configure @@ -14255,7 +14255,7 @@ $as_echo "$as_me: error: Not a valid argument for --enable-boehm $enable_boehm" { (exit 1); exit 1; }; };; esac -ac_config_files="$ac_config_files bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp new-cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile doc/ecl.man doc/ecl-config.man ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp new-cmp/cmpdefs.pre:new-cmp/cmpdefs.lsp" +ac_config_files="$ac_config_files bare.lsp lsp/load.lsp clos/load.lsp cmp/load.lsp new-cmp/load.lsp ../Makefile Makefile c/Makefile doc/Makefile doc/ecl.man doc/ecl-config.man ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp" ac_config_headers="$ac_config_headers ecl/config.h:ecl/configpre.h" # FIXME @@ -14870,7 +14870,6 @@ do "lsp/config.pre") CONFIG_FILES="$CONFIG_FILES lsp/config.pre:lsp/config.lsp.in" ;; "compile.pre") CONFIG_FILES="$CONFIG_FILES compile.pre:compile.lsp.in" ;; "cmp/cmpdefs.pre") CONFIG_FILES="$CONFIG_FILES cmp/cmpdefs.pre:cmp/cmpdefs.lsp" ;; - "new-cmp/cmpdefs.pre") CONFIG_FILES="$CONFIG_FILES new-cmp/cmpdefs.pre:new-cmp/cmpdefs.lsp" ;; "ecl/config.h") CONFIG_HEADERS="$CONFIG_HEADERS ecl/config.h:ecl/configpre.h" ;; *) { { $as_echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 diff --git a/src/configure.in b/src/configure.in index a4ac98bbc..0015f15a9 100644 --- a/src/configure.in +++ b/src/configure.in @@ -891,7 +891,6 @@ AC_CONFIG_FILES([ ecl/configpre.h:h/config.h.in bin/ecl-config.pre:util/ecl-config lsp/config.pre:lsp/config.lsp.in compile.pre:compile.lsp.in cmp/cmpdefs.pre:cmp/cmpdefs.lsp - new-cmp/cmpdefs.pre:new-cmp/cmpdefs.lsp ]) AC_CONFIG_HEADERS([ecl/config.h:ecl/configpre.h]) # FIXME AC_OUTPUT diff --git a/src/new-cmp/cmpc-inline.lsp b/src/new-cmp/cmpc-inline.lsp index be6b441b5..efaf0ee0e 100644 --- a/src/new-cmp/cmpc-inline.lsp +++ b/src/new-cmp/cmpc-inline.lsp @@ -65,10 +65,6 @@ (defun get-inline-info (fname types return-type return-rep-type) (declare (si::c-local)) (let ((output nil)) - (dolist (x *inline-functions*) - (when (eq (car x) fname) - (let ((other (inline-type-matches (cdr x) types return-type))) - (setf output (choose-inline-info output other return-type return-rep-type))))) (unless (safe-compile) (dolist (x (sys:get-sysprop fname ':INLINE-UNSAFE)) (let ((other (inline-type-matches x types return-type))) diff --git a/src/new-cmp/cmpdefs.lsp b/src/new-cmp/cmpdefs.lsp deleted file mode 100644 index c70984467..000000000 --- a/src/new-cmp/cmpdefs.lsp +++ /dev/null @@ -1,69 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- -;;;; -;;;; Copyright (c) 2009, Juan Jose Garcia-Ripoll -;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. -;;;; -;;;; CMPDEFS -- Definitions created at compile / configuration time - -(in-package "C") - -;;; This is copied into each .h file generated, EXCEPT for system-p calls. -;;; The constant string *include-string* is the content of file "ecl.h". -;;; Here we use just a placeholder: it will be replaced with sed. -(defvar *cmpinclude* "") - -;;; -;;; Compiler program and flags. -;;; - -(defvar *cc* "@ECL_CC@" -"This variable controls how the C compiler is invoked by ECL. -The default value is \"cc -I. -I/usr/local/include/\". -The second -I option names the directory where the file ECL.h has been installed. -One can set the variable appropriately adding for instance flags which the -C compiler may need to exploit special hardware features (e.g. a floating point -coprocessor).") - -(defvar *ld* "@ECL_CC@" -"This variable controls the linker which is used by ECL.") - -(defvar *cc-flags* "@CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@") - -(defvar *cc-optimize* #-msvc "-O" - #+msvc "@CFLAGS_OPTIMIZE@") - -(defvar *ld-format* #-msvc "~A -o ~S -L~S ~{~S ~} ~@?" - #+msvc "~A -Fe~S~* ~{~S ~} ~@?") - -(defvar *cc-format* #-msvc "~A ~A ~:[~*~;~A~] \"-I~A\" -w -c \"~A\" -o \"~A\"" - #+msvc "~A ~A ~:[~*~;~A~] -I\"~A\" -w -c \"~A\" -Fo\"~A\"") - -#-dlopen -(defvar *ld-flags* "@LDFLAGS@ -lecl @CORE_LIBS@ @FASL_LIBS@ @LIBS@") -#+dlopen -(defvar *ld-flags* #-msvc "@LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@" - #+msvc "@LDFLAGS@ ecl.lib @CLIBS@") -#+dlopen -(defvar *ld-shared-flags* #-msvc "@SHARED_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@" - #+msvc "@SHARED_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@") -#+dlopen -(defvar *ld-bundle-flags* #-msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ -lecl @FASL_LIBS@ @LIBS@" - #+msvc "@BUNDLE_LDFLAGS@ @LDFLAGS@ ecl.lib @CLIBS@") - -(defvar +shared-library-prefix+ "@SHAREDPREFIX@") -(defvar +shared-library-extension+ "@SHAREDEXT@") -(defvar +shared-library-format+ "@SHAREDPREFIX@~a.@SHAREDEXT@") -(defvar +static-library-prefix+ "@LIBPREFIX@") -(defvar +static-library-extension+ "@LIBEXT@") -(defvar +static-library-format+ "@LIBPREFIX@~a.@LIBEXT@") -(defvar +object-file-extension+ "@OBJEXT@") -(defvar +executable-file-format+ "~a@EXEEXT@") - -(defvar *ecl-include-directory* @includedir\@) -(defvar *ecl-library-directory* @libdir\@) diff --git a/src/new-cmp/cmpenv.lsp b/src/new-cmp/cmpenv.lsp deleted file mode 100644 index 36c8be83b..000000000 --- a/src/new-cmp/cmpenv.lsp +++ /dev/null @@ -1,680 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- -;;;; -;;;; Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya. -;;;; Copyright (c) 1990, Giuseppe Attardi. -;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Library General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 2 of the License, or (at your option) any later version. -;;;; -;;;; See file '../Copyright' for full details. - -;;;; CMPENV Environments of the Compiler. - -(in-package "C-ENV") - -(defun function-arg-types (arg-types &aux (types nil)) - (do ((al arg-types (cdr al))) - ((or (endp al) - (member (car al) '(&optional &rest &key))) - (nreverse types)) - (declare (object al)) - (push (c-types:type-filter (car al)) types))) - -(defun proper-list-p (x &optional test) - (and (listp x) - (handler-case (list-length x) (type-error (c) nil)) - (or (null test) (every test x)))) - -;;; The valid return type declaration is: -;;; (( VALUES {type}* )) or ( {type}* ). - -(defun function-return-type (return-types) - (cond ((endp return-types) t) - ((and (consp (car return-types)) - (eq (caar return-types) 'VALUES)) - (cond ((not (endp (cdr return-types))) - (warn "The function return types ~s is illegal." return-types) - t) - ((or (endp (cdar return-types)) - (member (cadar return-types) '(&optional &rest &key))) - t) - (t (c-types:type-filter (cadar return-types))))) - (t (c-types:type-filter (car return-types))))) - -(defun add-function-proclamation (fname decl) - (if (si:valid-function-name-p fname) - (let* ((arg-types '*) - (return-types '*) - (l decl)) - (cond ((null l)) - ((consp l) - (setf arg-types (pop l))) - (t (warn "The function proclamation ~s ~s is not valid." - fname decl))) - (cond ((null l)) - ((and (consp l) (null (rest l))) - (setf return-types (function-return-type l))) - (t (warn "The function proclamation ~s ~s is not valid." - fname decl))) - (if (eq arg-types '*) - (rem-sysprop fname 'PROCLAIMED-ARG-TYPES) - (put-sysprop fname 'PROCLAIMED-ARG-TYPES arg-types)) - (if (eq return-types '*) - (rem-sysprop fname 'PROCLAIMED-RETURN-TYPE) - (put-sysprop fname 'PROCLAIMED-RETURN-TYPE return-types))) - (warn "The function proclamation ~s ~s is not valid." fname decl))) - -(defun add-function-declaration (fname arg-types return-types env) - (if (si::valid-function-name-p fname) - (cmp-env-register-ftype fname (list arg-types return-types) env) - (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname)) - env) - -(defun get-arg-types (fname &optional (env *cmp-env*)) - (let ((x (cmp-env-search-ftype fname env))) - (if x - (values (first x) t) - (sys:get-sysprop fname 'PROCLAIMED-ARG-TYPES)))) - -(defun get-return-type (fname &optional (env *cmp-env*)) - (let ((x (cmp-env-search-ftype fname env))) - (if x - (values (second x) t) - (sys:get-sysprop fname 'PROCLAIMED-RETURN-TYPE)))) - -(defun get-local-arg-types (fun &optional (env *cmp-env*)) - (let ((x (cmp-env-search-ftype (fun-name fun)))) - (if x - (values (first x) t) - (values nil nil)))) - -(defun get-local-return-type (fun &optional (env *cmp-env*)) - (let ((x (cmp-env-search-ftype (fun-name fun)))) - (if x - (values (second x) t) - (values nil nil)))) - -(defun get-proclaimed-narg (fun &optional (env *cmp-env*)) - (multiple-value-bind (arg-list found) - (get-arg-types fun env) - (if found - (loop for type in arg-list - with minarg = 0 - and maxarg = 0 - and in-optionals = nil - do (cond ((member type '(* &rest &key &allow-other-keys) :test #'eq) - (return (values minarg call-arguments-limit))) - ((eq type '&optional) - (setf in-optionals t maxarg minarg)) - (in-optionals - (incf maxarg)) - (t - (incf minarg) - (incf maxarg))) - finally (return (values minarg maxarg found))) - (values 0 call-arguments-limit found)))) - -;;; Proclamation and declaration handling. - -(defun inline-possible (fname &optional (env *cmp-env*)) - (not (or ; (compiler-= *debug* 2) Breaks compilation of STACK-PUSH-VALUES - (let ((x (cmp-env-search-declaration 'notinline env))) - (and x (member fname x :test #'same-fname-p))) - (member fname *notinline* :test #'same-fname-p) - (sys:get-sysprop fname 'CMP-NOTINLINE)))) - -#-:CCL -(defun proclaim (decl &aux decl-name) - (unless (listp decl) - (error "The proclamation specification ~s is not a list" decl)) - (case (setf decl-name (car decl)) - (SPECIAL - (dolist (var (cdr decl)) - (if (symbolp var) - (sys:*make-special var) - (error "Syntax error in proclamation ~s" decl)))) - (OPTIMIZE - (dolist (x (cdr decl)) - (when (symbolp x) (setq x (list x 3))) - (if (or (not (consp x)) - (not (consp (cdr x))) - (not (numberp (second x))) - (not (<= 0 (second x) 3))) - (warn "The OPTIMIZE proclamation ~s is illegal." x) - (case (car x) - (DEBUG (setq *debug* (second x))) - (SAFETY (setq *safety* (second x))) - (SPACE (setq *space* (second x))) - (SPEED (setq *speed* (second x))) - (COMPILATION-SPEED (setq *speed* (- 3 (second x)))) - (t (warn "The OPTIMIZE quality ~s is unknown." (car x))))))) - (TYPE - (if (consp (cdr decl)) - (proclaim-var (second decl) (cddr decl)) - (error "Syntax error in proclamation ~s" decl))) - (FTYPE - (if (atom (rest decl)) - (error "Syntax error in proclamation ~a" decl) - (multiple-value-bind (type-name args) - (si::normalize-type (second decl)) - (if (eq type-name 'FUNCTION) - (dolist (v (cddr decl)) - (add-function-proclamation v args)) - (error "In an FTYPE proclamation, found ~A which is not a function type." - (second decl)))))) - (INLINE - (dolist (fun (cdr decl)) - (if (si::valid-function-name-p fun) - (sys:rem-sysprop fun 'CMP-NOTINLINE) - (error "Not a valid function name ~s in proclamation ~s" fun decl)))) - (NOTINLINE - (dolist (fun (cdr decl)) - (if (si::valid-function-name-p fun) - (sys:put-sysprop fun 'CMP-NOTINLINE t) - (error "Not a valid function name ~s in proclamation ~s" fun decl)))) - ((OBJECT IGNORE DYNAMIC-EXTENT IGNORABLE) - ;; FIXME! IGNORED! - (dolist (var (cdr decl)) - (unless (si::valid-function-name-p var) - (error "Not a valid function name ~s in ~s proclamation" fun decl-name)))) - (DECLARATION - (validate-alien-declaration (rest decl) #'error) - (setf si::*alien-declarations* - (nconc (copy-list (rest decl)) si::*alien-declarations*))) - (SI::C-EXPORT-FNAME - (dolist (x (cdr decl)) - (cond ((symbolp x) - (multiple-value-bind (found c-name) - (si::mangle-name x t) - (if found - (warn "The function ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." x) - (sys:put-sysprop x 'Lfun c-name)))) - ((consp x) - (destructuring-bind (c-name lisp-name) x - (if (si::mangle-name lisp-name) - (warn "The funciton ~s is already in the runtime. C-EXPORT-FNAME declaration ignored." lisp-name) - (sys:put-sysprop lisp-name 'Lfun c-name)))) - (t - (error "Syntax error in proclamation ~s" decl))))) - ((ARRAY ATOM BASE-CHAR BIGNUM BIT BIT-VECTOR CHARACTER 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 - READTABLE SEQUENCE SHORT-FLOAT SIMPLE-ARRAY SIMPLE-BIT-VECTOR - SIMPLE-STRING SIMPLE-VECTOR SINGLE-FLOAT STANDARD-CHAR STREAM STRING - SYMBOL T VECTOR SIGNED-BYTE UNSIGNED-BYTE FUNCTION) - (proclaim-var decl-name (cdr decl))) - (otherwise - (cond ((multiple-value-bind (ok type) - (c-types:valid-type-specifier decl-name) - (when ok - (proclaim-var type (rest decl)) - t))) - ((let ((proclaimer (sys:get-sysprop (car decl) :proclaim))) - (when (functionp proclaimer) - (mapc proclaimer (rest decl)) - t))) - ((alien-declaration-p (first decl))) - (t - (warn "The declaration specifier ~s is unknown." decl-name)))))) - -(defun type-name-p (name) - (or (sys:get-sysprop name 'SI::DEFTYPE-DEFINITION) - (find-class name nil) - (sys:get-sysprop name 'SI::STRUCTURE-TYPE))) - -(defun validate-alien-declaration (names-list error) - (declare (si::c-local)) - (dolist (new-declaration names-list) - (unless (symbolp new-declaration) - (funcall error "The declaration ~s is not a symbol" new-declaration)) - (when (type-name-p new-declaration) - (funcall error "Symbol ~S cannot be both the name of a type and of a declaration" - new-declaration)))) - -(defun proclaim-var (type vl) - (setq type (c-types:type-filter type)) - (dolist (var vl) - (if (symbolp var) - (let* ((type1 (sys:get-sysprop var 'CMP-TYPE)) - (v (find var *undefined-vars* :key #'var-name)) - (merged (if type1 (type-and type1 type) type))) - (unless merged - (warn - "Proclamation for variable ~A of type~&~4T~A~&is incompatible with previous declaration~&~4~T~A" - var type type1) - (setq merged T)) - (sys:put-sysprop var 'CMP-TYPE merged) - (when v (setf (var-type v) merged))) - (warn "The variable name ~s is not a symbol." var)))) - -(defun c1body (body doc-p &aux - (all-declarations nil) - (ss nil) ; special vars - (is nil) ; ignored vars - (ts nil) ; typed vars (var . type) - (others nil) ; all other vars - doc form) - (loop - (when (endp body) (return)) - (setq form (cmp-macroexpand (car body))) - (cond - ((stringp form) - (when (or (null doc-p) (endp (cdr body)) doc) (return)) - (setq doc form)) - ((and (consp form) (eq (car form) 'DECLARE)) - (push form all-declarations) - (dolist (decl (cdr form)) - (cmpassert (and (proper-list-p decl) (symbolp (first decl))) - "Syntax error in declaration ~s" form) - (let* ((decl-name (first decl)) - (decl-args (rest decl))) - (flet ((declare-variables (type var-list) - (cmpassert (proper-list-p var-list #'symbolp) - "Syntax error in declaration ~s" decl) - (when type - (dolist (var var-list) - (push (cons var type) ts))))) - (case decl-name - (SPECIAL - (cmpassert (proper-list-p decl-args #'symbolp) - "Syntax error in declaration ~s" decl) - (setf ss (append decl-args ss))) - (IGNORE - (cmpassert (proper-list-p decl-args #'symbolp) - "Syntax error in declaration ~s" decl) - (setf is (append decl-args is))) - (TYPE - (cmpassert decl-args "Syntax error in declaration ~s" decl) - (declare-variables (first decl-args) (rest decl-args))) - (OBJECT - (declare-variables 'OBJECT decl-args)) - ;; read-only variable treatment. obsolete! - (:READ-ONLY - (push decl others)) - ((OPTIMIZE FTYPE INLINE NOTINLINE DECLARATION SI::C-LOCAL SI::C-GLOBAL - DYNAMIC-EXTENT IGNORABLE VALUES SI::NO-CHECK-TYPE - POLICY-DEBUG-IHS-FRAME) - (push decl others)) - (otherwise - (multiple-value-bind (ok type) - (c-types:valid-type-specifier decl-name) - (cmpassert ok "The declaration specifier ~s is unknown." decl-name) - (declare-variables type decl-args))) - ))))) - (t (return))) - (pop body)) - (values body ss ts is others doc all-declarations)) - -(defun default-optimization (optimization) - (ecase optimization - (speed *speed*) - (safety *safety*) - (space *space*) - (debug *debug*))) - -(defun search-optimization-quality (declarations what) - (dolist (i (reverse declarations) - (default-optimization what)) - (when (and (consp i) (eq (first i) 'policy-debug-ihs-frame) - (eq what 'debug)) - (return 2)) - (when (and (consp i) (eq (first i) 'optimize)) - (dolist (j (rest i)) - (cond ((consp j) - (when (eq (first j) what) - (return-from search-optimization-quality (second j)))) - ((eq j what) - (return-from search-optimization-quality 3))))))) - -(defun compute-optimizations (arguments env) - (let ((optimizations (cmp-env-all-optimizations env))) - (dolist (x arguments) - (when (symbolp x) (setq x (list x 3))) - (unless optimizations - (setq optimizations (cmp-env-all-optimizations))) - (if (or (not (consp x)) - (not (consp (cdr x))) - (not (numberp (second x))) - (not (<= 0 (second x) 3))) - (cmpwarn "The OPTIMIZE proclamation ~s is illegal." x) - (let ((value (second x))) - (case (car x) - (DEBUG (setf (first optimizations) value)) - (SAFETY (setf (second optimizations) value)) - (SPACE (setf (third optimizations) value)) - (SPEED (setf (fourth optimizations) value)) - (COMPILATION-SPEED) - (t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x))))))) - optimizations)) - -(defun add-declarations (decls &optional (env *cmp-env*)) - (dolist (decl decls) - (case (car decl) - (OPTIMIZE - (let ((optimizations (compute-optimizations (rest decl) env))) - (setf env (cmp-env-add-declaration 'optimize optimizations)))) - (POLICY-DEBUG-IHS-FRAME - (setf env (cmp-env-add-declaration 'optimize (compute-optimizations '(debug 2) env)))) - (FTYPE - (if (atom (rest decl)) - (cmpwarn "Syntax error in declaration ~a" decl) - (multiple-value-bind (type-name args) - (si::normalize-type (second decl)) - (if (eq type-name 'FUNCTION) - (dolist (v (cddr decl)) - (setf env (add-function-declaration v (first args) (rest args) env))) - (cmpwarn "In an FTYPE declaration, found ~A which is not a function type." - (second decl)))))) - (INLINE - (let* ((x (copy-list (cmp-env-search-declaration 'notinline))) - (names (rest decl))) - (dolist (fun names) - (unless (si::valid-function-name-p fun) - (cmperr "Not a valid function name ~s in declaration ~s" fun decl)) - (setf x (delete fun x :test #'same-fname-p))) - (setf env (cmp-env-add-declaration 'notinline x)))) - (NOTINLINE - (let* ((x (cmp-env-search-declaration 'notinline)) - (names (rest decl))) - (dolist (fun names) - (if (si::valid-function-name-p fun) - (push fun x) - (cmperr "Not a valid function name ~s in declaration ~s" fun decl))) - (setf env (cmp-env-add-declaration 'notinline x)))) - (DECLARATION - (validate-alien-declaration (rest decl) #'cmperr) - (cmp-env-extend-declarations 'alien (rest decl))) - ((SI::C-LOCAL SI::C-GLOBAL SI::NO-CHECK-TYPE)) - ((DYNAMIC-EXTENT IGNORABLE) - ;; FIXME! SOME ARE IGNORED! - ) - (:READ-ONLY) - (otherwise - (unless (alien-declaration-p (first decl)) - (cmpwarn "The declaration specifier ~s is unknown." (car decl)))))) - env) - -(defun check-vdecl (vnames ts is) - (dolist (x ts) - (unless (member (car x) vnames) - (cmpwarn "Type declaration was found for not bound variable ~s." - (car x)))) - (dolist (x is) - (unless (member x vnames) - (cmpwarn "Ignore declaration was found for not bound variable ~s." x)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; COMPILER ENVIRONMENT -;;; - -(defmacro cmp-env-new () - '(cons nil nil)) - -(defun cmp-env-copy (&optional (env *cmp-env*)) - (cons (car env) (cdr env))) - -(defmacro cmp-env-variables (&optional (env '*cmp-env*)) - `(car ,env)) - -(defmacro cmp-env-functions (&optional (env '*cmp-env*)) - `(cdr ,env)) - -(defun cmp-env-cleanups (env) - (loop with specials = '() - with end = (cmp-env-variables env) - with cleanup-forms = '() - with aux - for records-list on (cmp-env-variables *cmp-env*) - until (eq records-list end) - do (let ((record (first records-list))) - (cond ((atom record)) - ((and (symbolp (first record)) - (eq (second record) :special)) - (push (fourth record) specials)) - ((eq (first record) :cleanup) - (push (second record) cleanup-forms)))) - finally (progn - (unless (eq records-list end) - (error "Inconsistency in environment.")) - (return (values specials - (apply #'nconc (mapcar #'copy-list cleanup-forms))))))) - -(defun cmp-env-register-var (var &optional (env *cmp-env*) (boundp t)) - (push (list (var-name var) - (if (member (var-kind var) '(special global)) - :special - t) - boundp - var) - (cmp-env-variables env)) - env) - -(defun cmp-env-declare-special (name &optional (env *cmp-env*)) - (cmp-env-register-var (c::c1make-global-variable name :warn nil :kind 'SPECIAL) - env nil) - env) - -(defun cmp-env-add-declaration (type arguments &optional (env *cmp-env*)) - (push (list* :declare type arguments) - (cmp-env-variables env)) - env) - -(defun cmp-env-extend-declaration (type arguments &optional (env *cmp-env*)) - (let ((x (cmp-env-search-declaration type))) - (cmp-env-add-declaration type (append arguments x) env) - env)) - -(defun cmp-env-register-function (fun &optional (env *cmp-env*)) - (push (list (fun-name fun) 'function fun) - (cmp-env-functions env)) - env) - -(defun cmp-env-register-macro (name function &optional (env *cmp-env*)) - (push (list name 'si::macro function) - (cmp-env-functions env)) - env) - -(defun cmp-env-register-ftype (name declaration &optional (env *cmp-env*)) - (push (list* :declare name declaration) - (cmp-env-functions env)) - env) - -(defun cmp-env-register-symbol-macro (name form &optional (env *cmp-env*)) - (push (list name 'si::symbol-macro #'(lambda (whole env) form)) - (cmp-env-variables env)) - env) - -(defun cmp-env-register-block (blk &optional (env *cmp-env*)) - (push (list :block (blk-name blk) blk) - (cmp-env-variables env)) - env) - -(defun cmp-env-register-tag (name tag &optional (env *cmp-env*)) - (push (list :tag (list name) tag) - (cmp-env-variables env)) - env) - -(defun cmp-env-register-cleanup (form &optional (env *cmp-env*)) - (push (list :cleanup (copy-list form)) (cmp-env-variables env)) - env) - -(defun cmp-env-search-function (name &optional (env *cmp-env*)) - (let ((ccb nil) - (clb nil) - (unw nil) - (found nil)) - (dolist (record (cmp-env-functions env)) - (cond ((eq record 'CB) - (setf ccbb t)) - ((eq record 'LB) - (setf clb t)) - ((eq record 'UNWIND-PROTECT) - (setf unw t)) - ((atom record) - (baboon)) - ;; We have to use EQUAL because the name can be a list (SETF whatever) - ((equal (first record) name) - (setf found (first (last record))) - (return)))) - (values found ccb clb unw))) - -(defun cmp-env-search-variables (type name env) - (let ((ccb nil) - (clb nil) - (unw nil) - (found nil)) - (dolist (record (cmp-env-variables env)) - (cond ((eq record 'CB) - (setf ccb t)) - ((eq record 'LB) - (setf clb t)) - ((eq record 'UNWIND-PROTECT) - (setf unw t)) - ((atom record) - (baboon)) - ((not (eq (first record) type))) - ((eq type :block) - (when (eq name (second record)) - (setf found record) - (return))) - ((eq type :tag) - (when (member name (second record) :test #'eql) - (setf found record) - (return))) - ((eq (second record) 'si::symbol-macro) - (when (eq name 'si::symbol-macro) - (setf found record)) - (return)) - (t - (setf found record) - (return)))) - (values (first (last found)) ccb clb unw))) - -(defun cmp-env-search-block (name &optional (env *cmp-env*)) - (cmp-env-search-variables :block name env)) - -(defun cmp-env-search-tag (name &optional (env *cmp-env*)) - (cmp-env-search-variables :tag name env)) - -(defun cmp-env-search-symbol-macro (name &optional (env *cmp-env*)) - (cmp-env-search-variables name 'si::symbol-macro env)) - -(defun cmp-env-search-var (name &optional (env *cmp-env*)) - (cmp-env-search-variables name t env)) - -(defun cmp-env-search-macro (name &optional (env *cmp-env*)) - (let ((f (cmp-env-search-function name env))) - (if (functionp f) f nil))) - -(defun cmp-env-search-ftype (name &optional (env *cmp-env*)) - (dolist (i env nil) - (when (and (consp i) - (eq (pop i) :declare) - (same-fname-p (pop i) name)) - (return i)))) - -(defun cmp-env-mark (mark &optional (env *cmp-env*)) - (cons (cons mark (car env)) - (cons mark (cdr env)))) - -(defun cmp-env-new-variables (new-env old-env) - (loop for i in (ldiff (cmp-env-variables *cmp-env*) - (cmp-env-variables old-env)) - when (and (consp i) (var-p (fourth i))) - collect (fourth i))) - -(defun cmp-env-search-declaration (kind &optional (env *cmp-env*)) - (loop for i in (car env) - when (and (consp i) - (eq (first i) :declare) - (eq (second i) kind)) - return (cddr i))) - -(defun cmp-env-all-optimizations (&optional (env *cmp-env*)) - (or (cmp-env-search-declaration 'optimize) - (list *debug* *safety* *space* *speed*))) - -(defun cmp-env-optimization (property &optional (env *cmp-env*)) - (let ((x (cmp-env-all-optimizations env))) - (case property - (debug (first x)) - (safety (second x)) - (space (third x)) - (speed (fourth x))))) - -(defun policy-assume-right-type (&optional (env *cmp-env*)) - (< (cmp-env-optimization 'safety env) 2)) - -(defun policy-check-stack-overflow (&optional (env *cmp-env*)) - "Do we add a stack check to every function?" - (>= (cmp-env-optimization 'safety env) 2)) - -(defun policy-inline-slot-access-p (&optional (env *cmp-env*)) - "Do we inline access to structures and sealed classes?" - (or (< (cmp-env-optimization 'safety env) 2) - (<= (cmp-env-optimization 'safety env) (cmp-env-optimization 'speed env)))) - -(defun policy-check-all-arguments-p (&optional (env *cmp-env*)) - "Do we assume that arguments are the right type?" - (> (cmp-env-optimization 'safety env) 1)) - -(defun policy-automatic-check-type-p (&optional (env *cmp-env*)) - "Do we generate CHECK-TYPE forms for function arguments with type declarations?" - (and *automatic-check-type-in-lambda* - (>= (cmp-env-optimization 'safety env) 1))) - -(defun policy-assume-types-dont-change-p (&optional (env *cmp-env*)) - "Do we assume that type and class definitions will not change?" - (<= (cmp-env-optimization 'safety env) 1)) - -(defun policy-open-code-aref/aset-p (&optional (env *cmp-env*)) - "Do we inline access to arrays?" - (< (cmp-env-optimization 'debug env) 2)) - -(defun policy-open-code-accessors (&optional (env *cmp-env*)) - "Do we inline access to object slots, including conses and arrays?" - (< (cmp-env-optimization 'debug env) 2)) - -(defun policy-array-bounds-check-p (&optional (env *cmp-env*)) - "Check access to array bounds?" - (>= (cmp-env-optimization 'safety env) 1)) - -(defun policy-evaluate-forms (&optional (env *cmp-env*)) - "Pre-evaluate a function that takes constant arguments?" - (<= (cmp-env-optimization 'debug env) 1)) - -(defun alien-declaration-p (name) - (or (member name (cmp-env-search-declaration 'alien) :test #'eq) - (member name si:*alien-declarations*))) - -(defun policy-global-var-checking (&optional (env *cmp-env*)) - "Do we have to read the value of a global variable even if it is discarded? -Also, when reading the value of a global variable, should we ensure it is bound?" - (>= (cmp-env-optimization 'safety env) 1)) - -(defun policy-global-function-checking (&optional (env *cmp-env*)) - "Do we have to read the binding of a global function even if it is discarded?" - (>= (cmp-env-optimization 'safety env) 1)) - -(defun policy-debug-variable-bindings (&optional (env *cmp-env*)) - "Shall we create a vector with the bindings of each LET/LET*/LAMBDA form?" - ;; We can only create variable bindings when the function has an IHS frame!!! - (and (policy-debug-ihs-frame env) - (>= (cmp-env-optimization 'debug env) 3))) - -(defun policy-debug-ihs-frame (&optional (env *cmp-env*)) - "Shall we create an IHS frame so that this function shows up in backtraces?" - ;; Note that this is a prerequisite for registering variable bindings. Hence, - ;; it has to be recorded in a special variable. - (>= (fun-debug *current-function*) 2)) - -(defun policy-check-nargs (&optional (env *cmp-env*)) - (>= (cmp-env-optimization 'safety) 1)) - -(defmacro safe-compile () - `(>= (cmp-env-optimization 'safety) 2)) - diff --git a/src/new-cmp/cmplam.lsp b/src/new-cmp/cmplam.lsp index 6799e55e3..33c89401a 100644 --- a/src/new-cmp/cmplam.lsp +++ b/src/new-cmp/cmplam.lsp @@ -414,7 +414,6 @@ (defun exported-fname (name) (let (cname) (if (and (symbolp name) - (not (member name *notinline*)) (setf cname (get-sysprop name 'Lfun))) (values cname t) (values (next-cfun "L~D~A" name) nil)))) diff --git a/src/new-cmp/cmptype.lsp b/src/new-cmp/cmptype.lsp index 8e435a34d..46895ef64 100644 --- a/src/new-cmp/cmptype.lsp +++ b/src/new-cmp/cmptype.lsp @@ -14,301 +14,6 @@ (in-package "C-TYPES") -;;; CL-TYPE is any valid type specification of Common Lisp. -;;; -;;; TYPE is a representation type used by ECL. TYPE is one of: -;;; -;;; T(BOOLEAN) -;;; -;;; FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT -;;; (VECTOR T) STRING BIT-VECTOR (VECTOR FIXNUM) -;;; (VECTOR SINGLE-FLOAT) (VECTOR DOUBLE-FLOAT) -;;; (ARRAY T) (ARRAY BASE-CHAR) (ARRAY BIT) -;;; (ARRAY FIXNUM) -;;; (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) -;;; STANDARD-OBJECT STRUCTURE-OBJECT -;;; SYMBOL -;;; UNKNOWN -;;; -;;; NIL -;;; -;;; -;;; immediate-type: -;;; FIXNUM int -;;; CHARACTER char -;;; SINGLE-FLOAT float -;;; DOUBLE-FLOAT double - -(deftype any () 't) - -(defun member-type (type disjoint-supertypes) - (member type disjoint-supertypes :test #'subtypep)) - -(defun type-filter (type &optional values-allowed) - (multiple-value-bind (type-name type-args) (sys::normalize-type type) - (case type-name - ((FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT SYMBOL) type-name) - (SHORT-FLOAT #-short-float 'SINGLE-FLOAT #+short-float 'SHORT-FLOAT) - (LONG-FLOAT #-long-float 'DOUBLE-FLOAT #+long-float 'LONG-FLOAT) - ((SIMPLE-STRING STRING) 'STRING) - ((SIMPLE-BIT-VECTOR BIT-VECTOR) 'BIT-VECTOR) - ((NIL T) t) - ((SIMPLE-ARRAY ARRAY) - (cond ((endp type-args) '(ARRAY *)) ; Beppe - ((eq '* (car type-args)) t) - (t (let ((element-type (upgraded-array-element-type (car type-args))) - (dimensions (if (cdr type-args) (second type-args) '*))) - (if (and (not (eq dimensions '*)) - (or (numberp dimensions) - (= (length dimensions) 1))) - (case element-type - (BASE-CHAR 'STRING) - (BIT 'BIT-VECTOR) - (t (list 'VECTOR element-type))) - (list 'ARRAY element-type)))))) - (INTEGER (if (subtypep type 'FIXNUM) 'FIXNUM t)) - ((STREAM CONS) type-name) ; Juanjo - (FUNCTION type-name) - (t (cond ((eq type-name 'VALUES) - (unless values-allowed - (error "VALUES type found in a place where it is not allowed.")) - `(VALUES ,@(mapcar #'(lambda (x) - (if (or (eq x '&optional) - (eq x '&rest)) - x - (type-filter x))) - type-args))) - #+clos - ((subtypep type 'STANDARD-OBJECT) type) - #+clos - ((subtypep type 'STRUCTURE-OBJECT) type) - ((dolist (v '(FIXNUM CHARACTER SINGLE-FLOAT DOUBLE-FLOAT - #+short-float SHORT-FLOAT #+long-float LONG-FLOAT - (VECTOR T) STRING BIT-VECTOR - (VECTOR FIXNUM) (VECTOR SINGLE-FLOAT) - (VECTOR DOUBLE-FLOAT) (ARRAY BASE-CHAR) - (ARRAY BIT) (ARRAY FIXNUM) - (ARRAY SINGLE-FLOAT) (ARRAY DOUBLE-FLOAT) - (ARRAY T))) ; Beppe - (when (subtypep type v) (return v)))) - ((and (eq type-name 'SATISFIES) ; Beppe - (symbolp (car type-args)) - (sys:get-sysprop (car type-args) 'TYPE-FILTER))) - (t t)))))) - -(defun valid-type-specifier (type) - (handler-case - (if (subtypep type 'T) - (values t (type-filter type)) - (values nil nil)) - (error (c) (values nil nil)))) - -(defun known-type-p (type) - (subtypep type 'T)) - -(defun-equal-cached type-and (t1 t2) - ;; FIXME! Should we allow "*" as type name??? - (when (or (eq t1 t2) (eq t2 '*)) - (return-from type-and t1)) - (when (eq t1 '*) - (return-from type-and t2)) - (let* ((si::*highest-type-tag* si::*highest-type-tag*) - (si::*save-types-database* t) - (si::*member-types* si::*member-types*) - (si::*elementary-types* si::*elementary-types*) - (tag1 (si::safe-canonical-type t1)) - (tag2 (si::safe-canonical-type t2))) - (cond ((and (numberp tag1) (numberp tag2)) - (setf tag1 (si::safe-canonical-type t1) - tag2 (si::safe-canonical-type t2)) - (cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL - NIL) - ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 - t1) - ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 - t2) - (t - `(AND ,t1 ,t2)))) - ((eq tag1 'CONS) - (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) - t2) - ((eq tag2 'CONS) - (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) - t1) - ((null tag1) - (setf c::*compiler-break-enable* t) - ;(error "foo") - (cmpnote "Unknown type ~S. Assuming it is T." t1) - t2) - (t - (setf c::*compiler-break-enable* t) - ;(error "foo") - (cmpnote "Unknown type ~S. Assuming it is T." t2) - t1)))) - -(defun-equal-cached values-type-primary-type (type) - (when (and (consp type) (eq (first type) 'VALUES)) - (let ((subtype (second type))) - (when (or (eq subtype '&optional) (eq subtype '&rest)) - (setf type (cddr type)) - (when (or (null type) - (eq (setf subtype (first type)) '&optional) - (eq subtype '&rest)) - (cmperr "Syntax error in type expression ~S" type)) - ;; An &optional or &rest output value might be missing - ;; If this is the case, the the value will be NIL. - (setf subtype (type-or 'null subtype))) - (setf type subtype))) - type) - -(defun-equal-cached values-type-to-n-types (type length) - (if (or (atom type) (not (eql (first type) 'values))) - (list* type (make-list (1- length) :initial-element 'NULL)) - (do* ((l (rest type)) - (output '()) - (n length (1- n))) - ((or (null l) (zerop n)) (nreverse output)) - (let ((type (pop l))) - (case type - (&optional - (when (null l) - (cmperr "Syntax error in type expression ~S" type)) - (setf type (pop l))) - (&rest - (when (null l) - (cmperr "Syntax error in type expression ~S" type)) - (return-from values-type-to-n-types - (nreconc output (make-list n :initial-element (first l)))))) - (push type output))))) - -(defun split-values-type (type) - (if (or (atom type) (not (eq (first type) 'VALUES))) - (values (list type) nil nil) - (let ((rest (member '&rest type)) - (opt (member '&optional type))) - (values (ldiff (rest type) (or rest opt)) - (ldiff (rest (member '&optional type)) rest) - (rest (member '&rest type)))))) - -(defun-equal-cached values-type-or (t1 t2) - (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) - (return-from values-type-or t2)) - (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) - (return-from values-type-or t1)) - (unless t1 - (return-from values-type-or t2)) - (unless t2 - (return-from values-type-or t1)) - (multiple-value-bind (req1 opt1 rest1) - (split-values-type t1) - (multiple-value-bind (req2 opt2 rest2) - (split-values-type t2) - (let ((req '()) - (opt '()) - (rest '())) - (loop for t1 in req1 - do (cond (req2 - (push (type-or t1 (pop req2)) req)) - (opt2 - (push (type-or t1 (pop opt2)) opt)) - (rest2 - (push (type-or t1 (first rest2)) opt)) - (t - (push t1 opt)))) - (loop for t1 in opt1 - do (cond (req2 - (push (type-or t1 (pop req2)) opt)) - (opt2 - (push (type-or t1 (pop opt2)) opt)) - (rest2 - (push (type-or t1 (first rest2)) opt)) - (t - (push t1 opt)))) - (let ((t1 (if rest1 (first rest1) t))) - (loop for t2 in req2 - do (push (type-or t1 t2) opt)) - (loop for t2 in opt2 - do (push (type-or t1 t2) opt)) - (if rest2 - (setf rest (list (type-or t1 (first rest2)))) - (setf rest rest1))) - `(VALUES ,@(nreverse req) - ,@(and opt (cons '&optional (nreverse opt))) - ,@(and rest (cons '&optional rest))))))) - -(defun-equal-cached values-type-and (t1 t2) - (when (or (eq t2 'T) (equalp t2 '(VALUES &REST T))) - (return-from values-type-and t1)) - (when (or (eq t1 'T) (equalp t1 '(VALUES &REST T))) - (return-from values-type-and t2)) - (when (or (null t1) (null t2)) - (return-from values-type-and nil)) - (multiple-value-bind (req1 opt1 rest1) - (split-values-type t1) - (multiple-value-bind (req2 opt2 rest2) - (split-values-type t2) - (let ((req '()) - (opt '()) - (rest '())) - (loop for t1 in req1 - do (cond (req2 (push (type-and t1 (pop req2)) req)) - (opt2 (push (type-and t1 (pop opt2)) req)) - (rest2 (push (type-and t1 (first rest2)) req)) - (t (setf opt1 nil rest1 nil) (return)))) - (loop for t1 in opt1 - do (cond (req2 (push (type-and t1 (pop req2)) req)) - (opt2 (push (type-and t1 (pop opt2)) opt)) - (rest2 (push (type-and t1 (first rest2)) opt)) - (t (setf opt1 nil rest1 nil) (return)))) - (when rest - (let ((t1 (first rest))) - (loop for t2 in req2 - do (push (type-and t1 t2) req)) - (loop for t2 in opt2 - do (push (type-and t1 t2) opt)) - (when rest2 - (setf rest (list (type-and t1 (first rest2))))))) - `(VALUES ,@(nreverse req) - ,@(and opt (cons '&optional (nreverse opt))) - ,@(and rest (cons '&optional rest))))))) - -(defun-equal-cached type-or (t1 t2) - ;; FIXME! Should we allow "*" as type name??? - (when (or (eq t1 t2) (eq t2 '*)) - (return-from type-or t1)) - (when (eq t1 '*) - (return-from type-or t2)) - (let* ((si::*highest-type-tag* si::*highest-type-tag*) - (si::*save-types-database* t) - (si::*member-types* si::*member-types*) - (si::*elementary-types* si::*elementary-types*) - (tag1 (si::safe-canonical-type t1)) - (tag2 (si::safe-canonical-type t2))) - (cond ((and (numberp tag1) (numberp tag2)) - (setf tag1 (si::safe-canonical-type t1) - tag2 (si::safe-canonical-type t2)) - (cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2 - t2) - ((zerop (logandc2 tag2 tag1)) ; t2 <= t1 - t1) - (t - `(OR ,t1 ,t2)))) - ((eq tag1 'CONS) - (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1) - T) - ((eq tag2 'CONS) - (cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2) - T) - ((null tag1) - (cmpnote "Unknown type ~S" t1) - T) - (t - (cmpnote "Unknown type ~S" t2) - T)))) - -(defun type>= (type1 type2) - (subtypep type2 type1)) - ;;; ;;; and-form-type ;;; returns a copy of form whose type is the type-and of type and the form's @@ -337,234 +42,6 @@ (defun default-init-loc (var) (c1form-arg 0 (c1expr (default-init var)))) -;;---------------------------------------------------------------------- -;; (FUNCTION ...) types. This code is a continuation of predlib.lsp. -;; It implements function types and a SUBTYPEP relationship between them. -;; - -(in-package "SI") - -(defstruct function-type - required - optional - rest - key-p - keywords - keyword-types - allow-other-keys-p - output) - -(defun canonical-function-type (ftype) - (when (function-type-p ftype) - (return-from canonical-function-type ftype)) - (flet ((ftype-error () - (error "Syntax error in FUNCTION type definition ~S" ftype))) - (let (o k k-t values) - (unless (and (= (length ftype) 3) (eql (first ftype) 'FUNCTION)) - (ftype-error)) - (multiple-value-bind (requireds optionals rest key-flag keywords - allow-other-keys-p auxs) - (si::process-lambda-list (second ftype) 'FTYPE) - (dotimes (i (pop optionals)) - (let ((type (first optionals)) - (init (second optionals)) - (flag (third optionals))) - (setq optionals (cdddr optionals)) - (when (or init flag) (ftype-error)) - (push type o))) - (dotimes (i (pop keywords)) - (let ((keyword (first keywords)) - (var (second keywords)) - (type (third keywords)) - (flag (fourth keywords))) - (setq keywords (cddddr keywords)) - (when (or var flag) (ftype-error)) - (push keyword k) - (push type k-t))) - (setf values (third ftype)) - (cond ((atom values) (setf values (list 'VALUES values))) - ((and (listp values) (eql (first values) 'VALUES))) - (t (ftype-error))) - (when (and rest key-flag - (not (subtypep 'keyword rest))) - (ftype-error)) - (make-function-type :required (rest requireds) - :optional o - :rest rest - :key-p key-flag - :keywords k - :keyword-types k-t - :allow-other-keys-p allow-other-keys-p - :output (canonical-values-type values)))))) - -(defconstant +function-type-tag+ (cdr (assoc 'FUNCTION *elementary-types*))) - -(defun register-function-type (type) - (or (find-registered-tag type) - (find-registered-tag (setq ftype (canonical-function-type type))) - (let ((tag (register-type ftype #'function-type-p #'function-type-<=))) - (update-types +function-type-tag+ tag) - tag))) - -(defun function-type-<= (f1 f2) - (unless (and (every* #'subtypep - (function-type-required f2) - (function-type-required f1)) - (do* ((o1 (function-type-optional f1) (cdr o1)) - (o2 (function-type-optional f2) (cdr o2)) - (r1 (function-type-rest f1)) - (r2 (function-type-rest f2)) - t1 t2) - ((and (endp o1) (endp o2)) t) - (setf t1 (cond ((consp o1) (first o1)) - (r1 r1) - (t (return nil))) - t2 (cond ((consp o2) (first o2)) - (r2 r2) - (t (return nil)))) - (unless (subtypep t1 t2) - (return nil))) - (subtypep (function-type-output f1) - (function-type-output f2)) - (eql (function-type-key-p f1) (function-type-key-p f2)) - (or (function-type-allow-other-keys-p f2) - (not (function-type-allow-other-keys-p f1)))) - (return-from function-type-<= nil)) - (do* ((k2 (function-type-keywords f2)) - (k-t2 (function-type-keyword-types f2)) - (k1 (function-type-keywords f1) (cdr k1)) - (k-t1 (function-type-keyword-types f1) (cdr k1))) - ((endp k1) - t) - (unless - (let* ((n (position (first k1) k2))) - (when n - (let ((t2 (nth n k-t2))) - (subtypep (first k-t1) t2)))) - (return-from function-type-<= nil)))) - -;;---------------------------------------------------------------------- -;; (VALUES ...) type - -(defstruct values-type - min-values - max-values - required - optional - rest) - -(defun register-values-type (vtype) - (or (find-registered-tag vtype) - (find-registered-tag (setf vtype (canonical-values-type vtype))) - (register-type vtype #'values-type-p #'values-type-<=))) - -(defun canonical-values-type (vtype) - (when (values-type-p vtype) - (return-from canonical-values-type vtype)) - (flet ((vtype-error () - (error "Syntax error in VALUES type definition ~S" vtype))) - (unless (and (listp vtype) (eql (pop vtype) 'VALUES)) - (vtype-error)) - (let ((required '()) - (optional '()) - (rest nil)) - (do () - ((endp vtype) - (make-values-type :min-values (length required) - :max-values (if rest multiple-values-limit - (+ (length required) - (length optional))) - :required (nreverse required) - :optional (nreverse optional) - :rest rest)) - - (let ((type (pop vtype))) - (if (eql type '&optional) - (do () - ((endp vtype)) - (let ((type (pop vtype))) - (if (eql type '&rest) - (if (endp vtype) - (ftype-error) - (setf rest (first vtype))) - (push type optional)))) - (push type required))))))) - -(defun values-type-<= (v1 v2) - (and (= (values-type-min-values v1) (values-type-min-values v2)) - (= (values-type-max-values v1) (values-type-max-values v2)) - (every* #'subtypep (values-type-required v1) (values-type-required v2)) - (every* #'subtypep (values-type-optional v1) (values-type-optional v2)) - (subtypep (values-type-rest v1) (values-type-rest v2)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; TYPE PROPAGATORS -;;; - -(in-package "C-TYPES") - -(defun infer-arg-and-return-types (fname forms &optional (env *cmp-env*)) - (let ((found (sys:get-sysprop fname 'C1TYPE-PROPAGATOR)) - arg-types - (return-type '(VALUES &REST T))) - (cond (found - (multiple-value-setq (arg-types return-type) - (apply found fname (mapcar #'location-primary-type forms)))) - ((multiple-value-setq (arg-types found) - (get-arg-types fname env)) - (setf return-type (or (get-return-type fname) return-type)))) - (values arg-types return-type found))) - -(defun enforce-types (fname arg-types arguments) - (do* ((types arg-types (rest types)) - (args arguments (rest args)) - (i 1 (1+ i)) - (in-optionals nil)) - ((endp types) - (when types - (cmpwarn "Too many arguments passed to ~A" fname))) - (let ((expected-type (first types))) - (when (member expected-type '(* &rest &key &allow-other-keys) :test #'eq) - (return)) - (when (eq expected-type '&optional) - (when (or in-optionals (null (rest types))) - (cmpwarn "Syntax error in type proclamation for function ~A.~&~A" - fname arg-types)) - (setf in-optionals t - types (rest types) - expected-type (first types))) - (when (endp args) - (unless in-optionals - (cmpwarn "Too few arguments for proclaimed function ~A" fname)) - (return)) - (let* ((value (first args)) - (actual-type (location-primary-type value)) - (intersection (type-and actual-type expected-type))) - (unless intersection - (cmperr "The argument ~d of function ~a has type~&~4T~A~&instead of expected~&~4T~A" - i fname actual-type expected-type)))))) - -(defun propagate-types (fname forms) - (multiple-value-bind (arg-types return-type found) - (infer-arg-and-return-types fname forms) - (when found - (enforce-types fname arg-types forms)) - return-type)) - -(defmacro def-type-propagator (fname lambda-list &body body) - (unless (member '&rest lambda-list) - (let ((var (gensym))) - (setf lambda-list (append lambda-list (list '&rest var)) - body (list* `(declare (ignorable ,var)) body))) - `(sys:put-sysprop ',fname 'C1TYPE-PROPAGATOR - #'(ext:lambda-block ,fname ,lambda-list ,@body)))) - -(defun copy-type-propagator (orig dest-list) - (loop with function = (sys:get-sysprop orig 'C1TYPE-PROPAGATOR) - for name in dest-list - do (sys:put-sysprop name 'C1TYPE-PROPAGATOR function))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; TYPE CHECKING diff --git a/src/new-cmp/load.lsp.in b/src/new-cmp/load.lsp.in index e777b64c6..522e13b2d 100644 --- a/src/new-cmp/load.lsp.in +++ b/src/new-cmp/load.lsp.in @@ -2,21 +2,26 @@ (defconstant +cmp-module-files+ '("src:new-cmp;cmppackage.lsp" - "src:new-cmp;cmptypes.lsp" - "src:new-cmp;cmpglobals.lsp" - "build:new-cmp;cmpdefs.lsp" + "src:cmp;cmptypes.lsp" + "src:cmp;cmpglobals.lsp" + "build:cmp;cmpdefs.lsp" "src:new-cmp;cmptables.lsp" "src:new-cmp;cmpdata.lsp" "src:new-cmp;cmpmac.lsp" "src:new-cmp;cmpform.lsp" "src:new-cmp;cmploc.lsp" "src:cmp;cmputil.lsp" + "src:cmp;cmptype-arith.lsp" + "src:cmp;cmptype-prop.lsp" "src:new-cmp;cmptype.lsp" "src:new-cmp;cmptranslate.lsp" "src:new-cmp;cmpblock.lsp" "src:new-cmp;cmpcall.lsp" "src:new-cmp;cmpcatch.lsp" - "src:new-cmp;cmpenv.lsp" + "src:cmp;cmpenv-api.lsp" + "src:cmp;cmpenv-fun.lsp" + "src:cmp;cmpenv-decl.lsp" + "src:cmp;cmppolicy.lsp" "src:new-cmp;cmpeval.lsp" "src:new-cmp;cmpcffi.lsp" "src:new-cmp;cmpflet.lsp" @@ -41,7 +46,7 @@ "src:new-cmp;cmparray.lsp" "src:new-cmp;cmppass.lsp" "src:new-cmp;cmpc.lsp" - "src:new-cmp;cmpc-wt.lsp" + "src:cmp;cmpc-wt.lsp" "src:new-cmp;cmpc-loc.lsp" "src:new-cmp;cmpc-set.lsp" "src:new-cmp;cmpc-ffi.lsp" @@ -53,9 +58,10 @@ "src:new-cmp;cmpc-tables.lsp" "src:new-cmp;cmpc-cbk.lsp" "src:new-cmp;cmpc-top.lsp" - "src:new-cmp;cmpmain.lsp")) + "src:new-cmp;cmpmain.lsp" + "src:cmp;proclamations.lsp" + "src:cmp;sysfun.lsp")) (let ((si::*keep-documentation* nil)) - (mapc #'(lambda (x) (load x :verbose t)) +cmp-module-files+) - (load "src:new-cmp;sysfun" :verbose t)) + (mapc #'(lambda (x) (load x :verbose t)) +cmp-module-files+)) diff --git a/src/new-cmp/sysfun.lsp b/src/new-cmp/sysfun.lsp deleted file mode 100644 index f00bffa1d..000000000 --- a/src/new-cmp/sysfun.lsp +++ /dev/null @@ -1,2208 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*- -;;;; -;;; CMPSYSFUN Database for system functions. -;;; -;;; Copyright (c) 2003, Juan Jose Garcia Ripoll -;;; Copyright (c) 1991, Giuseppe Attardi. All rights reserved. -;;; Copying of this file is authorized to users who have executed the true -;;; and proper "License Agreement for ECoLisp". -;;; -;;; DATABASE OF FUNCTION PROCLAMATIONS AND INLINE EXPANSIONS -;;; -;;; What follows is the complete list of function type proclamations for the -;;; most important functions in the ECL core library, together with some useful -;;; inline expansions. -;;; -;;; The function proclamations are created with PROCLAIM-FUNCTION, as in -;;; -;;; (PROCLAIM-FUNCTION function-name ([arg-type]*) return-type -;;; &rest {:no-sp-change|:pure|:reader|:no-side-effects}) -;;; -;;; with the following interpretation: ARG-TYPE and RETURN-TYPE denote the most -;;; general types for the input and output values of this function. If the -;;; compiler detects that some of the values passed to this function does not -;;; match these types, it will generate an error. In addition to this, ECL -;;; contemplates different function properties: -;;; -;;; :NO-SP-CHANGE indicates that the function does not change the value of any -;;; special variable, and it is used to perform code transformations. -;;; -;;; :NO-SIDE-EFFECTS is slightly stronger, as it indicates that the function -;;; does not change variables or the content of objects in the -;;; thread environment. Note the following: -;;; -;;; - Allocating memory, creating objects, etc is not considered a side -;;; effect, as it does not affect the code flow. -;;; - Similarly, signalling errors is not considered a side effect. -;;; - The environment may be changed by other threads. This is taken -;;; into account (see below). -;;; -;;; :READER indicates that the function not only has no side effects, but its -;;; value depends only on its arguments. However, :READER specifies that -;;; the arguments are mutable. -;;; -;;; :PURE is the strictest class of functions. They have no side effects, the -;;; output only depends on the arguments, the arguments are inmutable -;;; objects and the function call can be optimized away when the -;;; arguments are constant. -;;; -;;; Inline expansions, on the other hand, have the following syntax -;;; -;;; (DEF-INLINE function-name kind ([arg-type]*) return-rep-type -;;; expansion-string) -;;; -;;; Here, ARG-TYPE is the list of argument types belonging to the lisp family, -;;; while RETURN-REP-TYPE is a representation type, i.e. the C type of the -;;; output expression. EXPANSION-STRING is a C/C++ expression template, like the -;;; ones used by C-INLINE. Finally, KIND can be :ALWAYS, :SAFE or :UNSAFE, -;;; depending on whether the inline expression should be applied always, in safe -;;; or in unsafe compilation mode, respectively. -;;; - -(in-package "C-DATA") -(export 'PROCLAIM-FUNCTION "C-DATA") - -(defmacro proclaim-function (&whole form name arg-types return-type &rest properties) - (when (sys:get-sysprop name 'proclaimed-arg-types) - (warn "Duplicate proclamation for ~A" name)) - (unless (or (equal arg-types '(*))) - (sys:put-sysprop name 'proclaimed-arg-types arg-types)) - (when (and return-type (not (eq 'T return-type))) - (sys:put-sysprop name 'proclaimed-return-type return-type)) - (loop for p in properties - do (case p - (:no-sp-change - (sys:put-sysprop name 'no-sp-change t)) - ((:predicate :pure) - (sys:put-sysprop name 'pure t) - (sys:put-sysprop name 'no-side-effects t)) - ((:no-side-effects :reader) - (sys:put-sysprop name 'no-side-effects t)) - (otherwise - (error "Unknown property ~S in function proclamation ~S" p form)))) - (sys:rem-sysprop name ':inline-always) - (sys:rem-sysprop name ':inline-safe) - (sys:rem-sysprop name ':inline-unsafe) - nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; AUXILIARY TYPES -;; - -(deftype string-designator () '(or string symbol character)) -(deftype natural () '(integer 0 *)) -(deftype function-name () '(or list symbol)) -(deftype function-designator () '(or symbol function)) -(deftype extended-function-designator () '(or function-name function)) -(deftype environment () 'list) -(deftype type-specifier () '(or symbol class list)) -(deftype gen-bool () "Generalized boolean type" 't) -(deftype format-control () "Format control for FORMAT" '(or string function)) -(deftype restart-designator () '(or (and symbol (not (member nil))) restart)) -(deftype package-designator () '(or string-designator package)) -(deftype byte-specifier () '(cons unsigned-byte unsigned-byte)) -(deftype character-designator () '(or string-designator character)) -(deftype radix () '(integer 2 36)) -(deftype digit-weight () '(integer 0 35)) -(deftype character-code () '(integer 0 #.(1- char-code-limit))) -(deftype tree () 't) -(deftype association-list () 'list) -(deftype bit-array () '(array bit)) -(deftype pathname-designator () '(or string pathname stream)) -(deftype pathname-host () '(or string list (member nil :unspecific))) -(deftype pathname-device () '(or string (member nil :unspecific))) -(deftype pathname-directory () '(or string list (member :wild :unspecific))) -(deftype pathname-name () '(or string (member nil :wild :unspecific))) -(deftype pathname-type () '(or string (member nil :wild :unspecific))) -(deftype pathname-version () '(or unsigned-byte (member nil :wild :newest :unspecific))) -(deftype universal-time () 'unsigned-byte) -(deftype time-zone () '(rational -24 24)) -(deftype stream-designator () '(or stream (member t nil))) -(deftype file-position-designator () '(or unsigned-byte (member :start :end))) -(deftype external-file-format () '(or symbol list)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; ALL FUNCTION DECLARATIONS -;;; -;;; -;;; ANSI SECTIONS -;;; -;;; 3. EVALUATION AND COMPILATION -;;; - -(proclaim-function compile (function-name &optional (or list function)) - (values (or function-name function) gen-bool gen-bool)) -(proclaim-function compiler-macro-function (function-name &optional environment) - function) -(proclaim-function constantp (t &optional environment) gen-bool :no-side-effects) -(proclaim-function eval (t) (values &rest t)) -(proclaim-function macro-function (symbol &optional environment) function) -(proclaim-function macroexpand (t &optional environment) (values t gen-bool)) -(proclaim-function macroexpand-1 (t &optional environment) (values t gen-bool)) -(proclaim-function proclaim (list) (values &rest t)) -(proclaim-function special-operator-p (symbol) gen-bool :pure) - -;; ECL extensions: -(proclaim-function si:specialp (symbol) gen-bool :predicate) - - -;;; -;;; 4. TYPES AND CLASSES -;;; - -(proclaim-function coerce (t type-specifier) t) -(proclaim-function subtypep (type-specifier type-specifier &optional environment) - (values gen-bool gen-bool)) -(proclaim-function type-of (t) type-specifier) -(proclaim-function typep (t type-specifier &optional environment) gen-bool) - -; Slot accessors: -; (proclaim-function type-error-datum (condition) t) -; (proclaim-function type-error-expected-type (condition) t) - - -;;; -;;; 5. DATA AND CONTROL FLOW -;;; - -(proclaim-function apply (function-designator &rest t) (values &rest t)) -(proclaim-function funcall (function-designator &rest t) (values &rest t)) -(proclaim-function fdefinition (function-name) (or list function (member 'SPECIAL))) -(proclaim-function fboundp (function-name) gen-bool :no-side-effects) -(proclaim-function fmakunbound (function-name) function-name) -(proclaim-function function-lambda-expression (function) (values list gen-bool t)) -(proclaim-function functionp (t) gen-bool :pure) -(proclaim-function compiled-function-p (t) gen-bool :pure) -(proclaim-function not (t) boolean :pure) -(proclaim-function eq (t t) gen-bool :pure) -(proclaim-function eql (t t) gen-bool :pure) -(proclaim-function equal (t t) gen-bool :pure) -(proclaim-function equalp (t t) gen-bool :pure) -(proclaim-function identity (t) t :no-side-effects) -(proclaim-function complement (function) function) -(proclaim-function constantly (t) function) -(proclaim-function every (function sequence &rest sequence) gen-bool) -(proclaim-function some (function sequence &rest sequence) t) -(proclaim-function notevery (function sequence &rest sequence) gen-bool) -(proclaim-function notany (function sequence &rest sequence) gen-bool) -(proclaim-function values-list (list) (values &rest t)) -(proclaim-function get-setf-expansion (t &optional enviroment) - (values t t t t t)) - -;; ECL extensions - -(proclaim-function si:fset (function-name function &optional gen-bool t) function) -(proclaim-function si:clear-compiler-properties (function-name) t) -(proclaim-function si:compiled-function-name (function) function-name) -(proclaim-function si:compiled-function-block (function) si::codeblock) -(proclaim-function si:compiled-function-file (function) t) - -(proclaim-function si:ihs-top () si::index) -(proclaim-function si:ihs-fun (si::index) (or null function-designator)) -(proclaim-function si:ihs-env (si::index) t) -(proclaim-function si:frs-top () si::index) -(proclaim-function si:frs-bds (si::index) si::index) -(proclaim-function si:frs-tag (si::index) t) -(proclaim-function si:frs-ihs (si::index) si::index) -(proclaim-function si:bds-top () si::index) -(proclaim-function si:bds-var (si::index) symbol) -(proclaim-function si:bds-val (si::index) t) -(proclaim-function si:sch-frs-base (si::index si::index) (or null si::index)) - - -;;; -;;; 7. OBJECTS -;;; - -(proclaim-function ensure-generic-function (function-name &rest t) generic-function) -(proclaim-function slot-boundp (si::instance symbol) gen-bool) -(proclaim-function slot-exists-p (si::instance symbol) gen-bool) -(proclaim-function slot-makunbound (si::instance symbol) si::instance) -(proclaim-function slot-value (si::instance symbol) t) -(proclaim-function make-load-form-saving-slots (t &rest t) (values t t)) -(proclaim-function find-class (symbol &optional environment t) (or class null)) -(proclaim-function class-of (t) class :no-side-effects) - -;; Slot accessors: -; (proclaim-function unbound-slot-instance (condition) si::instance :predicate) - - -;;; -;;; 8. STRUCTURES -;;; - -(proclaim-function copy-structure (t) t) - -;; ECL extensions -(proclaim-function si:make-structure (t &rest t) structure-object) -(proclaim-function si:structure-name (structure-object) symbol :reader) -(proclaim-function si:structure-ref (structure-object t fixnum) t :reader) -(proclaim-function si:structure-set (structure-object t fixnum t) t) -(proclaim-function si:structurep (t) gen-bool :predicate) -(proclaim-function si:structure-subtype-p (t t) gen-bool :predicate) - - -;;; -;;; 9. CONDITIONS -;;; - -(proclaim-function error (t &rest t) (values)) -;; FIXME! It is not clear from the specification whether CERROR actually -;; returns values. However ECL is actually using the fact that it returns -;; the value from CONTINUE. -(proclaim-function cerror (format-control t &rest t) (values &rest t)) -(proclaim-function invalid-method-error (method format-control &rest t) (values)) -(proclaim-function method-combination-error (method format-control &rest t) (values)) -(proclaim-function signal (t &rest t) null) -(proclaim-function warn (t &rest t) null) -(proclaim-function invoke-debugger (condition) (values)) -(proclaim-function break (&optional format-control &rest t) null) -(proclaim-function make-condition (type-specifier &rest t) condition) -(proclaim-function compute-restarts (&optional condition) list) -(proclaim-function find-restart (restart-designator &optional condition) restart) -(proclaim-function invoke-restart (restart-designator &rest t) (values &rest t)) -(proclaim-function invoke-restart-interactively (restart-designator) (values &rest t)) -(proclaim-function abort (&optional condition) (values)) -(proclaim-function continue (&optional condition) null) -(proclaim-function muffle-warning (&optional condition) (values)) -(proclaim-function store-value (value &optional condition) null) -(proclaim-function use-value (value &optional condition) null) - -;; Slot accessors: -;; (proclaim-function cell-error-name (cell-error) t) -;; (proclaim-function simple-condition-format-control (simple-condition) t) -;; (proclaim-function simple-condition-format-arguments (simple-condition) t) -;; (proclaim-function restart-name (restart) t) - -;; ECL extensions -(proclaim-function ext:catch-signal (fixnum gen-bool) null) - - -;;; -;;; 10. SYMBOLS -;;; - -(proclaim-function symbolp (t) gen-bool :pure) -(proclaim-function keywordp (t) gen-bool :pure) -(proclaim-function make-symbol (string) symbol) -(proclaim-function copy-symbol (symbol &optional gen-bool) symbol) -(proclaim-function gensym (&optional (or string natural)) symbol) -(proclaim-function gentemp (&optional string package-designator) symbol) -(proclaim-function symbol-function (symbol) (or list (member 'special) function)) -(proclaim-function symbol-name (symbol) string :pure) -(proclaim-function symbol-package (symbol) (or package null) :reader) -(proclaim-function symbol-plist (symbol) list :reader) -(proclaim-function symbol-value (symbol) t :reader) -(proclaim-function get (symbol t &optional t) t :no-side-effects) -(proclaim-function remprop (symbol t) gen-bool) -(proclaim-function boundp (symbol) gen-bool :no-side-effects) -(proclaim-function makunbound (symbol) symbol) -(proclaim-function set (symbol t) symbol) - -;; ECL extensions: -(proclaim-function si:*make-special (symbol) symbol) -(proclaim-function si:*make-constant (symbol t) symbol) -(proclaim-function si:put-f (list t t) list) -(proclaim-function si:rem-f (list t) boolean) -(proclaim-function si:set-symbol-plist (symbol t) t) -(proclaim-function si:putprop (symbol t t) t) -(proclaim-function si:put-sysprop (t t t) t) -(proclaim-function si:get-sysprop (t t t) t) -(proclaim-function si:rem-sysprop (t t) t) - - -;;; -;;; 11. PACKAGES -;;; - -(proclaim-function export (list &optional package) t) -(proclaim-function find-symbol (string &optional package-designator) - (values symbol symbol)) -(proclaim-function find-package (package-designator) (or package null)) -(proclaim-function find-all-symbols (string) list) -(proclaim-function import (list &optional package-designator) t) -(proclaim-function list-all-packages () list) -(proclaim-function rename-package (package-designator package-designator - &optional list) package) -(proclaim-function shadow (list &optional package-designator) t) -(proclaim-function shadowing-import (list &optional package-designator) t) -(proclaim-function delete-package (package-designator) gen-bool) -(proclaim-function make-package (string-designator &rest t) package) -(proclaim-function unexport (list &optional package-designator) t) -(proclaim-function unintern (symbol &optional package-designator) gen-bool) -(proclaim-function unuse-package (list &optional package-designator) t) -(proclaim-function use-package (list &optional package-designator) t) -(proclaim-function intern (string &optional package-designator) (values symbol symbol)) -(proclaim-function package-name (package-designator) (or string null) :reader) -(proclaim-function package-nicknames (package-designator) list :reader) -(proclaim-function package-shadowing-symbols (package-designator) list :reader) -(proclaim-function package-use-list (package-designator) list :reader) -(proclaim-function package-used-by-list (package-designator) list :reader) -(proclaim-function packagep (t) gen-bool :pure) - -;; Slot accessor: -;; (proclaim-function package-error-package (condition) package) - -;; ECL extensions -(proclaim-function si:select-package (package-designator) package) -(proclaim-function si:package-hash-tables (package-designator) - (values hash-table hash-table list) :reader) -(proclaim-function si:package-lock (package-designator gen-bool) package) - - -;;; -;;; 12. NUMBERS -;;; - -(proclaim-function = (number &rest number) gen-bool :pure) -(proclaim-function /= (number &rest number) gen-bool :pure) -(proclaim-function < (real &rest real) gen-bool :pure) -(proclaim-function > (real &rest real) gen-bool :pure) -(proclaim-function <= (real &rest real) gen-bool :pure) -(proclaim-function >= (real &rest real) gen-bool :pure) -(proclaim-function max (real &rest real) real :pure) -(proclaim-function min (real &rest real) real :pure) -(proclaim-function minusp (real) gen-bool :pure) -(proclaim-function plusp (real) gen-bool :pure) -(proclaim-function zerop (number) gen-bool :pure) -(proclaim-function floor (real &optional real) (values integer real) :pure) -(proclaim-function ceiling (real &optional real) (values integer real) :pure) -(proclaim-function truncate (real &optional real) (values integer real) :pure) -(proclaim-function round (real &optional real) (values integer real) :pure) -(proclaim-function ffloor (real &optional real) (values float real) :pure) -(proclaim-function fceiling (real &optional real) (values float real) :pure) -(proclaim-function ftruncate (real &optional real) (values float real) :pure) -(proclaim-function fround (real &optional real) (values float real) :pure) -(proclaim-function cos (number) number :pure) -(proclaim-function sin (number) number :pure) -(proclaim-function tan (number) number :pure) -(proclaim-function cosh (number) number :pure) -(proclaim-function sinh (number) number :pure) -(proclaim-function tanh (number) number :pure) -(proclaim-function acos (number) number :pure) -(proclaim-function asin (number) number :pure) -(proclaim-function atan (number &optional real) number :pure) -(proclaim-function acosh (number) number :pure) -(proclaim-function asinh (number) number :pure) -(proclaim-function atanh (number) number :pure) -(proclaim-function * (&rest number) number :pure) -(proclaim-function + (&rest number) number :pure) -(proclaim-function - (&rest number) number :pure) -(proclaim-function / (&rest number) number :pure) -(proclaim-function 1+ (number) number :pure) -(proclaim-function 1- (number) number :pure) -(proclaim-function abs (number) (real 0 *) :pure) -(proclaim-function evenp (integer) gen-bool :pure) -(proclaim-function oddp (integer) gen-bool :pure) -(proclaim-function exp (number) number :pure) -(proclaim-function expt (number number) number :pure) -(proclaim-function gcd (&rest integer) unsigned-byte :pure) -(proclaim-function lcm (&rest integer) unsigned-byte :pure) -(proclaim-function log (number &optional number) number :pure) -(proclaim-function mod (real real) real :pure) -(proclaim-function rem (real real) real :pure) -(proclaim-function signum (number) number :pure) -(proclaim-function sqrt (number) number :pure) -(proclaim-function isqrt (unsigned-byte) unsigned-byte :pure) -(proclaim-function make-random-state (&optional (or random-state (member nil t))) - random-state) -(proclaim-function random ((or (integer 0 *) (float 0 *)) - &optional random-state) - (or (integer 0 *) (float 0 *))) -(proclaim-function random-state-p (t) gen-bool :pure) -(proclaim-function numberp (t) gen-bool :pure) -(proclaim-function cis (real) complex :pure) -(proclaim-function complex (real &optional real) number :pure) -(proclaim-function complexp (t) gen-bool :pure) -(proclaim-function conjugate (number) number :pure) -(proclaim-function phase (number) number :pure) -(proclaim-function realpart (number) real :pure) -(proclaim-function imagpart (number) real :pure) -(proclaim-function upgraded-complex-part-type - (type-specifier &optional environment) - type-specifier) -(proclaim-function realp (t) gen-bool :pure) -(proclaim-function numerator (rational) integer :pure) -(proclaim-function denominator (rational) unsigned-byte :pure) -(proclaim-function rational (real) rational :pure) -(proclaim-function rationalize (real) rational :pure) -(proclaim-function rationalp (t) gen-bool :pure) -(proclaim-function ash (integer integer) integer :pure) -(proclaim-function integer-length (integer) unsigned-byte :pure) -(proclaim-function integerp (t) gen-bool :pure) -(proclaim-function parse-integer (string &rest t) (values integer si::index)) -(proclaim-function boole ((integer 0 15) integer integer) integer :pure) -(proclaim-function logand (&rest integer) integer :pure) -(proclaim-function logandc1 (integer integer) integer :pure) -(proclaim-function logandc2 (integer integer) integer :pure) -(proclaim-function logeqv (&rest integer) integer :pure) -(proclaim-function logior (&rest integer) integer :pure) -(proclaim-function lognand (integer integer) integer :pure) -(proclaim-function lognor (integer integer) integer :pure) -(proclaim-function lognot (integer) integer :pure) -(proclaim-function logorc1 (integer integer) integer :pure) -(proclaim-function logorc2 (integer integer) integer :pure) -(proclaim-function logxor (&rest integer) integer :pure) -(proclaim-function logbitp (unsigned-byte integer) gen-bool :pure) -(proclaim-function logcount (integer) unsigned-byte :pure) -(proclaim-function logtest (integer integer) gen-bool :pure) -(proclaim-function byte (unsigned-byte unsigned-byte) byte-specifier :pure) -(proclaim-function byte-size (byte-specifier) unsigned-byte :pure) -(proclaim-function byte-position (byte-specifier) unsigned-byte :pure) -(proclaim-function deposit-field (integer byte-specifier integer) integer :pure) -(proclaim-function dpb (integer byte-specifier integer) integer :pure) -(proclaim-function ldb (byte-specifier integer) unsigned-byte :pure) -(proclaim-function ldb-test (byte-specifier integer) gen-bool :pure) -(proclaim-function mask-field (byte-specifier integer) unsigned-byte :pure) -(proclaim-function decode-float (float) (values float integer float) :pure) -(proclaim-function scale-float (float integer) float :pure) -(proclaim-function float-radix (float) fixnum :pure) -(proclaim-function float-sign (float &optional float) float :pure) -(proclaim-function float-digits (float) fixnum :pure) -(proclaim-function float-precision (float) fixnum :pure) -(proclaim-function integer-decode-float (float) - (values float integer (member -1 1)) - :pure) -(proclaim-function float (number &optional float) float :pure) -(proclaim-function floatp (t) gen-bool :pure) - -;; Slot accessors: -;; (proclaim-function arithmetic-error-operands (condition) t) -;; (proclaim-function arithmetic-error-operation (condition) t) - -;; ECL extensions -(proclaim-function si:bit-array-op (t t t t) t) - - -;;; -;;; 13. CHARACTERS -;;; - -(proclaim-function char= (character &rest character) gen-bool :pure) -(proclaim-function char/= (character &rest character) gen-bool :pure) -(proclaim-function char< (character &rest character) gen-bool :pure) -(proclaim-function char> (character &rest character) gen-bool :pure) -(proclaim-function char<= (character &rest character) gen-bool :pure) -(proclaim-function char>= (character &rest character) gen-bool :pure) -(proclaim-function char-equal (character &rest character) gen-bool :pure) -(proclaim-function char-not-equal (character &rest character) gen-bool :pure) -(proclaim-function char-lessp (character &rest character) gen-bool :pure) -(proclaim-function char-greaterp (character &rest character) gen-bool :pure) -(proclaim-function char-not-greaterp (character &rest character) gen-bool :pure) -(proclaim-function char-not-lessp (character &rest character) gen-bool :pure) -(proclaim-function character (character-designator) character) -(proclaim-function characterp (t) gen-bool :pure) -(proclaim-function alpha-char-p (character) gen-bool :pure) -(proclaim-function alphanumericp (character) gen-bool :pure) -(proclaim-function digit-char (digit-weight &optional radix) character :pure) -(proclaim-function digit-char-p (character &optional radix) - (or digit-weight null) - :pure) -(proclaim-function graphic-char-p (character) gen-bool :pure) -(proclaim-function standard-char-p (character) gen-bool :pure) -(proclaim-function char-upcase (character) character :pure) -(proclaim-function char-downcase (character) character :pure) -(proclaim-function upper-case-p (character) gen-bool :pure) -(proclaim-function lower-case-p (character) gen-bool :pure) -(proclaim-function both-case-p (character) gen-bool :pure) -(proclaim-function char-code (character) character-code :pure) -(proclaim-function char-int (character) character-code :pure) -(proclaim-function code-char (character-code) (or character null) :pure) -(proclaim-function char-name (character) (or string null) :pure) -(proclaim-function name-char (string-designator) (or character null) :pure) - -;; ECL extensions -(proclaim-function si:base-char-p (t) gen-bool :predicate) - - -;;; -;;; 14. CONSES -;;; - -(proclaim-function cons (t t) cons :no-side-effects) -(proclaim-function consp (t) gen-bool :pure) -(proclaim-function atom (t) gen-bool :pure) -(proclaim-function rplaca (cons t) cons) -(proclaim-function rplacd (cons t) cons) -(proclaim-function car (list) t :reader) -(proclaim-function cdr (list) t :reader) -(proclaim-function caar (list) t :reader) -(proclaim-function cadr (list) t :reader) -(proclaim-function cdar (list) t :reader) -(proclaim-function cddr (list) t :reader) -(proclaim-function caaar (list) t :reader) -(proclaim-function caadr (list) t :reader) -(proclaim-function cadar (list) t :reader) -(proclaim-function caddr (list) t :reader) -(proclaim-function cdaar (list) t :reader) -(proclaim-function cdadr (list) t :reader) -(proclaim-function cddar (list) t :reader) -(proclaim-function cdddr (list) t :reader) -(proclaim-function caaaar (list) t :reader) -(proclaim-function caaadr (list) t :reader) -(proclaim-function caadar (list) t :reader) -(proclaim-function caaddr (list) t :reader) -(proclaim-function cadaar (list) t :reader) -(proclaim-function cadadr (list) t :reader) -(proclaim-function caddar (list) t :reader) -(proclaim-function cadddr (list) t :reader) -(proclaim-function cdaaar (list) t :reader) -(proclaim-function cdaadr (list) t :reader) -(proclaim-function cdadar (list) t :reader) -(proclaim-function cdaddr (list) t :reader) -(proclaim-function cddaar (list) t :reader) -(proclaim-function cddadr (list) t :reader) -(proclaim-function cdddar (list) t :reader) -(proclaim-function cddddr (list) t :reader) -(proclaim-function copy-tree (tree) tree :no-side-effects) -(proclaim-function sublis (association-list tree &key) tree :no-side-effects) -(proclaim-function nsublis (association-list tree &key) tree) -(proclaim-function subst (t t tree &key) tree :no-side-effects) -(proclaim-function subst-if (t function-designator tree &key) tree) -(proclaim-function subst-if-not (t function-designator tree &key) tree) -(proclaim-function nsubst (t t tree &key) tree) -(proclaim-function nsubst-if (t function-designator tree &key) tree) -(proclaim-function nsubst-if-not (t function-designator tree &key) tree) -(proclaim-function tree-equal (tree tree &key) gen-bool :predicate) -(proclaim-function copy-list (list) list :no-side-effects) -(proclaim-function list (&rest t) list :no-side-effects) -(proclaim-function list* (&rest t) t :no-side-effects) -(proclaim-function list-length (list) (or null si::index) :no-side-effects) -(proclaim-function listp (t) gen-bool :pure) -(proclaim-function make-list (si::index &key) list) -(proclaim-function first (list) t :reader) -(proclaim-function second (list) t :reader) -(proclaim-function third (list) t :reader) -(proclaim-function fourth (list) t :reader) -(proclaim-function fifth (list) t :reader) -(proclaim-function sixth (list) t :reader) -(proclaim-function seventh (list) t :reader) -(proclaim-function eighth (list) t :reader) -(proclaim-function ninth (list) t :reader) -(proclaim-function tenth (list) t :reader) -(proclaim-function nth (unsigned-byte list) t :reader) -(proclaim-function endp (list) gen-bool :predicate) -(proclaim-function null (t) gen-bool :predicate) -(proclaim-function nconc (*) t) -(proclaim-function append (*) t :no-side-effects) -(proclaim-function revappend (list t) t :no-side-effects) -(proclaim-function nreconc (list t) t) -(proclaim-function butlast (list &optional unsigned-byte) list :no-side-effects) -(proclaim-function nbutlast (list &optional unsigned-byte) list :no-side-effects) -(proclaim-function last (list &optional unsigned-byte) list :reader) -(proclaim-function ldiff (list t) list :no-side-effects) -(proclaim-function tailp (t list) gen-bool :reader) -(proclaim-function nthcdr (fixnum list) t :no-side-effects) -(proclaim-function rest (list) t :no-side-effects) -(proclaim-function member (t list &key) list :no-side-effects) -(proclaim-function member-if (function-designator list &key) list) -(proclaim-function member-if-not (function-designator list &key) list) -(proclaim-function mapc (function-designator list &rest list) list) -(proclaim-function mapcar (function-designator list &rest list) list) -(proclaim-function mapcan (function-designator list &rest list) list) -(proclaim-function mapl (function-designator list &rest list) list) -(proclaim-function maplist (function-designator list &rest list) list) -(proclaim-function mapcon (function-designator list &rest list) list) -(proclaim-function acons (t t association-list) association-list :no-side-effects) -(proclaim-function assoc (t association-list &key) t :no-side-effects) -(proclaim-function assoc-if (function-designator association-list &key) t) -(proclaim-function assoc-if-not (function-designator association-list &key) t) -(proclaim-function copy-alist (association-list) association-list :no-side-effects) -(proclaim-function pairlis (list list &optional association-list) - association-list :no-side-effects) -(proclaim-function rassoc (t association-list &key) t :no-side-effects) -(proclaim-function rassoc-if (function-designator association-list &key) t) -(proclaim-function rassoc-if-not (function-designator association-list &key) t) -(proclaim-function get-properties (list list) (values t t list) :no-side-effects) -(proclaim-function getf (list t &optional t) t :no-side-effects) -(proclaim-function intersection (list list &key) list :no-side-effects) -(proclaim-function nintersection (list list &key) list) -(proclaim-function adjoin (t list &key) list :no-side-effects) -(proclaim-function set-difference (list list &key) list :no-side-effects) -(proclaim-function nset-difference (list list &key) list) -(proclaim-function set-exclusive-or (list list &key) list :no-side-effects) -(proclaim-function nset-exclusive-or (list list &key) list) -(proclaim-function subsetp (list list &key) gen-bool :predicate) -(proclaim-function union (list list &key) list :no-side-effects) -(proclaim-function nunion (list list &key) list) - -;; ECL extensions -(proclaim-function member1 (t list t t t) t) -(proclaim-function si:memq (t list) t) - - -;;; -;;; 15. ARRAYS -;;; - -(proclaim-function make-array ((or si::index list) &key) array) -(proclaim-function adjust-array (array (or si::index list) &key) array) -(proclaim-function adjustable-array-p (array) gen-bool :pure) -(proclaim-function aref (array &rest si::index) t :reader) -(proclaim-function array-dimension (array (integer 0 #.(1- array-rank-limit))) - si::index :reader) -(proclaim-function array-dimensions (array) list :reader) -(proclaim-function array-element-type (array) type-specifier :pure) -(proclaim-function array-has-fill-pointer-p (array) gen-bool :pure) -(proclaim-function array-displacement (array) (values (or array null) si::index) - :reader) -(proclaim-function array-in-bounds-p (array &rest si::index) gen-bool - :no-side-effects) -(proclaim-function array-rank (array) (integer 0 #.(1- array-rank-limit)) - :reader) -(proclaim-function array-row-major-index (array &rest si::index) si::index - :no-side-effects) -(proclaim-function array-total-size (array) si::index :reader) -(proclaim-function arrayp (t) gen-bool :pure) -(proclaim-function fill-pointer (vector) si::index :reader) -(proclaim-function row-major-aref (array si::index) t :reader) -(proclaim-function upgraded-array-element-type - (type-specifier &optional environment) - type-specifier :no-side-effects) -(proclaim-function simple-vector-p (t) gen-bool :pure) -(proclaim-function svref (simple-vector si::index) t :reader) -(proclaim-function vector (&rest t) vector :no-side-effects) -(proclaim-function vector-pop (vector) t) -(proclaim-function vector-push (t vector) (or si::index null)) -(proclaim-function vector-push-extend (t vector &optional si::index) si::index) -(proclaim-function vectorp (t) gen-bool :pure) -(proclaim-function bit ((array bit) &rest si::index) bit :reader) -(proclaim-function sbit ((simple-array bit) &rest si::index) - bit :reader) -(proclaim-function bit-and (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-andc1 (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-andc2 (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-eqv (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-ior (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-nand (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-nor (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-orc1 (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-orc2 (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-xor (bit-array bit-array &optional - (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-not (bit-array &optional (or bit-array (member t nil))) - bit-array) -(proclaim-function bit-vector-p (t) gen-bool :pure) -(proclaim-function simple-bit-vector-p (t) t :pure) - -;; ECL extensions -(proclaim-function si:make-pure-array (*) array) -(proclaim-function si:make-vector (*) vector) -(proclaim-function si:aset (t array &rest si::index) t) -(proclaim-function si:row-major-aset (array si::index t) t) -(proclaim-function si:svset (simple-vector si::index t) t) -(proclaim-function si:fill-pointer-set (vector si::index) si::index) -(proclaim-function si:replace-array (array array) array) - - -;;; -;;; 16. STRINGS -;;; - -(proclaim-function simple-string-p (t) gen-bool :pure) -(proclaim-function char (string si::index) character :reader) -(proclaim-function schar (simple-string si::index) character :reader) -(proclaim-function string (string-designator) string :no-side-effects) -(proclaim-function string-upcase (string-designator &key) - string :no-side-effects) -(proclaim-function string-downcase (string-designator &key) - string :no-side-effects) -(proclaim-function string-capitalize (string-designator &key) - string :no-side-effects) -(proclaim-function nstring-upcase (string &key) string) -(proclaim-function nstring-downcase (string &key) string) -(proclaim-function nstring-capitalize (string &key) string) -(proclaim-function string-trim (sequence string-designator) - string :no-side-effects) -(proclaim-function string-left-trim (sequence string-designator) - string :no-side-effects) -(proclaim-function string-right-trim (sequence string-designator) - string :no-side-effects) -(proclaim-function string= (string-designator string-designator &key) - gen-bool :no-side-effects) -(proclaim-function string/= (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function string< (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function string> (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function string<= (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function string>= (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function string-equal (string-designator string-designator &key) - gen-bool :no-side-effects) -(proclaim-function string-not-equal (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function string-lessp (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function string-greaterp (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function string-not-lessp (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function string-not-greaterp (string-designator string-designator &key) - (or si::index null) :no-side-effects) -(proclaim-function stringp (t) gen-bool :predicate) -(proclaim-function make-string (si::index &key) string :no-side-effects) - -;; ECL extensions: -(proclaim-function si:base-string-p (t) gen-bool :predicate) -(proclaim-function si:char-set (string si::index character) character) -(proclaim-function si:schar-set (string si::index character) character) -(proclaim-function si:base-string-concatenate (base-string) base-string) - - -;;; -;;; 17. SEQUENCES -;;; - -(proclaim-function copy-seq (sequence) sequence :no-side-effects) -(proclaim-function elt (sequence si::index) t :no-side-effects) -(proclaim-function fill (sequence t &key) sequence) -(proclaim-function make-sequence (type-specifier si::index &key) sequence) -(proclaim-function subseq (sequence si::index &optional (or si::index null)) - sequence) -(proclaim-function map (type-specifier function-designator sequence &rest sequence) - sequence) -(proclaim-function map-into (sequence function-designator sequence &rest sequence) - sequence) -(proclaim-function reduce (function-designator sequence &key) t) -(proclaim-function count (t sequence &key) si::index :no-side-effects) -(proclaim-function count-if (function-designator sequence &key) si::index) -(proclaim-function count-if-not (function-designator sequence &key) si::index) -(proclaim-function length (sequence) si::index :no-side-effects) -(proclaim-function reverse (sequence) sequence :no-side-effects) -(proclaim-function nreverse (sequence) sequence) -(proclaim-function sort (sequence function-designator &key) sequence) -(proclaim-function stable-sort (sequence function-designator &key) sequence) -(proclaim-function find (t sequence &key) t :no-side-effects) -(proclaim-function find-if (function-designator sequence &key) t) -(proclaim-function find-if-not (function-designator sequence &key) t) -(proclaim-function position (t sequence &key) (or null si::index) :no-side-effects) -(proclaim-function position-if (function-designator sequence &key) - (or null si::index)) -(proclaim-function position-if-not (function-designator sequence &key) - (or null si::index)) -(proclaim-function search (sequence sequence &key) - (or null si::index) :no-side-effects) -(proclaim-function mismatch (sequence sequence &key) - (or null si::index) :no-side-effects) -(proclaim-function replace (sequence sequence &key) sequence) -(proclaim-function substitute (t t sequence &key) sequence :no-side-effects) -(proclaim-function substitute-if (t function-designator sequence &key) sequence) -(proclaim-function substitute-if-not (t function-designator sequence &key) sequence) -(proclaim-function nsubstitute (t t sequence &key) sequence) -(proclaim-function nsubstitute-if (t function-designator sequence &key) sequence) -(proclaim-function nsubstitute-if-not (t function-designator sequence &key) sequence) -(proclaim-function concatenate (type-specifier &rest sequence) sequence - :no-side-effects) -(proclaim-function merge (type-specifier sequence sequence function-designator &key) - sequence) -(proclaim-function remove (t sequence &key) sequence :no-side-effects) -(proclaim-function remove-if (function-designator sequence &key) sequence) -(proclaim-function remove-if-not (function-designator sequence &key) sequence) -(proclaim-function delete (t sequence &key) sequence) -(proclaim-function delete-if (function-designator sequence &key) sequence) -(proclaim-function delete-if-not (function-designator sequence &key) sequence) -(proclaim-function remove-duplicates (sequence &key) sequence :no-side-effects) -(proclaim-function delete-duplicates (sequence &key) sequence) - -;; ECL extensions: -(proclaim-function si:elt-set (sequence si::index t) t) -(proclaim-function si::make-seq-iterator (t *) t :no-side-effects) -(proclaim-function si::seq-iterator-ref (t t) t :reader) -(proclaim-function si::seq-iterator-set (t t t) t :no-sp-change) -(proclaim-function si::seq-iterator-next (t t) t :reader) - - -;;; -;;; 18. HASH TABLES -;;; - -(proclaim-function make-hash-table (&key) hash-table :no-side-effects) -(proclaim-function hash-table-p (t) gen-bool :pure) -(proclaim-function hash-table-count (hash-table) si::index :reader) -(proclaim-function hash-table-rehash-size (hash-table) - (or (integer 1 *) (float (1.0) *)) - :reader) -(proclaim-function hash-table-rehash-threshold (hash-table) - (float (1.0) *) - :reader) -(proclaim-function hash-table-size (hash-table) si::index :reader) -(proclaim-function hash-table-test (hash-table) function-designator :reader) -(proclaim-function gethash (t hash-table &key) (values t gen-bool) :reader) -(proclaim-function remhash (t hash-table) gen-bool) -(proclaim-function maphash (function-designator hash-table) null) -(proclaim-function clrhash (hash-table) hash-table) -(proclaim-function sxhash (t) (integer 0 #.most-positive-fixnum) :no-side-effects) - -;; ECL extensions -(proclaim-function si:hash-set (t hash-table t) t) - - -;;; -;;; 19. FILENAMES -;;; - -(proclaim-function pathname (pathname-designator) pathname) -(proclaim-function make-pathname (&key) pathname) -(proclaim-function pathnamep (t) gen-bool :pure) -(proclaim-function pathname-host (pathname) pathname-host :reader) -(proclaim-function pathname-device (pathname) pathname-device :reader) -(proclaim-function pathname-directory (pathname) pathname-directory :reader) -(proclaim-function pathname-name (pathname) pathname-name :reader) -(proclaim-function pathname-type (pathname) pathname-type :reader) -(proclaim-function pathname-version (pathname) pathname-version :reader) -(proclaim-function load-logical-pathname-translations (string) gen-bool) -(proclaim-function logical-pathname-translations (string) list) -(proclaim-function logical-pathname (pathname-designator) logical-pathname) -(proclaim-function namestring (pathname-designator) (or string null)) -(proclaim-function file-namestring (pathname-designator) (or string null)) -(proclaim-function directory-namestring (pathname-designator) (or string null)) -(proclaim-function host-namestring (pathname-designator) (or string null)) -(proclaim-function enough-namestring (pathname-designator - &optional pathname-designator) - (or string null)) -(proclaim-function parse-namestring (pathname-designator - &optional pathname-host - pathname-designator &key) - (values (or pathname null) (or si::index null))) -(proclaim-function wild-pathname-p (pathname-designator - &optional (member :host :device :directory :name - :type :version nil)) - gen-bool) -(proclaim-function pathname-match-p (pathname-designator pathname-designator) - gen-bool) -(proclaim-function translate-logical-pathname (pathname-designator &key) pathname) -(proclaim-function translate-pathname (pathname-designator pathname-designator - pathname-designator &key) - pathname) -(proclaim-function merge-pathnames (pathname-designator - &optional pathname-designator - pathname-version) - pathname) - -;;; -;;; 20. FILES -;;; - -(proclaim-function directory (pathname-designator &key) list) -(proclaim-function probe-file (pathname-designator) (or pathname null)) -(proclaim-function ensure-directories-exist (pathname &key) - (values pathname gen-bool)) -(proclaim-function truename (pathname-designator) pathname) -(proclaim-function file-author (pathname-designator) (or string null)) -(proclaim-function file-write-date (pathname-designator) (or unsigned-byte null)) -(proclaim-function rename-file (pathname-designator pathname-designator) - (values pathname pathname pathname)) -(proclaim-function delete-file (pathname-designator) t) - -;; Slot accessors: -;; (proclaim-function file-error-pathname (condition) pathname-designator) - -;; ECL extensions -(proclaim-function ext:file-kind (pathname-designator gen-bool) symbol) -(proclaim-function ext:chdir (pathname-designator &optional gen-bool) pathname) -(proclaim-function ext:getcwd (&optional gen-bool) pathname) -(proclaim-function ext:mkdir (pathname-designator fixnum) string) -(proclaim-function ext:mkstemp (pathname-designator) (or null pathname)) -(proclaim-function ext:rmdir (pathname-designator) null) -(proclaim-function ext:copy-file (pathname-designator pathname-designator) gen-bool) - - -;;; -;;; 21. STREAMS -;;; - -(proclaim-function input-stream-p (stream) gen-bool :reader) -(proclaim-function output-stream-p (stream) gen-bool :reader) -(proclaim-function interactive-stream-p (stream) gen-bool :reader) -(proclaim-function open-stream-p (stream) gen-bool :reader) -(proclaim-function stream-element-type (stream) type-specifier :reader) -(proclaim-function streamp (t) gen-bool :pure) -(proclaim-function read-byte (stream &optional gen-bool t) t) -(proclaim-function write-byte (integer stream) integer) -(proclaim-function peek-char (&optional (or character boolean) - stream-designator - gen-bool - t - gen-bool) - t) -(proclaim-function read-char (&optional stream-designator gen-bool t gen-bool) t) -(proclaim-function read-char-no-hang (&optional stream-designator gen-bool t gen-bool) t) -(proclaim-function terpri (&optional stream-designator) null) -(proclaim-function fresh-line (&optional stream-designator) gen-bool) -(proclaim-function unread-char (character &optional stream-designator) null) -(proclaim-function write-char (character &optional stream-designator) character) -(proclaim-function read-line (&optional stream-designator gen-bool t gen-bool) - (values t gen-bool)) -(proclaim-function write-string (string &optional stream-designator &key) string) -(proclaim-function write-line (string &optional stream-designator &key) string) -(proclaim-function read-sequence (sequence stream &key) si::index) -(proclaim-function write-sequence (sequence stream &key) sequence) -(proclaim-function file-length (stream) unsigned-byte) -(proclaim-function file-position (stream file-position-designator) gen-bool) -(proclaim-function file-string-length (stream (or string character)) - (or unsigned-byte null)) -(proclaim-function open (pathname-designator &key) (or stream null)) -(proclaim-function stream-external-format (stream) external-file-format :reader) -(proclaim-function close (stream &key) t) -(proclaim-function listen (&optional stream-designator) gen-bool) -(proclaim-function clear-input (&optional stream-designator) null) -(proclaim-function finish-output (&optional stream-designator) null) -(proclaim-function force-output (&optional stream-designator) null) -(proclaim-function clear-output (&optional stream-designator) null) -(proclaim-function y-or-n-p (&optional format-control &rest t) gen-bool) -(proclaim-function yes-or-no-p (&optional format-control &rest t) gen-bool) -(proclaim-function make-synonym-stream (symbol) synonym-stream) -(proclaim-function synonym-stream-symbol (synonym-stream) symbol :reader) -(proclaim-function broadcast-stream-streams (broadcast-stream) list :reader) -(proclaim-function make-broadcast-stream (&rest stream) broadcast-stream) -(proclaim-function make-two-way-stream (stream stream) two-way-stream) -(proclaim-function two-way-stream-input-stream (two-way-stream) - stream :reader) -(proclaim-function two-way-stream-output-stream (two-way-stream) - stream :reader) -(proclaim-function echo-stream-output-stream (echo-stream) stream :reader) -(proclaim-function echo-stream-input-stream (echo-stream) stream :reader) -(proclaim-function make-echo-stream (stream stream) echo-stream) -(proclaim-function concatenated-stream-streams (concatenated-stream) - list :reader) -(proclaim-function make-concatenated-stream (&rest stream) concatenated-stream) -(proclaim-function get-output-stream-string (string-stream) - string :reader) -(proclaim-function make-string-input-stream (string &optional - (or si::index null) - (or si::index null)) - string-stream) -(proclaim-function make-string-output-stream (&key) string-stream) - -;; Slot accessors: -;; (proclaim-function stream-error-stream (condition) stream) - -;; ECL extensions: -(proclaim-function si:make-string-output-stream-from-string (string) string-stream) -(proclaim-function si:open-client-stream (t unsigned-byte) stream) -(proclaim-function si:open-server-stream (unsigned-byte) stream) -(proclaim-function si:open-unix-socket-stream (base-string) stream) -(proclaim-function si:lookup-host-entry (t) (values (or null string) list list)) - - -;;; -;;; 22. PRINT -;;; - -(proclaim-function copy-pprint-dispatch (&optional (or si::pprint-dispatch-table null)) - si::pprint-dispatch-table) -(proclaim-function pprint-dispatch (t &optional (or si::pprint-dispatch-table null)) - (values function-designator gen-bool)) -(proclaim-function pprint-fill (stream-designator t &optional gen-bool gen-bool) - null) -(proclaim-function pprint-linear (stream-designator t &optional gen-bool gen-bool) - null) -(proclaim-function pprint-tabular (stream-designator t &optional gen-bool gen-bool - unsigned-byte) - null) -(proclaim-function pprint-indent ((member :block :current) real - &optional stream-designator) - null) -(proclaim-function pprint-newline ((member :linear :fill :miser :mandatory) - &optional stream-designator) - null) -(proclaim-function pprint-tab ((member :line :section :line-relative :section-relative) - unsigned-byte unsigned-byte &optional stream-designator) - null) -(proclaim-function set-pprint-dispatch (type-specifier function-designator - &optional real si::pprint-dispatch-table) - null) -(proclaim-function write (t &key) t) -(proclaim-function prin1 (t &optional stream-designator) t) -(proclaim-function princ (t &optional stream-designator) t) -(proclaim-function print (t &optional stream-designator) t) -(proclaim-function pprint (t &optional stream-designator) (values)) -(proclaim-function write-to-string (t &key) string) -(proclaim-function prin1-to-string (t) string) -(proclaim-function princ-to-string (t) string) -(proclaim-function format ((or stream-designator t) format-control &rest t) - (or null string)) - -;; Slot accessor: -;; (proclaim-function print-not-readable-object (condition) t) - - -;;; -;;; 23. READER -;;; - -(proclaim-function copy-readtable (&optional readtable-designator (or readtable null)) - readtable) -(proclaim-function make-dispatch-macro-character - (character &optional gen-bool readtable) - (member t)) -(proclaim-function read (&optional stream-designator gen-bool t gen-bool) t) -(proclaim-function read-preserving-whitespace - (&optional stream-designator gen-bool t gen-bool) t) -(proclaim-function read-delimited-list (character &optional stream-designator gen-bool) - list) -(proclaim-function read-from-string (string &optional gen-bool t &key) - (values t si::index)) -(proclaim-function readtable-case (readtable) - (member :upcase :downcase :preserve :invert) - :reader) -(proclaim-function readtablep (t) gen-bool :pure) -(proclaim-function get-dispatch-macro-character - (character character &optional readtable-designator) - (or function-designator null) - :reader) -(proclaim-function set-dispatch-macro-character - (character character function-designator - &optional readtable-designator) - (member t)) -(proclaim-function get-macro-character - (character &optional readtable-designator) - (values (or function-designator null) gen-bool) - :reader) -(proclaim-function set-macro-character - (character function-designator - &optional gen-bool readtable-designator) - (member t)) -(proclaim-function set-syntax-from-char - (character character &optional readtable readtable-designator) - (member t)) - -;; ECL extensions: -(proclaim-function si:string-to-object (string &optional t) t) -(proclaim-function si:standard-readtable () readtable) - - -;;; -;;; 24. SYSTEM CONSTRUCTION -;;; - -(proclaim-function compile-file (pathname-designator &key) - (values (or pathname null) gen-bool gen-bool)) -(proclaim-function compile-file-pathname (pathname-designator &key) - pathname) -(proclaim-function load ((or stream pathname-designator) &key) gen-bool) -(proclaim-function provide (string-designator) t) -(proclaim-function require (string-designatior &optional list) t) - - -;;; -;;; 25. ENVIRONMENT -;;; - -(proclaim-function decode-universal-time (universal-time &optional time-zone) - (values (integer 0 59) - (integer 0 59) - (integer 0 23) - (integer 1 31) - (integer 1 12) - unsigned-byte - (integer 0 6) - gen-bool - time-zone) - :pure) -(proclaim-function encode-universal-time ((integer 0 59) - (integer 0 59) - (integer 0 23) - (integer 1 31) - (integer 1 12) - unsigned-byte - &optional time-zone) - universal-time - :pure) -(proclaim-function get-universal-time () universal-time) -(proclaim-function get-decoded-time () - (values (integer 0 59) - (integer 0 59) - (integer 0 23) - (integer 1 31) - (integer 1 12) - unsigned-byte - (integer 0 6) - gen-bool - time-zone)) -(proclaim-function sleep ((real 0 *)) null) -(proclaim-function apropos (string-designator &optional (or null package-designator)) - (values)) -(proclaim-function apropos-list - (string-designator &optional (or null package-designator)) - list) -(proclaim-function describe (t &optional stream-designator) (values)) -(proclaim-function get-internal-real-time () unsigned-byte) -(proclaim-function get-internal-run-time () unsigned-byte) -(proclaim-function disassemble ((or function-designator list)) null) -(proclaim-function room (&optional (member t nil :default)) (values &rest t)) -(proclaim-function ed (&optional (or null pathname string function-name)) - (values &rest t)) -(proclaim-function inspect (t) (values &rest t)) -(proclaim-function dribble (&optional pathname-designator) (values &rest t)) -(proclaim-function lisp-implementation-type () (or string null)) -(proclaim-function lisp-implementation-version () (or string null)) -(proclaim-function short-site-name () (or string null)) -(proclaim-function long-site-name () (or string null)) -(proclaim-function machine-instance () (or string null)) -(proclaim-function machine-type () (or string null)) -(proclaim-function machine-version () (or string null)) -(proclaim-function software-type () (or string null)) -(proclaim-function software-version () (or string null)) -(proclaim-function user-homedir-pathname (&optional pathname-host) - (or pathname null)) - -;; ECL extensions - -(proclaim-function si::room-report () (values t t t t t t t t)) -(proclaim-function si::reset-gbc-count () t) -(proclaim-function ext:gc (&optional gen-bool) t) -(proclaim-function ext:quit (&optional fixnum) t) -(proclaim-function ext:argc () si::index) -(proclaim-function ext:argv () list) -(proclaim-function ext:getenv (string) (or null string)) -(proclaim-function ext:environ () list) -(proclaim-function ext:system (string) fixnum) -(proclaim-function ext:getpid () fixnum) -(proclaim-function ext:make-pipe () (or two-way-stream null)) -(proclaim-function ext:run-program (string list &key) - (values (or null two-way-stream) - (or null integer))) - -;;; -;;; A. FFI -;;; - -(proclaim-function si:pointer (t) unsigned-byte) -(proclaim-function si:foreign-data-p (t) gen-bool :predicate) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; INLINE EXPANSIONS -;;; - -(in-package "C-BACKEND") - -(defmacro def-inline (name safety arg-types return-rep-type expansion - &key (one-liner t) (exact-return-type nil) - &aux arg-rep-types) - (setf safety - (case safety - (:unsafe :inline-unsafe) - (:safe :inline-safe) - (:always :inline-always) - (t (error "In DEF-INLINE, wrong value of SAFETY")))) - (setf arg-rep-types - (mapcar #'(lambda (x) (if (eq x '*) x (lisp-type->rep-type x))) - arg-types)) - (when (eq return-rep-type t) - (setf return-rep-type :object)) - (let* ((return-type (if (and (consp return-rep-type) - (eq (first return-rep-type) 'values)) - t - (rep-type->lisp-type return-rep-type))) - (inline-info - (make-inline-info :name name - :arg-rep-types arg-rep-types - :return-rep-type return-rep-type - :return-type return-type - :arg-types arg-types - :exact-return-type exact-return-type - ;; :side-effects (not (get-sysprop name 'no-side-effects)) - :one-liner one-liner - :expansion expansion)) - (previous (sys:get-sysprop name safety))) - #+(or) - (loop for i in previous - when (and (equalp (inline-info-arg-types i) arg-types) - (not (equalp return-type (inline-info-return-type i)))) - do (format t "~&;;; Redundand inline definition for ~A~&;;; ~<~A~>~&;;; ~<~A~>" - name i inline-info)) - (sys:put-sysprop name safety (cons inline-info previous))) - nil) - -(def-inline aref :unsafe (t t t) t - "@0;ecl_aref_unsafe(#0,fix(#1)*(#0)->array.dims[1]+fix(#2))") -(def-inline aref :unsafe ((array t) t t) t - "@0;(#0)->array.self.t[fix(#1)*(#0)->array.dims[1]+fix(#2)]") -(def-inline aref :unsafe ((array bit) t t) :fixnum - "@0;ecl_aref_bv(#0,fix(#1)*(#0)->array.dims[1]+fix(#2))") -(def-inline aref :unsafe ((array t) fixnum fixnum) t - "@0;(#0)->array.self.t[#1*(#0)->array.dims[1]+#2]") -(def-inline aref :unsafe ((array bit) fixnum fixnum) :fixnum - "@0;ecl_aref_bv(#0,(#1)*(#0)->array.dims[1]+#2)") -(def-inline aref :unsafe ((array base-char) fixnum fixnum) :char - "@0;(#0)->base_string.self[#1*(#0)->array.dims[1]+#2]") -(def-inline aref :unsafe ((array double-float) fixnum fixnum) :double - "@0;(#0)->array.self.df[#1*(#0)->array.dims[1]+#2]") -(def-inline aref :unsafe ((array single-float) fixnum fixnum) :float - "@0;(#0)->array.self.sf[#1*(#0)->array.dims[1]+#2]") -(def-inline aref :unsafe ((array fixnum) fixnum fixnum) :fixnum - "@0;(#0)->array.self.fix[#1*(#0)->array.dims[1]+#2]") - -(def-inline aref :always (t t) t "ecl_aref1(#0,fixint(#1))") -(def-inline aref :always (t fixnum) t "ecl_aref1(#0,#1)") -(def-inline aref :unsafe (t t) t "ecl_aref1(#0,fix(#1))") -(def-inline aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,fix(#1))") -(def-inline aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") -#+unicode -(def-inline aref :unsafe ((array character) fixnum) :wchar - "(#0)->string.self[#1]") -(def-inline aref :unsafe ((array base-char) fixnum) :char - "(#0)->base_string.self[#1]") -(def-inline aref :unsafe ((array double-float) fixnum) :double - "(#0)->array.self.df[#1]") -(def-inline aref :unsafe ((array single-float) fixnum) :float - "(#0)->array.self.sf[#1]") -(def-inline aref :unsafe ((array fixnum) fixnum) :fixnum - "(#0)->array.self.fix[#1]") - -(def-inline si:aset :unsafe (t t t t) t - "@0;ecl_aset_unsafe(#1,fix(#2)*(#1)->array.dims[1]+fix(#3),#0)") -(def-inline si:aset :unsafe (t t fixnum fixnum) t - "@0;ecl_aset_unsafe(#1,(#2)*(#1)->array.dims[1]+(#3),#0)") -(def-inline si:aset :unsafe (t (array t) fixnum fixnum) t - "@1;(#1)->array.self.t[#2*(#1)->array.dims[1]+#3]= #0") -(def-inline si:aset :unsafe (t (array bit) fixnum fixnum) :fixnum - "@0;ecl_aset_bv(#1,(#2)*(#1)->array.dims[1]+(#3),fix(#0))") -(def-inline si:aset :unsafe (base-char (array base-char) fixnum fixnum) :char - "@1;(#1)->base_string.self[#2*(#1)->array.dims[1]+#3]= #0") -#+unicode -(def-inline si:aset :unsafe (character (array character) fixnum fixnum) :wchar - "@1;(#1)->string.self[#2*(#1)->array.dims[1]+#3]= #0") -(def-inline si:aset :unsafe (double-float (array double-float) fixnum fixnum) - :double "@1;(#1)->array.self.df[#2*(#1)->array.dims[1]+#3]= #0") -(def-inline si:aset :unsafe (single-float (array single-float) fixnum fixnum) - :float "@1;(#1)->array.self.sf[#2*(#1)->array.dims[1]+#3]= #0") -(def-inline si:aset :unsafe (fixnum (array fixnum) fixnum fixnum) :fixnum - "@1;(#1)->array.self.fix[#2*(#1)->array.dims[1]+#3]= #0") -(def-inline si:aset :unsafe (fixnum (array bit) fixnum fixnum) :fixnum - "@0;ecl_aset_bv(#1,(#2)*(#1)->array.dims[1]+(#3),#0)") -(def-inline si:aset :always (t t t) t "ecl_aset1(#1,fixint(#2),#0)") -(def-inline si:aset :always (t t fixnum) t "ecl_aset1(#1,#2,#0)") -(def-inline si:aset :unsafe (t t t) t "ecl_aset1(#1,fix(#2),#0)") -(def-inline si:aset :unsafe (t (array t) fixnum) t - "(#1)->vector.self.t[#2]= #0") -(def-inline si:aset :unsafe (t (array bit) fixnum) :fixnum - "ecl_aset_bv(#1,#2,fix(#0))") -(def-inline si:aset :unsafe (base-char (array base-char) fixnum) :char - "(#1)->base_string.self[#2]= #0") -#+unicode -(def-inline si:aset :unsafe (character (array character) fixnum) :wchar - "(#1)->string.self[#2]= #0") -(def-inline si:aset :unsafe (double-float (array double-float) fixnum) :double - "(#1)->array.self.df[#2]= #0") -(def-inline si:aset :unsafe (single-float (array single-float) fixnum) :float - "(#1)->array.self.sf[#2]= #0") -(def-inline si:aset :unsafe (fixnum (array fixnum) fixnum) :fixnum - "(#1)->array.self.fix[#2]= #0") -(def-inline si:aset :unsafe (fixnum (array bit) fixnum) :fixnum - "ecl_aset_bv(#1,#2,#0)") - -(def-inline row-major-aref :always (t t) t "ecl_aref(#0,fixint(#1))") -(def-inline row-major-aref :always (t fixnum) t "ecl_aref(#0,#1)") -(def-inline row-major-aref :unsafe (t t) t "ecl_aref_unsafe(#0,fix(#1))") -(def-inline row-major-aref :unsafe (t fixnum) t "ecl_aref_unsafe(#0,#1)") -(def-inline row-major-aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,fix(#1))") -(def-inline row-major-aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") -#+unicode -(def-inline row-major-aref :unsafe ((array character) fixnum) :wchar - "(#0)->string.self[#1]") -(def-inline row-major-aref :unsafe ((array base-char) fixnum) :char - "(#0)->base_string.self[#1]") -(def-inline row-major-aref :unsafe ((array double-float) fixnum) :double - "(#0)->array.self.df[#1]") -(def-inline row-major-aref :unsafe ((array single-float) fixnum) :float - "(#0)->array.self.sf[#1]") -(def-inline row-major-aref :unsafe ((array fixnum) fixnum) :fixnum - "(#0)->array.self.fix[#1]") - -(def-inline si:row-major-aset :always (t t t) t "ecl_aset(#0,fixint(#1),#2)") -(def-inline si:row-major-aset :always (t fixnum t) t "ecl_aset(#0,#1,#2)") -(def-inline si:row-major-aset :unsafe (t t t) t "ecl_aset_unsafe(#0,fix(#1),#2)") -(def-inline si:row-major-aset :unsafe (t fixnum t) t "ecl_aset_unsafe(#0,#1,#2)") -(def-inline si:row-major-aset :unsafe ((array t) fixnum t) t - "(#0)->vector.self.t[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array bit) fixnum t) :fixnum - "ecl_aset_bv(#0,#1,fix(#2))") -(def-inline si:row-major-aset :unsafe ((array bit) fixnum fixnum) :fixnum - "ecl_aset_bv(#0,#1,#2)") -(def-inline si:row-major-aset :unsafe ((array base-char) fixnum base-char) :char - "(#0)->base_string.self[#1]= #2") -#+unicode -(def-inline si:row-major-aset :unsafe ((array character) fixnum character) :wchar - "(#0)->string.self[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array double-float) fixnum double-float) :double - "(#0)->array.self.df[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array single-float) fixnum single-float) :float - "(#0)->array.self.sf[#1]= #2") -(def-inline si:row-major-aset :unsafe ((array fixnum) fixnum fixnum) :fixnum - "(#0)->array.self.fix[#1]= #2") - -(def-inline array-rank :unsafe (array) :fixnum - "(#0)->array.rank") - -(def-inline array-dimension :always (t t) fixnum - "ecl_array_dimension(#0,fixint(#1))") -(def-inline array-dimension :always (t fixnum) fixnum - "ecl_array_dimension(#0,#1)") - -(def-inline array-total-size :unsafe (t) :fixnum "((#0)->array.dim)") - -(def-inline svref :always (t t) t "ecl_aref1(#0,fixint(#1))") -(def-inline svref :always (t fixnum) t "ecl_aref1(#0,#1)") -(def-inline svref :unsafe (t t) t "(#0)->vector.self.t[fix(#1)]") -(def-inline svref :unsafe (t fixnum) t "(#0)->vector.self.t[#1]") - -(def-inline si:svset :always (t t t) t "ecl_aset1(#0,fixint(#1),#2)") -(def-inline si:svset :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") -(def-inline si:svset :unsafe (t t t) t "((#0)->vector.self.t[fix(#1)]=(#2))") -(def-inline si:svset :unsafe (t fixnum t) t "(#0)->vector.self.t[#1]= #2") - -(def-inline fill-pointer :unsafe (t) :fixnum "((#0)->vector.fillp)") - -(def-inline si:fill-pointer-set :unsafe (t fixnum) :fixnum - "((#0)->vector.fillp)=(#1)") - -;; file character.d - -(def-inline standard-char-p :always (character) :bool "ecl_standard_char_p(#0)") - -(def-inline graphic-char-p :always (character) :bool "ecl_graphic_char_p(#0)") - -(def-inline alpha-char-p :always (character) :bool "ecl_alpha_char_p(#0)") - -(def-inline upper-case-p :always (character) :bool "ecl_upper_case_p(#0)") - -(def-inline lower-case-p :always (character) :bool "ecl_lower_case_p(#0)") - -(def-inline both-case-p :always (character) :bool "ecl_both_case_p(#0)") - -(def-inline alphanumericp :always (character) :bool "ecl_alphanumericp(#0)") - -(def-inline char= :always (t t) :bool "ecl_char_code(#0)==ecl_char_code(#1)") -(def-inline char= :always (character character) :bool "(#0)==(#1)") - -(def-inline char/= :always (t t) :bool "ecl_char_code(#0)!=ecl_char_code(#1)") -(def-inline char/= :always (character character) :bool "(#0)!=(#1)") - -(def-inline char< :always (character character) :bool "(#0)<(#1)") - -(def-inline char> :always (character character) :bool "(#0)>(#1)") - -(def-inline char<= :always (character character) :bool "(#0)<=(#1)") - -(def-inline char>= :always (character character) :bool "(#0)>=(#1)") - -(def-inline char-code :always (character) :fixnum "#0") - -(def-inline code-char :always (fixnum) :char "#0") - -(def-inline char-upcase :always (base-char) :char "ecl_char_upcase(#0)") -(def-inline char-upcase :always (character) :wchar "ecl_char_upcase(#0)") - -(def-inline char-downcase :always (base-char) :char "ecl_char_downcase(#0)") -(def-inline char-downcase :always (character) :wchar "ecl_char_downcase(#0)") - -(def-inline char-int :always (character) :fixnum "#0") - -;; file ffi.d - -(def-inline si:foreign-data-p :always (t) :bool "@0;ECL_FOREIGN_DATA_P(#0)") - -;; file file.d - -(def-inline input-stream-p :always (stream) :bool "ecl_input_stream_p(#0)") - -(def-inline output-stream-p :always (stream) :bool "ecl_output_stream_p(#0)") - -;; file list.d - -(def-inline car :always (cons) t "CAR(#0)") -(def-inline car :unsafe (t) t "CAR(#0)") - -(def-inline cdr :always (cons) t "CDR(#0)") -(def-inline cdr :unsafe (t) t "CDR(#0)") - -(def-inline caar :always (cons) t "CAAR(#0)") -(def-inline caar :unsafe (t) t "CAAR(#0)") - -(def-inline cadr :always (cons) t "CADR(#0)") -(def-inline cadr :unsafe (t) t "CADR(#0)") - -(def-inline cdar :always (cons) t "CDAR(#0)") -(def-inline cdar :unsafe (t) t "CDAR(#0)") - -(def-inline cddr :always (cons) t "CDDR(#0)") -(def-inline cddr :unsafe (t) t "CDDR(#0)") - -(def-inline caaar :always (cons) t "CAAAR(#0)") -(def-inline caaar :unsafe (t) t "CAAAR(#0)") - -(def-inline caadr :always (cons) t "CAADR(#0)") -(def-inline caadr :unsafe (t) t "CAADR(#0)") - -(def-inline cadar :always (cons) t "CADAR(#0)") -(def-inline cadar :unsafe (t) t "CADAR(#0)") - -(def-inline caddr :always (cons) t "CADDR(#0)") -(def-inline caddr :unsafe (t) t "CADDR(#0)") - -(def-inline cdaar :always (cons) t "CDAAR(#0)") -(def-inline cdaar :unsafe (t) t "CDAAR(#0)") - -(def-inline cdadr :always (cons) t "CDADR(#0)") -(def-inline cdadr :unsafe (t) t "CDADR(#0)") - -(def-inline cddar :always (cons) t "CDDAR(#0)") -(def-inline cddar :unsafe (t) t "CDDAR(#0)") - -(def-inline cdddr :always (cons) t "CDDDR(#0)") -(def-inline cdddr :unsafe (t) t "CDDDR(#0)") - -(def-inline caaaar :always (cons) t "CAAAAR(#0)") -(def-inline caaaar :unsafe (t) t "CAAAAR(#0)") - -(def-inline caaadr :always (cons) t "CAAADR(#0)") -(def-inline caaadr :unsafe (t) t "CAAADR(#0)") - -(def-inline caadar :always (cons) t "CAADAR(#0)") -(def-inline caadar :unsafe (t) t "CAADAR(#0)") - -(def-inline caaddr :always (cons) t "CAADDR(#0)") -(def-inline caaddr :unsafe (t) t "CAADDR(#0)") - -(def-inline cadaar :always (cons) t "CADAAR(#0)") -(def-inline cadaar :unsafe (t) t "CADAAR(#0)") - -(def-inline cadadr :always (cons) t "CADADR(#0)") -(def-inline cadadr :unsafe (t) t "CADADR(#0)") - -(def-inline caddar :always (cons) t "CADDAR(#0)") -(def-inline caddar :unsafe (t) t "CADDAR(#0)") - -(def-inline cadddr :always (cons) t "CADDDR(#0)") -(def-inline cadddr :unsafe (t) t "CADDDR(#0)") - -(def-inline cdaaar :always (cons) t "CDAAAR(#0)") -(def-inline cdaaar :unsafe (t) t "CDAAAR(#0)") - -(def-inline cdaadr :always (cons) t "CDAADR(#0)") -(def-inline cdaadr :unsafe (t) t "CDAADR(#0)") - -(def-inline cdadar :always (cons) t "CDADAR(#0)") -(def-inline cdadar :unsafe (t) t "CDADAR(#0)") - -(def-inline cdaddr :always (cons) t "CDADDR(#0)") -(def-inline cdaddr :unsafe (t) t "CDADDR(#0)") - -(def-inline cddaar :always (cons) t "CDDAAR(#0)") -(def-inline cddaar :unsafe (t) t "CDDAAR(#0)") - -(def-inline cddadr :always (cons) t "CDDADR(#0)") -(def-inline cddadr :unsafe (t) t "CDDADR(#0)") - -(def-inline cdddar :always (cons) t "CDDDAR(#0)") -(def-inline cdddar :unsafe (t) t "CDDDAR(#0)") - -(def-inline cddddr :always (cons) t "CDDDDR(#0)") -(def-inline cddddr :unsafe (t) t "CDDDDR(#0)") - -(def-inline cons :always (t t) t "CONS(#0,#1)") - -(def-inline endp :safe (t) :bool "ecl_endp(#0)") -(def-inline endp :unsafe (t) :bool "#0==Cnil") - -(def-inline nth :always (t t) t "ecl_nth(fixint(#0),#1)") -(def-inline nth :always (fixnum t) t "ecl_nth(#0,#1)") -(def-inline nth :unsafe (t t) t "ecl_nth(fix(#0),#1)") -(def-inline nth :unsafe (fixnum t) t "ecl_nth(#0,#1)") - -(def-inline first :always (cons) t "ECL_CONS_CAR(#0)") -(def-inline first :unsafe (t) t "CAR(#0)") - -(def-inline second :always (cons) t "CADR(#0)") -(def-inline second :unsafe (t) t "CADR(#0)") - -(def-inline third :always (cons) t "CADDR(#0)") -(def-inline third :unsafe (t) t "CADDR(#0)") - -(def-inline fourth :always (cons) t "CADDDR(#0)") -(def-inline fourth :unsafe (t) t "CADDDR(#0)") - -(def-inline rest :always (cons) t "ECL_CONS_CDR(#0)") -(def-inline rest :unsafe (t) t "CDR(#0)") - -(def-inline nthcdr :always (t t) t "ecl_nthcdr(fixint(#0),#1)") -(def-inline nthcdr :always (fixnum t) t "ecl_nthcdr(#0,#1)") -(def-inline nthcdr :unsafe (t t) t "ecl_nthcdr(fix(#0),#1)") -(def-inline nthcdr :unsafe (fixnum t) t "ecl_nthcdr(#0,#1)") - -(def-inline last :always (t) t "ecl_last(#0,1)") -(def-inline list :always nil t "Cnil") -(def-inline list :always (t) t "ecl_list1(#0)") - -(def-inline list* :always (t) t "#0") -(def-inline list* :always (t t) t "CONS(#0,#1)") - -(def-inline append :always (t t) t "ecl_append(#0,#1)") - -(def-inline nconc :always (t t) t "ecl_nconc(#0,#1)") - -(def-inline butlast :always (t) t "ecl_butlast(#0,1)") - -(def-inline nbutlast :always (t) t "ecl_nbutlast(#0,1)") - -;; file num_arith.d - -(def-inline + :always (t t) t "ecl_plus(#0,#1)") -(def-inline + :always (fixnum-float fixnum-float) :double - "(double)(#0)+(double)(#1)" :exact-return-type t) -(def-inline + :always (fixnum-float fixnum-float) :float - "(float)(#0)+(float)(#1)" :exact-return-type t) -(def-inline + :always (fixnum fixnum) :fixnum "(#0)+(#1)" :exact-return-type t) - -(def-inline - :always (t) t "ecl_negate(#0)") -(def-inline - :always (t t) t "ecl_minus(#0,#1)") -(def-inline - :always (fixnum-float fixnum-float) :double - "(double)(#0)-(double)(#1)" :exact-return-type t) -(def-inline - :always (fixnum-float fixnum-float) :float - "(float)(#0)-(float)(#1)" :exact-return-type t) -(def-inline - :always (fixnum fixnum) :fixnum "(#0)-(#1)" :exact-return-type t) -(def-inline - :always (fixnum-float) :double "-(double)(#0)" :exact-return-type t) -(def-inline - :always (fixnum-float) :float "-(float)(#0)" :exact-return-type t) -(def-inline - :always (fixnum) :fixnum "-(#0)" :exact-return-type t) - -(def-inline * :always (t t) t "ecl_times(#0,#1)") -(def-inline * :always (fixnum-float fixnum-float) :double - "(double)(#0)*(double)(#1)" :exact-return-type t) -(def-inline * :always (fixnum-float fixnum-float) :float - "(float)(#0)*(float)(#1)" :exact-return-type t) -(def-inline * :always (fixnum fixnum) t "_ecl_fix_times_fix(#0,#1)" :exact-return-type t) -(def-inline * :always (fixnum fixnum) :fixnum "(#0)*(#1)" :exact-return-type t) - -(def-inline / :always (t t) t "ecl_divide(#0,#1)") -(def-inline / :always (fixnum-float fixnum-float) :double - "(double)(#0)/(double)(#1)" :exact-return-type t) -(def-inline / :always (fixnum-float fixnum-float) :float - "(float)(#0)/(float)(#1)" :exact-return-type t) -(def-inline / :always (fixnum fixnum) :fixnum "(#0)/(#1)" :exact-return-type t) - -(def-inline 1+ :always (t) t "ecl_one_plus(#0)") -(def-inline 1+ :always (double-loat) :double "(double)(#0)+1") -(def-inline 1+ :always (single-float) :float "(float)(#0)+1") -(def-inline 1+ :always (fixnum) :fixnum "(#0)+1" :exact-return-type t) - -(def-inline 1- :always (t) t "ecl_one_minus(#0)") -(def-inline 1- :always (double-float) :double "(double)(#0)-1") -(def-inline 1- :always (single-float) :float "(float)(#0)-1") -(def-inline 1- :always (fixnum) :fixnum "(#0)-1" :exact-return-type t) - -;; file num_co.d - -(def-inline float :always (t single-float) :float "ecl_to_float(#0)") -(def-inline float :always (t double-float) :double "ecl_to_double(#0)") -(def-inline float :always (fixnum-float) :double "((double)(#0))" :exact-return-type t) -(def-inline float :always (fixnum-float) :float "((float)(#0))" :exact-return-type t) - -(def-inline numerator :unsafe (integer) integer "(#0)") -(def-inline numerator :unsafe (ratio) integer "(#0)->ratio.num") - -(def-inline denominator :unsafe (integer) integer "MAKE_FIXNUM(1)") -(def-inline denominator :unsafe (ratio) integer "(#0)->ratio.den") - -(def-inline floor :always (t) (values &rest t) "ecl_floor1(#0)") -(def-inline floor :always (t t) (values &rest t) "ecl_floor2(#0,#1)") -#+(or) ; does not work well, no multiple values -(def-inline floor :always (fixnum fixnum) :fixnum - "@01;(#0>=0&>0?(#0)/(#1):ecl_ifloor(#0,#1))") - -(def-inline ceiling :always (t) (values &rest t) "ecl_ceiling1(#0)") -(def-inline ceiling :always (t t) (values &rest t) "ecl_ceiling2(#0,#1)") - -(def-inline truncate :always (t) (values &rest t) "ecl_truncate1(#0)") -(def-inline truncate :always (t t) (values &rest t) "ecl_truncate2(#0,#1)") -#+(or) ; does not work well, no multiple values -(def-inline truncate :always (fixnum-float) :fixnum "(cl_fixnum)(#0)") - -(def-inline round :always (t) (values &rest t) "ecl_round1(#0)") -(def-inline round :always (t t) (values &rest t) "ecl_round2(#0,#1)") - -(def-inline mod :always (t t) t "(ecl_floor2(#0,#1),cl_env_copy->values[1])") -(def-inline mod :always (fixnum fixnum) :fixnum - "@01;(#0>=0&>0?(#0)%(#1):ecl_imod(#0,#1))") - -(def-inline rem :always (t t) t "(ecl_truncate2(#0,#1),cl_env_copy->values[1])") -(def-inline rem :always (fixnum fixnum) :fixnum "(#0)%(#1)") - -(def-inline = :always (t t) :bool "ecl_number_equalp(#0,#1)") -(def-inline = :always (fixnum-float fixnum-float) :bool "(#0)==(#1)") - -(def-inline /= :always (t t) :bool "!ecl_number_equalp(#0,#1)") -(def-inline /= :always (fixnum-float fixnum-float) :bool "(#0)!=(#1)") - -(def-inline < :always (t t) :bool "ecl_number_compare(#0,#1)<0") -(def-inline < :always (fixnum-float fixnum-float) :bool "(#0)<(#1)") -(def-inline < :always (fixnum-float fixnum-float fixnum-float) :bool - "@012;((#0)<(#1) && (#1)<(#2))") - -(def-inline > :always (t t) :bool "ecl_number_compare(#0,#1)>0") -(def-inline > :always (fixnum-float fixnum-float) :bool "(#0)>(#1)") -(def-inline > :always (fixnum-float fixnum-float fixnum-float) :bool - "@012;((#0)>(#1) && (#1)>(#2))") - -(def-inline <= :always (t t) :bool "ecl_number_compare(#0,#1)<=0") -(def-inline <= :always (fixnum-float fixnum-float) :bool "(#0)<=(#1)") -(def-inline <= :always (fixnum-float fixnum-float fixnum-float) :bool - "@012;((#0)<=(#1) && (#1)<=(#2))") - -(def-inline >= :always (t t) :bool "ecl_number_compare(#0,#1)>=0") -(def-inline >= :always (fixnum-float fixnum-float) :bool "(#0)>=(#1)") -(def-inline >= :always (fixnum-float fixnum-float fixnum-float) :bool - "@012;((#0)>=(#1) && (#1)>=(#2))") - -(def-inline max :always (t t) t "@01;(ecl_number_compare(#0,#1)>=0?#0:#1)") -(def-inline max :always (fixnum fixnum) :fixnum "@01;(#0)>=(#1)?#0:#1") - -(def-inline min :always (t t) t "@01;(ecl_number_compare(#0,#1)<=0?#0:#1)") -(def-inline min :always (fixnum fixnum) :fixnum "@01;(#0)<=(#1)?#0:#1") - -;; file num_log.d - -(def-inline logand :always nil t "MAKE_FIXNUM(-1)") -(def-inline logand :always nil :fixnum "-1") -(def-inline logand :always (t t) t "ecl_boole(ECL_BOOLAND,(#0),(#1))") -(def-inline logand :always (fixnum fixnum) :fixnum "((#0) & (#1))") - -(def-inline logandc1 :always (t t) t "ecl_boole(ECL_BOOLANDC1,(#0),(#1))") -(def-inline logandc1 :always (fixnum fixnum) :fixnum "(~(#0) & (#1))") - -(def-inline logandc2 :always (t t) t "ecl_boole(ECL_BOOLANDC2,(#0),(#1))") -(def-inline logandc2 :always (fixnum fixnum) :fixnum "((#0) & ~(#1))") - -(def-inline logeqv :always nil t "MAKE_FIXNUM(-1)") -(def-inline logeqv :always nil :fixnum "-1") -(def-inline logeqv :always (t t) t "ecl_boole(ECL_BOOLEQV,(#0),(#1))") -(def-inline logeqv :always (fixnum fixnum) :fixnum "(~( (#0) ^ (#1) ))") - -(def-inline logior :always nil t "MAKE_FIXNUM(0)") -(def-inline logior :always nil :fixnum "0") -(def-inline logior :always (t t) t "ecl_boole(ECL_BOOLIOR,(#0),(#1))") -(def-inline logior :always (fixnum fixnum) :fixnum "((#0) | (#1))") - -(def-inline lognand :always (t t) t "ecl_boole(ECL_BOOLNAND,(#0),(#1))") -(def-inline lognand :always (fixnum fixnum) :fixnum "(~( (#0) & (#1) ))") - -(def-inline lognor :always (t t) t "ecl_boole(ECL_BOOLNOR,(#0),(#1))") -(def-inline lognor :always (fixnum fixnum) :fixnum "(~( (#0) | (#1) ))") - -(def-inline lognot :always (t) t "ecl_boole(ECL_BOOLXOR,(#0),MAKE_FIXNUM(-1))") -(def-inline lognot :always (fixnum) :fixnum "(~(#0))") - -(def-inline logorc1 :always (t t) t "ecl_boole(ECL_BOOLORC1,(#0),(#1))") -(def-inline logorc1 :always (fixnum fixnum) :fixnum "(~(#0) | (#1))") - -(def-inline logorc2 :always (t t) t "ecl_boole(ECL_BOOLORC2,(#0),(#1))") -(def-inline logorc2 :always (fixnum fixnum) :fixnum "((#0) | ~(#1))") - -(def-inline logxor :always nil t "MAKE_FIXNUM(0)") -(def-inline logxor :always nil :fixnum "0") -(def-inline logxor :always (t t) t "ecl_boole(ECL_BOOLXOR,(#0),(#1))") -(def-inline logxor :always (fixnum fixnum) :fixnum "((#0) ^ (#1))") - -(def-inline boole :always (fixnum t t) t "ecl_boole((#0),(#1),(#2))") - -(def-inline logbitp :always ((integer -29 29) fixnum) :bool "(#1 >> #0) & 1") - -(def-inline zerop :always (t) :bool "ecl_zerop(#0)") -(def-inline zerop :always (fixnum-float) :bool "(#0)==0") - -(def-inline plusp :always (t) :bool "ecl_plusp(#0)") -(def-inline plusp :always (fixnum-float) :bool "(#0)>0") - -(def-inline minusp :always (t) :bool "ecl_minusp(#0)") -(def-inline minusp :always (fixnum-float) :bool "(#0)<0") - -(def-inline oddp :always (t) :bool "ecl_oddp(#0)") -(def-inline oddp :always (fixnum fixnum) :bool "(#0) & 1") - -(def-inline evenp :always (t) :bool "ecl_evenp(#0)") -(def-inline evenp :always (fixnum fixnum) :bool "~(#0) & 1") - -(def-inline expt :always ((integer 2 2) (integer 0 29)) :fixnum "(1<<(#1))") -(def-inline expt :always ((integer 0 0) t) :fixnum "0") -(def-inline expt :always ((integer 1 1) t) :fixnum "1") - -(def-inline log :always (fixnum-float) :double "log((double)(#0))" :exact-return-type t) -(def-inline log :always (fixnum-float) :float "(float)log((double)(#0))" :exact-return-type t) - -(def-inline sqrt :always ((or (long-float 0.0 *) (double-float 0.0 *))) :double "sqrt((double)(#0))") -(def-inline sqrt :always ((or (single-float 0.0 *) (short-float 0.0 *))) :float "(float)sqrt((double)(#0))") - -(def-inline sin :always (fixnum-float) :double "sin((double)(#0))" :exact-return-type t) -(def-inline sin :always (fixnum-float) :float "(float)sin((double)(#0))" :exact-return-type t) - -(def-inline cos :always (fixnum-float) :double "cos((double)(#0))" :exact-return-type t) -(def-inline cos :always (fixnum-float) :float "(float)cos((double)(#0))" :exact-return-type t) - -(def-inline tan :always (fixnum-float) :double "tan((double)(#0))" :exact-return-type t) -(def-inline tan :always (fixnum-float) :float "(float)tan((double)(#0))" :exact-return-type t) - -(def-inline sin :always (fixnum-float) :double "sinh((double)(#0))" :exact-return-type t) -(def-inline sin :always (fixnum-float) :float "(float)sinh((double)(#0))" :exact-return-type t) - -(def-inline cos :always (fixnum-float) :double "cosh((double)(#0))" :exact-return-type t) -(def-inline cos :always (fixnum-float) :float "(float)cosh((double)(#0))" :exact-return-type t) - -(def-inline tan :always (fixnum-float) :double "tanh((double)(#0))" :exact-return-type t) -(def-inline tan :always (fixnum-float) :float "(float)tanh((double)(#0))" :exact-return-type t) - -;; file pathname.d - -(def-inline null :always (t) :bool "#0==Cnil") - -(def-inline symbolp :always (t) :bool "@0;ECL_SYMBOLP(#0)") - -(def-inline atom :always (t) :bool "@0;ECL_ATOM(#0)") - -(def-inline consp :always (t) :bool "@0;ECL_CONSP(#0)") - -(def-inline listp :always (t) :bool "@0;ECL_LISTP(#0)") - -(def-inline numberp :always (t) :bool "ecl_numberp(#0)") - -(def-inline integerp :always (t) :bool "@0;ECL_FIXNUMP(#0)||ECL_BIGNUMP(#0)") - -(def-inline floatp :always (t) :bool "floatp(#0)") - -(def-inline characterp :always (t) :bool "CHARACTERP(#0)") - -(def-inline base-char-p :always (character) :bool "BASE_CHAR_P(#0)") - -(def-inline stringp :always (t) :bool "@0;ECL_STRINGP(#0)") - -(def-inline base-string-p :always (t) :bool "@0;ECL_BASE_STRING_P(#0)") - -(def-inline bit-vector-p :always (t) :bool "@0;ECL_BIT_VECTOR_P(#0)") - -(def-inline vectorp :always (t) :bool "@0;ECL_VECTORP(#0)") - -(def-inline arrayp :always (t) :bool "@0;ECL_ARRAYP(#0)") - -(def-inline eq :always (t t) :bool "(#0)==(#1)") -(def-inline eq :always (fixnum fixnum) :bool "(#0)==(#1)") - -(def-inline eql :always (t t) :bool "ecl_eql(#0,#1)") -(def-inline eql :always (character t) :bool "(CODE_CHAR(#0)==(#1))") -(def-inline eql :always (t character) :bool "((#0)==CODE_CHAR(#1))") -(def-inline eql :always (character character) :bool "(#0)==(#1)") -(def-inline eql :always ((not (or complex bignum ratio float)) t) :bool - "(#0)==(#1)") -(def-inline eql :always (t (not (or complex bignum ratio float))) :bool - "(#0)==(#1)") -(def-inline eql :always (fixnum fixnum) :bool "(#0)==(#1)") - -(def-inline equal :always (t t) :bool "ecl_equal(#0,#1)") -(def-inline equal :always (fixnum fixnum) :bool "(#0)==(#1)") - -(def-inline equalp :always (t t) :bool "ecl_equalp(#0,#1)") -(def-inline equalp :always (fixnum fixnum) :bool "(#0)==(#1)") - -(def-inline not :always (t) :bool "(#0)==Cnil") - -;; file print.d, read.d - -(def-inline clear-output :always (stream) NULL "(ecl_clear_output(#0),Cnil)") - -(def-inline finish-output :always (stream) NULL "(ecl_finish_output(#0),Cnil)") - -(def-inline finish-output :always (stream) NULL "(ecl_force_output(#0),Cnil)") - -(def-inline prin1 :always (t t) t "ecl_prin1(#0,#1)") -(def-inline prin1 :always (t) t "ecl_prin1(#0,Cnil)") - -(def-inline princ :always (t t) t "ecl_princ(#0,#1)") -(def-inline princ :always (t) t "ecl_princ(#0,Cnil)") - -(def-inline print :always (t t) t "ecl_print(#0,#1)") -(def-inline print :always (t) t "ecl_print(#0,Cnil)") - -(def-inline terpri :always (t) t "ecl_terpri(#0)") -(def-inline terpri :always nil t "ecl_terpri(Cnil)") - -(def-inline write-char :always (t) t "@0;(ecl_princ_char(ecl_char_code(#0),Cnil),(#0))") - -(def-inline clear-input :always (stream) NULL "(ecl_clear_input(#0),Cnil)") - -(def-inline copy-readtable :always (null null) t "standard_readtable") - -(def-inline boundp :always (t) :bool "ecl_boundp(cl_env_copy,#0)") -(def-inline boundp :unsafe (symbol) :bool "@0;Null(#0)||(ECL_SYM_VAL(cl_env_copy,#0)!=OBJNULL)") - - -;; file sequence.d - -(def-inline elt :always (t t) t "ecl_elt(#0,fix(#1))") -(def-inline elt :always (t fixnum) t "ecl_elt(#0,#1)") -(def-inline elt :always (vector t) t "ecl_aref1(#0,fix(#1))") -(def-inline elt :always (vector fixnum) t "ecl_aref1(#0,#1)") - -(def-inline elt :unsafe (t t) t "ecl_elt(#0,fix(#1))") -(def-inline elt :unsafe (t fixnum) t "ecl_elt(#0,#1)") -(def-inline elt :unsafe (vector t) t "ecl_aref_unsafe(#0,fix(#1))") -(def-inline elt :unsafe (vector fixnum) t "ecl_elt_unsafe(#0,#1)") -(def-inline aref :unsafe ((array bit) t) :fixnum "ecl_aref_bv(#0,fix(#1))") -(def-inline aref :unsafe ((array bit) fixnum) :fixnum "ecl_aref_bv(#0,#1)") -#+unicode -(def-inline aref :unsafe ((array character) fixnum) :wchar - "(#0)->string.self[#1]") -(def-inline aref :unsafe ((array base-char) fixnum) :char - "(#0)->base_string.self[#1]") -(def-inline aref :unsafe ((array double-float) fixnum) :double - "(#0)->array.self.df[#1]") -(def-inline aref :unsafe ((array single-float) fixnum) :float - "(#0)->array.self.sf[#1]") -(def-inline aref :unsafe ((array fixnum) fixnum) :fixnum - "(#0)->array.self.fix[#1]") - -(def-inline si:elt-set :always (t t t) t "ecl_elt_set(#0,fixint(#1),#2)") -(def-inline si:elt-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)") -(def-inline si:elt-set :always (vector t t) t "ecl_aset1(#0,fixint(#1),#2)") -(def-inline si:elt-set :always (vector fixnum t) t "ecl_aset1(#0,#1,#2)") - -(def-inline si:elt-set :unsafe (t t t) t "ecl_elt_set(#0,fix(#1),#2)") -(def-inline si:elt-set :unsafe (vector t t) t "ecl_aset1_unsafe(#0,fixint(#1),#2)") -(def-inline si:elt-set :unsafe (vector fixnum t) t "ecl_aset1_unsafe(#0,#1,#2)") - -(def-inline length :always (t) :fixnum "ecl_length(#0)") -(def-inline length :unsafe (array t) :fixnum "(#0)->vector.fillp") - -;; file character.d - -(def-inline char :always (t fixnum) t "ecl_aref1(#0,#1)") -(def-inline char :always (t fixnum) :wchar "ecl_char(#0,#1)") -#-unicode -(def-inline char :unsafe (t t) t "CODE_CHAR((#0)->base_string.self[fix(#1)])") -#-unicode -(def-inline char :unsafe (t fixnum) :char "(#0)->base_string.self[#1]") -(def-inline char :unsafe (base-string fixnum) :unsigned-char "(#0)->base_string.self[#1]") -#+unicode -(def-inline char :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") - -(def-inline si:char-set :always (t t t) t "si_char_set(#0,#1,#2)") -(def-inline si:char-set :always (t fixnum t) t "ecl_aset1(#0,#1,#2)") -(def-inline si:char-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)") -#-unicode -(def-inline si:char-set :unsafe (t t t) t - "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") -#-unicode -(def-inline si:char-set :unsafe (t fixnum character) :char - "(#0)->base_string.self[#1]= #2") -(def-inline si:char-set :unsafe (base-string t t) t - "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") -(def-inline si:char-set :unsafe (base-string fixnum base-char) :char - "(#0)->base_string.self[#1]= #2") -(def-inline si:char-set :unsafe (ext:extended-string t t) t - "@2;((#0)->string.self[fix(#1)]=ecl_char_code(#2),(#2))") -(def-inline si:char-set :unsafe (ext:extended-string fixnum character) :char - "(#0)->string.self[#1]= #2") - -(def-inline schar :always (t t) t "ecl_elt(#0,fixint(#1))") -(def-inline schar :always (t fixnum) t "ecl_elt(#0,#1)") -(def-inline schar :always (t fixnum) :wchar "ecl_char(#0,#1)") -(def-inline schar :unsafe (base-string t) t "CODE_CHAR((#0)->base_string.self[fix(#1)])") -#-unicode -(def-inline schar :unsafe (t fixnum) :char "(#0)->base_string.self[#1]") -(def-inline schar :unsafe (base-string fixnum) :char "(#0)->base_string.self[#1]") -#+unicode -(def-inline schar :unsafe (ext:extended-string fixnum) :wchar "(#0)->string.self[#1]") - -(def-inline si:schar-set :always (t t t) t "ecl_elt_set(#0,fixint(#1),#2)") -(def-inline si:schar-set :always (t fixnum t) t "ecl_elt_set(#0,#1,#2)") -(def-inline si:schar-set :always (t fixnum character) :wchar "ecl_char_set(#0,#1,#2)") -#-unicode -(def-inline si:schar-set :unsafe (t t t) t - "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") -#-unicode -(def-inline si:schar-set :unsafe (t fixnum base-char) :char - "(#0)->base_string.self[#1]= #2") -(def-inline si:schar-set :unsafe (base-string t t) t - "@2;((#0)->base_string.self[fix(#1)]=ecl_char_code(#2),(#2))") -(def-inline si:schar-set :unsafe (base-string fixnum base-char) :char - "(#0)->base_string.self[#1]= #2") -#+unicode -(def-inline si:schar-set :unsafe (ext:extended-string fixnum t) :wchar - "@2;((#0)->string.self[#1]= ecl_char_code(#2),(#2))") -#+unicode -(def-inline si:schar-set :unsafe (ext:extended-string fixnum character) :wchar - "(#0)->string.self[#1]= #2") - -(def-inline string= :always (string string) :bool "ecl_string_eq(#0,#1)") - -;; file structure.d - -(def-inline si:structure-name :always (structure) symbol "SNAME(#0)") - -(def-inline si:structure-ref :always (t t fixnum) t "ecl_structure_ref(#0,#1,#2)") - -(def-inline si:structure-set :always (t t fixnum t) t - "ecl_structure_set(#0,#1,#2,#3)") - -;; file symbol.d - -(def-inline get :always (t t t) t "ecl_get(#0,#1,#2)") -(def-inline get :always (t t) t "ecl_get(#0,#1,Cnil)") - -(def-inline symbol-name :always (t) string "ecl_symbol_name(#0)") - -;; AKCL addition - -(proclaim-function si:copy-stream (t t) t) - -;; Additions used by the compiler. -;; The following functions do not exist. They are always expanded into the -;; given C code. References to these functions are generated in the C1 phase. - -(proclaim-function shift>> (*) nil :no-side-effects) -(def-inline shift>> :always (fixnum fixnum) :fixnum "((#0) >> (- (#1)))") - -(proclaim-function shift<< (*) nil :no-side-effects) -(def-inline shift<< :always (fixnum fixnum) :fixnum "((#0) << (#1))") - -(proclaim-function short-float-p (t) gen-bool :predicate) -#-short-float -(def-inline short-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)") -#+short-float -(def-inline short-float-p :always (t) :bool "type_of(#0)==t_shortfloat") - -(proclaim-function single-float-p (t) gen-bool :predicate) -(def-inline single-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)") - -(proclaim-function double-float-p (t) gen-bool :predicate) -(def-inline double-float-p :always (t) :bool "@0;ECL_DOUBLE_FLOAT_P(#0)") - -(proclaim-function long-float-p (t) gen-bool :predicate) -#-long-float -(def-inline long-float-p :always (t) :bool "@0;ECL_DOUBLE_FLOAT_P(#0)") -#+long-float -(def-inline long-float-p :always (t) :bool "@0;ECL_LONG_FLOAT_P(#0)") - -(proclaim-function si:fixnump (t) gen-bool :predicate) -(def-inline si:fixnump :always (t) :bool "FIXNUMP(#0)") -(def-inline si:fixnump :always (fixnum) :bool "1") - -(proclaim-function si:put-properties (*) nil :no-sp-change) - -(proclaim-function c::ldb1 (fixnum fixnum fixnum) fixnum :no-side-effects) -(def-inline c::ldb1 :always (fixnum fixnum fixnum) :fixnum - "((((~((cl_fixnum)-1 << (#0))) << (#1)) & (cl_fixnum)(#2)) >> (#1))") -(def-inline c::ldb1 :always (fixnum fixnum fixnum) t - "MAKE_FIXNUM((((~((cl_fixnum)-1 << (#0))) << (#1)) & (cl_fixnum)(#2)) >> (#1))") - -;; Functions only available with CLOS - -#+clos(progn -(proclaim-function si:allocate-raw-instance (t t fixnum) t) -(proclaim-function si:instance-ref-safe (t fixnum) t) -(proclaim-function si:instance-ref (t fixnum) t :no-side-effects) -(def-inline si:instance-ref :always (t fixnum) t "ecl_instance_ref((#0),(#1))") -(def-inline si:instance-ref :unsafe (standard-object fixnum) t - "(#0)->instance.slots[#1]") - -(proclaim-function si:instance-set (t fixnum t) t) -(def-inline si:instance-set :unsafe (t fixnum t) t - "ecl_instance_set((#0),(#1),(#2))") -(def-inline si:instance-set :unsafe (standard-object fixnum t) t - "(#0)->instance.slots[#1]=(#2)") - -(proclaim-function si:instance-class (t) t :no-side-effects) -(def-inline si:instance-class :always (standard-object) t "CLASS_OF(#0)") -(proclaim-function si:instance-class-set (t t) t) -(proclaim-function si:instancep (t) t :predicate) -(def-inline si::instancep :always (t) :bool "@0;ECL_INSTANCEP(#0)") -(proclaim-function si:unbound (*) t :predicate) -(def-inline si:unbound :always nil t "ECL_UNBOUND") - -(proclaim-function si:sl-boundp (t) t :predicate) -(def-inline si:sl-boundp :always (t) :bool "(#0)!=ECL_UNBOUND") - -(proclaim-function si:sl-makunbound (t fixnum) t :predicate) - -(proclaim-function standard-instance-access (standard-object fixnum) t :no-side-effects) -(def-inline standard-instance-access :always (standard-object fixnum) t "ecl_instance_ref((#0),(#1))") -(def-inline standard-instance-access :unsafe (standard-object fixnum) t - "(#0)->instance.slots[#1]") - -(proclaim-function funcallable-standard-instance-access (funcallable-standard-object fixnum) t :no-side-effects) -(def-inline funcallable-standard-instance-access :always (funcallable-standard-object fixnum) t "ecl_instance_ref((#0),(#1))") -(def-inline funcallable-standard-instance-access :unsafe (funcallable-standard-object fixnum) t - "(#0)->instance.slots[#1]") - -(proclaim-function associate-methods-to-gfun (generic-function *) generic-function) -) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; FUNCTIONS WHICH CAN BE CALLED FROM C -;;; -;;; The following two lists contain all functions in the core library which do -;;; not belong to the C part of the library, but which should have an exported C -;;; name that users (and compiled code) can refer to. This means, for instance, that -;;; MAKE-ARRAY will be compiled to a function called cl_make_array, etc. -;;; - -(in-package "SI") - -(defparameter c-data::*in-all-symbols-functions* - '(;; arraylib.lsp - 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-orc2 bit-not - vector-push vector-push-extend vector-pop adjust-array - ;; conditions.lsp - si::safe-eval - signal warn break make-condition compute-restarts find-restart - invoke-restart invoke-restart-interactively - abort continue muffle-warning store-value use-value - ;; config.lsp - short-site-name long-site-name machine-instance machine-type machine-version - software-type software-version lisp-implementation-type lisp-implementation-version - ;; describe.lsp - describe inspect - ;; iolib.lsp - read-from-string write-to-string prin1-to-string princ-to-string - y-or-n-p yes-or-no-p dribble si::string-to-object - ;; listlib.lsp - union nunion intersection nintersection set-difference nset-difference - set-exclusive-or nset-exclusive-or subsetp rassoc-if rassoc-if-not - assoc-if assoc-if-not member-if member-if-not subst-if subst-if-not - nsubst-if nsubst-if-not - ;; mislib.lsp - logical-pathname-translations load-logical-pathname-translations decode-universal-time - encode-universal-time get-decoded-time - ensure-directories-exist si::simple-program-error si::signal-simple-error - ;; module.lsp - provide require - ;; numlib.lsp - isqrt phase signum cis - asin acos asinh acosh atanh ffloor fceiling ftruncate fround - logtest byte byte-size byte-position ldb ldb-test mask-field dpb - deposit-field - ;; packlib.lsp - find-all-symbols apropos apropos-list - find-relative-package package-parent package-children - ;; predlib.lsp - upgraded-array-element-type upgraded-complex-part-type typep subtypep coerce - do-deftype - ;; seq.lsp - make-sequence concatenate map some every notany notevery map-into - ;; seqlib.lsp - 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 - complement constantly - ;; top.lsp - invoke-debugger - ;; pprint.lsp - pprint-fill copy-pprint-dispatch pprint-dispatch - pprint-linear pprint-newline pprint-tab pprint-tabular - set-pprint-dispatch pprint-indent . - #-clos - nil - #+clos - (;; combin.lsp - method-combination-error - invalid-method-error - #-(or) standard-instance-access ; this function is a synonym for si:instance-ref - #-(or) funcallable-standard-instance-access ; same for this one - subclassp of-class-p - ;; boot.lsp - slot-boundp - slot-makunbound - slot-value - slot-exists-p - ;; generic.lsp - ;; ensure-generic-function cannot be here because it is redefined at run time. - ;; print.lsp - make-load-form-saving-slots - ) -)) - -(proclaim - `(si::c-export-fname #+ecl-min ,@c-data::*in-all-symbols-functions* - si::ecase-error si::etypecase-error si::do-check-type - ccase-error typecase-error-string find-documentation find-declarations - si::search-keyword si::check-keyword si::check-arg-length - si::dm-too-few-arguments si::dm-bad-key - remove-documentation si::get-documentation - si::set-documentation si::expand-set-documentation - si::packages-iterator - si::pprint-logical-block-helper si::pprint-pop-helper - si::make-seq-iterator si::seq-iterator-ref si::seq-iterator-set si::seq-iterator-next - si::structure-type-error si::define-structure - si::coerce-to-list si::coerce-to-vector - si::fill-array-with-seq - #+formatter - ,@'( - format-princ format-prin1 format-print-named-character - format-print-integer - format-print-cardinal format-print-ordinal format-print-old-roman - format-print-roman format-fixed format-exponential - format-general format-dollars - format-relative-tab format-absolute-tab - format-justification - ) - #+clos - ,@'(;; defclass.lsp - clos::ensure-class - ;; combin.lsp - clos::simple-code-walker - ;; standard.lsp - clos::safe-instance-ref - clos::standard-instance-set - ;; kernel.lsp - clos::install-method - clos::class-id - clos::class-direct-superclasses - clos::class-direct-subclasses - clos::class-slots - clos::class-precedence-list - clos::class-direct-slots - clos::default-initargs-of - clos::generic-function-lambda-list - clos::generic-function-argument-precedence-order - clos::generic-function-method-combination - clos::generic-function-method-class - clos::generic-function-methods - clos::method-generic-function - clos::method-lambda-list - clos::method-specializers - clos::method-qualifiers - clos::method-function - clos::method-plist - clos::associate-methods-to-gfun - ;; method.lsp - clos::pop-next-method - ))) -;(trace c::c1expr c::c1call-global c::c1if c::cmp-macroexpand c::cmp-expand-macro)