Commit fbdb0a32 authored by Marius Gerbershagen's avatar Marius Gerbershagen Committed by Daniel Kochmański
Browse files

cmp: check that number of arguments matches the declaration in symbols_list.h

We also use the *in-all-symbols-functions* variable only for
determining which functions are to be exported during the build of ECL
itself. Otherwise, instead of specifying manually, which Lisp
functions are exported and in the core, we use the information from
symbols_list.h (i.e. we let all_symbols.d initialize all core
functions).
parent 68ee6fa2
......@@ -96,10 +96,10 @@ mangle_name(cl_object output, unsigned char *source, int l)
if (is_symbol) {
cl_fixnum p;
if (symbol == ECL_NIL) {
@(return ECL_T ecl_make_constant_base_string("ECL_NIL",-1));
@(return ECL_T ecl_make_constant_base_string("ECL_NIL",-1) minarg maxarg);
}
else if (symbol == ECL_T) {
@(return ECL_T ecl_make_constant_base_string("ECL_T",-1));
@(return ECL_T ecl_make_constant_base_string("ECL_T",-1) minarg maxarg);
}
p = (cl_symbol_initializer*)symbol - cl_symbols;
......@@ -108,7 +108,28 @@ mangle_name(cl_object output, unsigned char *source, int l)
output = cl_format(4, ECL_NIL,
ecl_make_constant_base_string("ECL_SYM(~S,~D)",-1),
name, ecl_make_fixnum(p));
@(return found output);
#ifndef ECL_FINAL
/* XXX to allow the Lisp compiler to check that the narg
* declaration in symbols_list.h matches the actual function
* definition, return the previously saved narg here. -- mg
* 2019-12-02 */
cl_object plist = cl_symbol_plist(symbol);
for ( ; ECL_CONSP(plist); plist = ECL_CONS_CDR(plist)) {
if (ECL_CONS_CAR(plist) == @'call-arguments-limit') {
plist = ECL_CONS_CDR(plist);
if (ECL_CONSP(plist) && ECL_FIXNUMP(ECL_CONS_CAR(plist))) {
cl_fixnum narg = ecl_fixnum(ECL_CONS_CAR(plist));
if (narg >= 0) {
minarg = maxarg = ecl_make_fixnum(narg);
} else {
minarg = ecl_make_fixnum(-narg-1);
}
}
break;
}
}
#endif
@(return found output minarg maxarg);
}
} else if (!Null(symbol)) {
cl_object fun = symbol->symbol.gfdef;
......@@ -251,6 +272,12 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
}
ECL_SYM_FUN(s) = f;
}
#ifndef ECL_FINAL
/* XXX to allow the Lisp compiler to check that the narg declaration
* in symbols_list.h matches the actual function definition, we save
* narg here. -- mg 2019-12-02 */
si_set_symbol_plist(s, cl_list(2, @'call-arguments-limit', ecl_make_fixnum(narg)));
#endif
cl_num_symbols_in_core = i + 1;
}
......
......@@ -1704,7 +1704,7 @@ cl_symbols[] = {
{CLOS_ "DIRECT-SLOT-DEFINITION-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "EFFECTIVE-SLOT-DEFINITION", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "EFFECTIVE-SLOT-DEFINITION-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "ENSURE-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "ENSURE-CLASS", CLOS_ORDINARY, ECL_NAME(clos_ensure_class), -2, OBJNULL},
{CLOS_ "ENSURE-CLASS-USING-CLASS", CLOS_ORDINARY, NULL, -1, OBJNULL},
{CLOS_ "ENSURE-GENERIC-FUNCTION-USING-CLASS", CLOS_ORDINARY, NULL, -3, OBJNULL},
{CLOS_ "EQL-SPECIALIZER", CLOS_ORDINARY, NULL, -1, OBJNULL},
......@@ -2075,7 +2075,7 @@ cl_symbols[] = {
{EXT_ "COMPLEX-ARRAY", EXT_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "SEQUENCE-START-END", SI_ORDINARY, si_sequence_start_end, 4, OBJNULL},
{SYS_ "SEQUENCE-COUNT", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "SEQUENCE-COUNT", SI_ORDINARY, ECL_NAME(si_sequence_count), 1, OBJNULL},
{SYS_ "SHRINK-VECTOR", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "COPY-SUBARRAY", SI_ORDINARY, si_copy_subarray, 5, OBJNULL},
......
......@@ -1704,7 +1704,7 @@ cl_symbols[] = {
{CLOS_ "DIRECT-SLOT-DEFINITION-CLASS",NULL,-1},
{CLOS_ "EFFECTIVE-SLOT-DEFINITION",NULL,-1},
{CLOS_ "EFFECTIVE-SLOT-DEFINITION-CLASS",NULL,-1},
{CLOS_ "ENSURE-CLASS",NULL,-1},
{CLOS_ "ENSURE-CLASS","ECL_NAME(clos_ensure_class)",-2},
{CLOS_ "ENSURE-CLASS-USING-CLASS",NULL,-1},
{CLOS_ "ENSURE-GENERIC-FUNCTION-USING-CLASS",NULL,-3},
{CLOS_ "EQL-SPECIALIZER",NULL,-1},
......@@ -2075,7 +2075,7 @@ cl_symbols[] = {
{EXT_ "COMPLEX-ARRAY",NULL,-1},
{SYS_ "SEQUENCE-START-END","si_sequence_start_end",4},
{SYS_ "SEQUENCE-COUNT",NULL,-1},
{SYS_ "SEQUENCE-COUNT","ECL_NAME(si_sequence_count)",1},
{SYS_ "SHRINK-VECTOR",NULL,-1},
{SYS_ "COPY-SUBARRAY","si_copy_subarray",5},
......
......@@ -145,7 +145,7 @@
(return-from call-global-loc
(call-exported-function-loc
fname args fd minarg maxarg
(member fname *in-all-symbols-functions*)
(si::mangle-name fname)
return-type))))))
(multiple-value-bind (found fd minarg maxarg)
......
......@@ -122,7 +122,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(assoc 'SI::C-GLOBAL decl)
(setf (fun-global fun) T)))
(no-entry (assoc 'SI::C-LOCAL decl))
cfun exported minarg maxarg)
cfun exported minarg maxarg proclamation-found-p)
(multiple-value-bind (lambda-expr optional-type-checks keyword-type-checks)
(c1lambda-expr lambda-list-and-body name
(si::function-block-name name))
......@@ -135,20 +135,45 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
(if global
(multiple-value-setq (cfun exported) (exported-fname name))
(setf cfun (next-cfun "LC~D~A" name) exported nil))
#+ecl-min
(when (member name c::*in-all-symbols-functions*)
(setf no-entry t))
(if exported
;; Check whether the function was proclaimed to have a certain
;; number of arguments, and otherwise produce a function with
;; a flexible signature.
(progn
(multiple-value-setq (minarg maxarg) (get-proclaimed-narg name))
(multiple-value-setq (minarg maxarg proclamation-found-p)
(get-proclaimed-narg name))
(cmpdebug "~&;;; Function ~A proclaimed (~A,~A)" name minarg maxarg)
(unless minarg
(setf minarg 0 maxarg call-arguments-limit)))
(multiple-value-bind (found-minarg found-maxarg)
(lambda-form-allowed-nargs lambda-expr)
(if proclamation-found-p
;; sanity check that the proclamation matches the actual
;; number of arguments found
(when (or (/= minarg found-minarg) (/= maxarg found-maxarg))
(cmperr "Function ~A takes between ~A and ~A arguments, but is proclaimed to take between ~A and ~A arguments"
name found-minarg found-maxarg minarg maxarg))
;; no proclamation found, produce function with
;; flexible signature
(setf minarg found-minarg))))
(multiple-value-setq (minarg maxarg)
(lambda-form-allowed-nargs lambda-expr)))
#+ecl-min
(when exported
(multiple-value-bind (foundp ignored minarg-core maxarg-core)
(si::mangle-name name)
(declare (ignore ignored))
(when foundp
;; Core functions declared in symbols_list.h are
;; initialized during startup in all_symbols.d
(setf no-entry t)
;; Sanity check that the number of arguments is consistent
;; with the declaration in symbols_list.h. Note that the
;; information about the maximum number of arguments for
;; variadic functions is missing from this declaration.
(when (or (/= minarg minarg-core)
(and (= maxarg minarg)
(/= maxarg maxarg-core)))
(cmperr "Function ~A takes between ~A and ~A arguments, but is declared to take between ~A and ~A arguments in symbols_list.h"
name minarg maxarg minarg-core maxarg-core)))))
(setf (fun-cfun fun) cfun
(fun-exported fun) exported
(fun-closure fun) nil
......
......@@ -1433,7 +1433,7 @@
(clos:funcallable-standard-object t)
t :reader)
#+clos
(proclamation associate-methods-to-gfun (generic-function *)
(proclamation clos::associate-methods-to-gfun (function-name *)
generic-function)
#+clos
(proclamation clos::need-to-make-load-form-p (t t) gen-bool :pure)
......
......@@ -938,10 +938,18 @@
;;; 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.
;;;
;;; Note that if the created C function should take only fixed
;;; arguments, a proclamation for the function type must exist so that
;;; the compiler can produce the correct function signature!
;;;
(in-package "SI")
#+ecl-min
(defvar c::*in-all-symbols-functions*
;; These functions are visible from external.h and their function
;; objects are created in init_all_symbols from the data in
;; symbols_list.h
`(;; 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
......@@ -965,9 +973,8 @@
describe inspect
;; iolib.lsp
read-from-string write-to-string prin1-to-string princ-to-string
y-or-n-p yes-or-no-p string-to-object dribble ext:make-encoding
ext:make-encoding
ext:load-encoding
y-or-n-p yes-or-no-p string-to-object dribble
ext:make-encoding ext:load-encoding
;; listlib.lsp
union nunion intersection nintersection set-difference nset-difference
set-exclusive-or nset-exclusive-or subsetp rassoc-if rassoc-if-not
......@@ -986,13 +993,19 @@
deposit-field
;; packlib.lsp
find-all-symbols apropos apropos-list
;; pprint.lsp
pprint-fill copy-pprint-dispatch pprint-dispatch
pprint-linear pprint-newline pprint-tab pprint-tabular
set-pprint-dispatch pprint-indent
;; predlib.lsp
upgraded-array-element-type upgraded-complex-part-type typep subtypep coerce
do-deftype si::ratiop si::single-float-p si::short-float-p si::double-float-p
si::do-deftype si::ratiop si::single-float-p si::short-float-p si::double-float-p
si::long-float-p
;; process.lsp
ext:run-program
ext:terminate-process
;; seq.lsp
make-sequence concatenate map some every notany notevery map-into
complement
make-sequence concatenate map some every notany notevery map-into complement
;; seqlib.lsp
reduce fill replace
remove remove-if remove-if-not delete delete-if delete-if-not
......@@ -1000,40 +1013,40 @@
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 constantly
si::sequence-count
;; setf.lsp
si::do-defsetf si::do-define-setf-method
;; process.lsp
ext:run-program
ext:terminate-process
;; pprint.lsp
pprint-fill copy-pprint-dispatch pprint-dispatch
pprint-linear pprint-newline pprint-tab pprint-tabular
set-pprint-dispatch pprint-indent
;; trace.lsp
si::traced-old-definition
#+clos
,@'(;; combin.lsp
method-combination-error
invalid-method-error
clos:std-compute-applicable-methods
clos:std-compute-effective-method
method-combination-error
clos:compute-effective-method-function
clos:std-compute-effective-method
;; defclass.lsp
clos::ensure-class
clos:load-defclass
;; kernel.lsp
clos:std-compute-applicable-methods
;; method.lsp
clos:extract-lambda-list
clos:extract-specializer-names
;; predlib.lsp
si::subclassp si::of-class-p
;; print.lsp
clos::need-to-make-load-form-p
;; slotvalue.lsp
slot-makunbound
;; std-slot-value.lsp
clos::standard-instance-access ;; alias clos:funcallable-standard-instance-access
clos::standard-instance-set
subclassp of-class-p
;; boot.lsp
slot-boundp
slot-makunbound
slot-exists-p
slot-value
clos::slot-value-set
slot-exists-p
clos::need-to-make-load-form-p
;; defclass
clos:load-defclass
;; method
clos:extract-lambda-list
clos:extract-specializer-names
)
clos::standard-instance-access ;; alias clos:funcallable-standard-instance-access
clos::standard-instance-set
)
;; cdr-5
ext:array-index-p
......@@ -1060,20 +1073,27 @@
))
(proclaim
;; These functions are not visible in external.h and have no entry in
;; symbols_list.h
`(si::c-export-fname #+ecl-min ,@c::*in-all-symbols-functions*
typecase-error-string find-documentation find-declarations
;; defmacro.lsp
find-documentation find-declarations
si::search-keyword si::check-keyword
si::dm-too-many-arguments si::dm-too-few-arguments
remove-documentation si::get-documentation
si::set-documentation si::expand-set-documentation
remove-documentation
;; defstruct.lsp
si::structure-type-error si::define-structure
;; helpfile.lsp
si::get-documentation si::set-documentation
si::expand-set-documentation
;; packlib.lsp
si::packages-iterator
;; pprint.lsp
si::pprint-logical-block-helper si::pprint-pop-helper
;; seq.lsp
si::make-seq-iterator si::seq-iterator-ref
si::seq-iterator-set si::seq-iterator-next
si::sequence-count
si::structure-type-error si::define-structure
si::coerce-to-list si::coerce-to-vector
si::traced-old-definition
#+formatter
,@'(
......@@ -1085,15 +1105,14 @@
format-relative-tab format-absolute-tab
format-justification
)
#+clos
,@'(;; defclass.lsp
clos::ensure-class
clos::find-slot-definition
;; combin.lsp
clos::simple-code-walker
,@'(;; generic.lsp
clos::associate-methods-to-gfun
;; kernel.lsp
clos::install-method
clos::default-initargs-of
;; std-slot-value.lsp
clos::find-slot-definition
;; clos::generic-function-lambda-list
;; clos::generic-function-argument-precedence-order
;; clos::generic-function-method-combination
......@@ -1105,8 +1124,6 @@
;; clos::method-qualifiers
;; clos::method-function
;; clos::method-plist
clos::associate-methods-to-gfun
;; method.lsp
clos::pop-next-method
)))
)
))
......@@ -2140,6 +2140,7 @@ extern ECL_API cl_object cl_every _ECL_ARGS((cl_narg narg, cl_object V1, cl_obje
extern ECL_API cl_object cl_notany _ECL_ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern ECL_API cl_object cl_notevery _ECL_ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern ECL_API cl_object cl_map_into _ECL_ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern ECL_API cl_object si_sequence_count(cl_object count);
/* seqlib.lsp */
......@@ -2212,10 +2213,10 @@ extern ECL_API cl_object clos_need_to_make_load_form_p(cl_object o, cl_object en
/* defclass.lsp */
extern ECL_API cl_object clos_load_defclass(cl_object name, cl_object superclasses, cl_object slots, cl_object options);
#if 0
/* defclass.lsp */
extern ECL_API cl_object clos_ensure_class _ECL_ARGS((cl_narg narg, cl_object V1, ...));
#if 0
/* kernel.lsp */
extern ECL_API cl_object clos_class_id _ECL_ARGS((cl_narg narg, cl_object V1, ...));
extern ECL_API cl_object clos_class_direct_superclasses _ECL_ARGS((cl_narg narg, cl_object V1, ...));
......
......@@ -57,8 +57,6 @@
(proclaim '(FTYPE (FUNCTION (T T) T) VECTOR-PUSH))
(proclaim '(FTYPE (FUNCTION (T) T) VECTOR-POP))
(proclaim '(FTYPE (FUNCTION (T) T) ASK-FOR-FORM))
(proclaim '(FTYPE (FUNCTION (T T T) T) TYPECASE-ERROR-STRING))
(proclaim '(FTYPE (FUNCTION (T) T) TYPECASE-ERROR-STRINGS))
(proclaim '(FTYPE (FUNCTION (T) T) BOIN-P))
(proclaim '(FTYPE (FUNCTION (T T T T T T T T T) T) MAKE-ACCESS-FUNCTION))
(proclaim '(FTYPE (FUNCTION (T T T T T) T) MAKE-CONSTRUCTOR))
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment