sfos/ecl
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'fix-604' into 'develop'

Browse source 
Fix 604

Closes #534 und #604

See merge request embeddable-common-lisp/ecl!230
This commit is contained in:
Marius Gerbershagen 2020-12-23 14:42:51 +00:00
commit bf664c1887
13 changed files with 2390 additions and 4646 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
msvc/c/Makefile
View file

@ -155,7 +155,7 @@ clean:
-for %f in ($(OBJS) all_symbols.obj all_symbols2.obj) do $(RM) %f
-$(RM) *.pdb
-for %f in (..\ecl\config.h dpp dpp.obj $(DPP) cut.exe cut.obj \
..\eclmin.lib ..\cinit.obj cinit.c symbols_list2.h) \
..\eclmin.lib ..\cinit.obj cinit.c) \
do $(RM) %f
-for %f in (..\ecl\*.h) do $(RM) %f
-for %f in (cut.exe cut.obj dpp.exe dpp.obj) do $(RM) %f
@ -164,7 +164,7 @@ clean:
# Build rules
$(DPP): $(srcdir)/dpp.c $(srcdir)/symbols_list2.h ../ecl/config.h ../ecl/config-internal.h
$(DPP): $(srcdir)/dpp.c $(srcdir)/symbols_list.h ../ecl/config.h ../ecl/config-internal.h
$(CC) /nologo -I.. -I./ $(srcdir)/dpp.c /Fe$@
$(HFILES): ../ecl/config.h.msvc6 ../ecl/config-internal.h.msvc6 Makefile
-mkdir ..\ecl\impl

13
src/c/Makefile.in
View file

@ -102,23 +102,12 @@ clean:
# Build rules
$(DPP): $(srcdir)/dpp.c $(srcdir)/symbols_list2.h
$(DPP): $(srcdir)/dpp.c $(srcdir)/symbols_list.h
if test -f ../CROSS-DPP; then touch dpp; else \
$(TRUE_CC) -I$(srcdir) -I@true_builddir@ -I./ $(srcdir)/dpp.c @CPPFLAGS@ @CFLAGS@ @ECL_CFLAGS@ -o $@ ; \
fi
$(OBJS): $(DPP)
# symbols_list2.h is built this way to allow for an atomic replacement of
# the file. Otherwise we have problem when doing concurrent builds with
# rsync updates of the source tree.
#
$(srcdir)/symbols_list2.h: $(srcdir)/symbols_list.h Makefile
cat $(srcdir)/symbols_list.h | \
sed -e 's%{\([A-Z ]*.*".*"\),[^,]*,[ ]*NULL,[ ]*\([^,]*\),.*}%{\1,NULL,\2}%g' \
-e 's%{\([A-Z ]*.*".*"\),[^,]*,[ ]*\([^,]*\),[ ]*\([^,]*\),.*}%{\1,"\2",\3}%g' \
-e 's%{NULL.*%{NULL,NULL,-1}};%' | \
sed -e 's%"\(IF_[A-Z0-9]*\)(\([^)]*\))"%\1("\2")%g' > tmp.h
mv tmp.h $@
#
# This reduces the overhead of jumping to other functions

12
src/c/all_symbols.d
View file

@ -153,6 +153,9 @@ mangle_name(cl_object output, unsigned char *source, int l)
}
}
}
if (!Null(symbol->symbol.cname)) {
@(return found symbol->symbol.cname minarg maxarg);
}
package = ecl_symbol_package(symbol);
if (Null(package)) {
;
@ -204,7 +207,8 @@ mangle_name(cl_object output, unsigned char *source, int l)
@)
static void
make_this_symbol(int i, cl_object s, int code, const char *name,
make_this_symbol(int i, cl_object s, int code,
const char *name, const char *cname,
cl_objectfn fun, int narg, cl_object value)
{
enum ecl_stype stp;
@ -242,6 +246,7 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
s->symbol.stype = stp;
s->symbol.hpack = package;
s->symbol.name = ecl_make_constant_base_string(name,-1);
s->symbol.cname = ecl_cstring_to_base_string_or_nil(cname);
if (package == cl_core.keyword_package) {
package->pack.external =
_ecl_sethash(s->symbol.name, package->pack.external, s);
@ -285,7 +290,7 @@ void
init_all_symbols(void)
{
int i, code, narg;
const char *name;
const char *name, *cname;
cl_object s, value;
cl_objectfn fun;
@ -297,6 +302,7 @@ init_all_symbols(void)
fun = (cl_objectfn)cl_symbols[i].init.fun;
narg = cl_symbols[i].init.narg;
value = cl_symbols[i].init.value;
make_this_symbol(i, s, code, name, fun, narg, value);
cname = cl_symbols[i].init.translation;
make_this_symbol(i, s, code, name, cname, fun, narg, value);
}
}

2
src/c/dpp.c
View file

@ -93,7 +93,7 @@
#define DPP
#include <ecl/config.h>
#include <ecl/config-internal.h>
#include "symbols_list2.h"
#include "symbols_list.h"
/* #define POOLSIZE 2048 */
#define POOLSIZE 4096

29
src/c/package.d
View file

@ -153,7 +153,6 @@ _ecl_package_to_be_created(const cl_env_ptr env, cl_object name)
static cl_object
find_pending_package(cl_env_ptr env, cl_object name, cl_object nicknames)
{
if (ecl_option_values[ECL_OPT_BOOTED]) {
cl_object l = env->packages_to_be_created;
while (!Null(l)) {
cl_object pair = ECL_CONS_CAR(l);
@ -171,6 +170,14 @@ find_pending_package(cl_env_ptr env, cl_object name, cl_object nicknames)
l = ECL_CONS_CDR(l);
}
}
static cl_object
find_local_nickname_package(cl_object name) {
cl_object p = ecl_symbol_value(@'*package*');
if (ECL_PACKAGEP(p)) {
p = ecl_assoc(name, p->pack.local_nicknames);
if (!Null(p)) return ECL_CONS_CDR(p);
}
return ECL_NIL;
}
@ -222,9 +229,9 @@ ecl_make_package(cl_object name, cl_object nicknames,
local_nicknames = process_local_nicknames_list(local_nicknames);
ECL_WITH_GLOBAL_ENV_WRLOCK_BEGIN(env) {
/* Find a similarly named package in the list of
* packages to be created and use it or try to build a
* new package */
if (ecl_option_values[ECL_OPT_BOOTED]) {
/* Find a similarly named package in the list of packages to be created
* and use it or try to build a new package. */
x = find_pending_package(env, name, nicknames);
if (Null(x)) {
other = ecl_find_package_nolock(name);
@ -243,6 +250,13 @@ ecl_make_package(cl_object name, cl_object nicknames,
}
x->pack.nicknames = CONS(nick, x->pack.nicknames);
} end_loop_for_in;
} else {
/* When we are not booted yet, then we are certain that there are no
duplicated package definitions (nor pending packages or nicknames
overlapping with existing packages). */
x = alloc_package(name);
x->pack.nicknames = nicknames;
}
loop_for_in(use_list) {
cl_object y = ECL_CONS_CAR(use_list);
x->pack.uses = CONS(y, x->pack.uses);
@ -327,11 +341,8 @@ ecl_find_package_nolock(cl_object name)
return name;
name = cl_string(name);
p = ecl_symbol_value(@'*package*');
if (ECL_PACKAGEP(p)) {
p = ecl_assoc(name, p->pack.local_nicknames);
if (!Null(p)) return ECL_CONS_CDR(p);
}
p = find_local_nickname_package(name);
if (!Null(p)) return p;
l = cl_core.packages;
loop_for_on_unsafe(l) {

7
src/c/symbol.d
View file

@ -137,6 +137,13 @@ ecl_make_symbol(const char *s, const char *p)
cl_object
ecl_symbol_value(cl_object s)
{
#ifndef ECL_FINAL
/* Symbols are not initialized yet. This test is issued only during ECL
compilation to ensure, that we have no early references in the core. */
if(cl_num_symbols_in_core < 3) {
ecl_internal_error("SYMBOL-VALUE: symbols are not initialized yet.");
}
#endif
if (Null(s)) {
return s;
} else {

4306
src/c/symbols_list.h
View file

File diff suppressed because it is too large Load diff

2433
src/c/symbols_list2.h
View file

File diff suppressed because it is too large Load diff

4
src/doc/manual/developer-guide/sources.txi
View file

@ -207,9 +207,7 @@
@tab symbols
@item @file{symbols_list.h}
@item @file{symbols_list2.h}
@tab The latter is generated from the first. The first has to contain all
symbols on the system which aren't local.
@tab The file has contains all symbols defined in the core.
@item @file{tcp.d}
@tab stream interface to TCP

5
src/h/external.h
View file

@ -310,9 +310,10 @@ extern ECL_API cl_object si_mangle_name _ECL_ARGS((cl_narg narg, cl_object symbo
typedef union {
struct {
const char *name;
int type;
const char *translation;
void *fun;
short narg;
int narg;
int type;
cl_object value;
} init;
struct ecl_symbol data;

1
src/h/object.h
View file

@ -288,6 +288,7 @@ struct ecl_symbol {
cl_object plist; /* property list */
/* This field coincides with cons.car */
cl_object name; /* print name */
cl_object cname; /* associated C name (or NIL) */
cl_object hpack; /* home package */
/* ECL_NIL for uninterned symbols */
#ifdef ECL_THREADS

1
src/util/emacs.el
View file

@ -201,7 +201,6 @@
"c/structure.d"
"c/symbol.d"
"c/symbols_list.h"
"c/symbols_list2.h"
"c/tcp.d"
"c/threads/atomic.d"
"c/threads/barrier.d"

153
src/util/gen-symbol-table.lisp Normal file
View file

@ -0,0 +1,153 @@
;;; This file is used to generate symbols_list.h. Go to the last page to see
;;; an ad-hoc parser for the old symbols_list.h from which the current
;;; definitions were created. Keep in mind that it is only a helper to
;;; generate the cl_symbols table in a desired format, some manual curation is
;;; also needed (i.e modification of the structure etc).
;;; Utilities
(defvar *pkg+kind-mapping*
`(("CL_ORDINARY" :cl :ordinary)
("CL_SPECIAL" :cl :special)
("CL_CONSTANT" :cl :constant)
("CL_FORM" :cl :form)
("SI_ORDINARY" :si :ordinary)
("SI_SPECIAL" :si :special)
("SI_CONSTANT" :si :constant)
("EXT_ORDINARY" :ext :ordinary)
("EXT_SPECIAL" :ext :special)
("EXT_CONSTANT" :ext :constant)
("EXT_FORM" :ext :form)
("MP_ORDINARY" :mp :ordinary)
("MP_SPECIAL" :mp :special)
("MP_CONSTANT" :mp :constant)
("CLOS_ORDINARY" :clos :ordinary)
("CLOS_SPECIAL" :clos :special)
("CLOS_ORDINARY | PRIVATE" :clos :private)
("KEYWORD" :keyword :constant)
("GRAY_ORDINARY" :gray :ordinary)
("FFI_ORDINARY" :ffi :ordinary)
("FFI_CONSTANT" :ffi :constant)))
(defun pkg+kind->type (pkg kind)
(car (find (list pkg kind) *pkg+kind-mapping* :key #'cdr :test #'equal)))
(defun type->pkg+kind (type)
(cdr (find type *pkg+kind-mapping* :key #'car :test #'equal)))
(defun split-sequence (char string &aux acc)
(do ((line string (subseq line (1+ (position char line)))))
((null (position char line))
(push line acc)
(nreverse (mapcar (lambda (str)
(string-trim '(#\space) str))
acc)))
(push (subseq line 0 (position char line)) acc)))
;;; Parser returns a list of "lines" in a preprocessed form:
;;;
;;; (line-type ,@arguments) ; or
;;; (pack name kind value cfun narg)
;;;
;;; LINE-TYPE is either :macro, :comment, :newline, :end-tag or :entry. PACK
;;; is one of core packages (i.e :ffi), NAME is the symbol name etc. CFUN is
;;; the name of the corresponding C function.
;;;
;;; Entry parsers have versions so it is possible to parse and generate older
;;; versions of the table.
;;;
;;; Example usage:
;;;
#+(or)
(let ((symbols-list (parse-symbols-list "path/to/symbols_list.h" #'v1-parse-entry)))
(generate-symbols-list symbols_list #'v1-generate-entry))
(defun parse-symbols-list (path parser)
(with-open-file (s path)
(do ((line (read-line s nil :eof)
(read-line s nil :eof))
results)
((eq line :eof) (nreverse results))
(push
(cond ((zerop (length line))
`(:newline))
((search "}};" line)
`(:end-tag ,(funcall parser line)))
((case (char line 0)
(#\{ `(:entry ,(funcall parser line)))
(#\# `(:macro ,line))
(otherwise (if (zerop (length line))
`(:newline)
`(:comment ,line))))))
results))))
(defun generate-symbols-list (results generator)
(loop for line in results
do (case (first line)
(:macro (format t "~a~%" (second line)))
(:comment (format t "~a~%" (second line)))
(:newline (terpri))
(:end-tag (format t "~a};~%" (apply generator (second line))))
(:entry (format t "~a,~%" (apply generator (second line)))))))
(defun v1-parse-entry (line)
(destructuring-bind (name package+kind cfun narg value)
(split-sequence #\, (subseq line
(1+ (position #\{ line))
(position #\} line)))
(let* ((pkg-kind (type->pkg+kind package+kind))
(pack (first pkg-kind))
(kind (second pkg-kind))
(narg (parse-integer narg)))
(list pack name kind value cfun narg))))
(defun v1-generate-entry (package name kind value cfun narg)
(let ((type (pkg+kind->type package kind))
(narg (or narg -1)))
(format nil "{~a, ~a, ~a, ~d, ~a}"
name type cfun narg value)))
;;; V2 is defined to unify symbols_list.h files between ECL core and DPP. Also
;;; it gives the all_symbols.d module an insight for the predefined symbol
;;; name mappings (see #534).
(defun v2-parse-entry (line)
(let* ((fun-pos (search "ECL_FUN" line))
(var-pos (search "ECL_VAR" line))
(end-pos (position #\) line :from-end t))
(name (subseq line 1 (1- fun-pos)))
(fun-arg (split-sequence #\, (subseq line
(+ fun-pos 8)
(- var-pos 2))))
(var-arg (split-sequence #\, (subseq line
(+ var-pos 8)
end-pos))))
(destructuring-bind (fun-name cfun narg) fun-arg
(declare (ignore fun-name))
(destructuring-bind (type value) var-arg
(let* ((pkg-kind (type->pkg+kind type))
(pack (first pkg-kind))
(kind (second pkg-kind))
(narg (parse-integer narg)))
(list pack name kind value cfun narg))))))
(defun v2-generate-entry (package name kind value cfun narg)
(let ((type (pkg+kind->type package kind))
(narg (or narg -1))
(fun-name (let* ((start (position #\( cfun :from-end t))
(end (position #\) cfun))
;; Find the "innermost" symbol, i.e for
;; IF_DFFI(ECL_NAME(foobar)) it is foobar
(fname (if start
(subseq cfun
(1+ start)
end)
cfun)))
;; If it is NULL, we want to specify NULL, otherwise we
;; wrap the symbol in quotes to have a string.
(if (string= fname "NULL")
"NULL"
(format nil "~s" fname)))))
(format nil "{~a ECL_FUN(~a, ~a, ~a) ECL_VAR(~a, ~a)}"
name fun-name cfun narg type value)))