mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-02-21 06:30:23 -08:00
Code Issues Projects Releases Packages Wiki Activity

Support for hierarchical package names

Browse source
This commit is contained in:
jgarcia 2006-10-26 16:39:14 +00:00
parent 161e5a0fe8
commit baa9407388
16 changed files with 5325 additions and 3499 deletions
Download patch file Download diff file Expand all files Collapse all files

1
msvc/ecl-threads.def
View file

@ -1297,6 +1297,7 @@ EXPORTS
cl_apropos
cl_apropos_list
si_packages_iterator
si_find_relative_package
; predlib.lsp

1
msvc/ecl.def
View file

@ -1279,6 +1279,7 @@ EXPORTS
cl_apropos
cl_apropos_list
si_packages_iterator
si_find_relative_package
; predlib.lsp

2
src/CHANGELOG
View file

@ -128,6 +128,8 @@ ECL 1.0:
allows to have, in the same file, a class definition and a constant which
is an object of that class.
- Support for hierarchical package names, as in Allegro Common-Lisp.
* Contributed code:
- New examples: cmdline/ls.lsp, ffi/uffi.lsp

6
src/c/cinit.d
View file

@ -63,6 +63,12 @@ cl_vector_push_extend(cl_narg narg, cl_object elt, cl_object vector, ...)
return funcall(3, @'VECTOR-PUSH-EXTEND', elt, vector);
}
extern cl_object
si_find_relative_package(cl_narg narg, cl_object package, ...)
{
@(return Cnil);
}
static cl_object si_simple_toplevel ()
{
cl_object sentence;

4
src/c/main.d
View file

@ -468,6 +468,10 @@ cl_boot(int argc, char **argv)
#endif
#ifdef ECL_SHORT_FLOAT
ADD_FEATURE("SHORT-FLOAT");
#endif
#ifdef ECL_RELATIVE_PACKAGE_NAMES
ADD_FEATURE("RELATIVE-PACKAGE-NAMES");
ECL_SET(@'SI::*RELATIVE-PACKAGE-NAMES*', Ct);
#endif
/* This is assumed in all systems */
ADD_FEATURE("IEEE-FLOATING-POINT");

7
src/c/package.d
View file

@ -239,6 +239,13 @@ ecl_find_package_nolock(cl_object name)
if (member_string_eq(name, p->pack.nicknames))
return p;
}
#ifdef ECL_RELATIVE_PACKAGE_NAMES
/* Note that this function may actually be called _before_ symbols are set up
* and bound! */
if (ecl_booted && SYM_VAL(@'si::*relative-package-names*') != Cnil) {
return si_find_relative_package(1, name);
}
#endif
return Cnil;
}

8
src/c/symbols_list.h
View file

@ -1651,6 +1651,14 @@ cl_symbols[] = {
{SYS_ "GET-FINALIZER", SI_ORDINARY, si_get_finalizer, 1, OBJNULL},
{SYS_ "SET-FINALIZER", SI_ORDINARY, si_set_finalizer, 2, OBJNULL},
#ifdef ECL_RELATIVE_PACKAGE_NAMES
{SYS_ "*RELATIVE-PACKAGE-NAMES*", SI_SPECIAL, NULL, -1, Cnil},
{KEY_ "RELATIVE-PACKAGE-NAMES", KEYWORD, NULL, -1, OBJNULL},
{SYS_ "FIND-RELATIVE-PACKAGE", SI_ORDINARY, si_find_relative_package, -1, OBJNULL},
{SYS_ "PACKAGE-PARENT", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "PACKAGE-CHILDREN", SI_ORDINARY, NULL, -1, OBJNULL},
#endif
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

8
src/c/symbols_list2.h
View file

@ -1651,6 +1651,14 @@ cl_symbols[] = {
{SYS_ "GET-FINALIZER","si_get_finalizer"},
{SYS_ "SET-FINALIZER","si_set_finalizer"},
#ifdef ECL_RELATIVE_PACKAGE_NAMES
{SYS_ "*RELATIVE-PACKAGE-NAMES*",NULL},
{KEY_ "RELATIVE-PACKAGE-NAMES",NULL},
{SYS_ "FIND-RELATIVE-PACKAGE","si_find_relative_package"},
{SYS_ "PACKAGE-PARENT",NULL},
{SYS_ "PACKAGE-CHILDREN",NULL},
#endif
/* Tag for end of list */
{NULL,NULL}};

1
src/cmp/sysfun.lsp
View file

@ -1400,6 +1400,7 @@ type_of(#0)==t_bitvector")
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

8648
src/configure vendored
View file

File diff suppressed because it is too large Load diff

21
src/configure.in
View file

@ -166,16 +166,22 @@ AC_ARG_ENABLE(unicode,
[], [enable_unicode=no])
AC_ARG_ENABLE(longdouble,
AS_HELP_STRING( [--enable-long-double],
AS_HELP_STRING( [--enable-longdouble],
[include support for long double]
[(default=NO)]),
[longdouble=${enableval}], [longdouble=no])
[enable_longdouble=${enableval}], [enable_longdouble=no])
AC_ARG_ENABLE(c99complex,
AS_HELP_STRING( [--enable-c99-complex],
[include support for C complex type]
[(default=NO)]),
[c99complex=${enableval}], [c99complex=no])
[enable_c99complex=${enableval}], [enable_c99complex=no])
AC_ARG_ENABLE(hpack,
AS_HELP_STRING( [--enable-hierarchical-packages],
[hierarchical package names]
[(default=YES)]),
[enable_hpack=${enableval}], [enable_hpack=yes])
dnl -----------------------------------------------------------------------
dnl Installation directories
@ -391,14 +397,13 @@ ECL_FILE_STRUCTURE
ECL_FFI
ECL_FPE_MODEL
if test "$longdouble" != "no" ; then
if test "$enable_longdouble" != "no" ; then
AC_CHECK_TYPES([long double])
fi
if test "$c99complex" != "no" ; then
if test "$enable_c99complex" != "no" ; then
AC_CHECK_TYPES([double complex, float complex],[],[],[#include <complex.h>])
fi
dnl -----------------------------------------------------------------------
dnl Study the call conventions
ECL_STACK_DIRECTION
@ -517,6 +522,10 @@ if test "${enable_unicode}" = "yes"; then
AC_DEFINE(ECL_UNICODE, [1], [Support for Unicode])
fi
if test "${enable_hpack}" = "yes"; then
AC_DEFINE(ECL_RELATIVE_PACKAGE_NAMES, [1], [Hierarchical package names])
fi
dnl ----------------------------------------------------------------------
dnl Configure included Boehm GC if needed
AC_SUBST(ECL_BOEHM_GC_HEADER)

2
src/h/config.h.in
View file

@ -169,6 +169,8 @@ typedef unsigned @CL_FIXNUM_TYPE@ cl_hashkey;
/* We have non-portable implementation of FFI calls */
#undef ECL_DYNAMIC_FFI
/* We use hierarchical package names, like in Allegro CL */
#undef ECL_RELATIVE_PACKAGE_NAMES
/*
* SYSTEM FEATURES:

1
src/h/external.h
View file

@ -1594,6 +1594,7 @@ extern cl_object cl_deposit_field _ARGS((cl_narg narg, cl_object V1, cl_object V
extern cl_object cl_find_all_symbols _ARGS((cl_narg, cl_object V1, ...));
extern cl_object cl_apropos _ARGS((cl_narg arg, cl_object V1, ...));
extern cl_object cl_apropos_list _ARGS((cl_narg arg, cl_object V1, ...));
extern cl_object si_find_relative_package _ARGS((cl_narg narg, cl_object pack_name, ...));
/* predlib.lsp */

1
src/h/internal.h
View file

@ -257,7 +257,6 @@ extern cl_object si_get_library_pathname(void);
/*
* Fake several ISO C99 mathematical functions
*/
#define _GNU_SOURCE
#ifndef HAVE_EXPF
# define expf(x) exp((float)x)

4
src/lsp/cmdline.lsp
View file

@ -23,7 +23,7 @@
(defvar *help-message* "
Usage: ecl [-? | --help]
[-dir dir] [-load file] [-shell file] [-eval expr] [-rc | -norc]
[-dir dir] [-load file] [-shell file] [-eval expr] [-rc | -norc] [-hp | -nohp]
[[-o ofile] [-c [cfile]] [-h [hfile]] [-data [datafile]] [-s] [-q]
-compile file]
@ -72,6 +72,8 @@ Usage: ecl [-? | --help]
("-h" 1 (setq h-file 1))
("-data" 1 (setq data-file 1))
("-q" 0 (setq verbose nil))
("-hp" 0 (setf *relative-package-names* t))
("-nohp" 0 (setf *relative-package-names* nil))
("-s" 0 (setq system-p t))))
(defun produce-init-code (option-list rules)

109
src/lsp/packlib.lsp
View file

@ -171,3 +171,112 @@ If PACKAGE is non-NIL, then only the specified PACKAGE is searched."
(when (search string (string symbol) :test #'char-equal)
(setq list (cons symbol list))))))
list))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; HIERARCHICAL PACKAGE NAMES
;;
;; Code provided by Franz Inc. to the public domain and adapted for ECL.
;;
(defun find-relative-package (name)
;; Given a package name, a string, do a relative package name lookup.
;;
;; It is intended that this function will be called from find-package.
;; In Allegro, find-package calls package-name-to-package, and the latter
;; function calls this function when it does not find the package.
;;
;; Because this function is called via the reader, we want it to be as
;; fast as possible.
(declare (optimize speed))
(flet ((relative-to (package name)
(if (string= "" name)
package
(find-package (concatenate 'simple-string (package-name package) "." name))))
(find-non-dot (name)
(do* ((len (length name))
(i 0 (1+ i)))
((= i len) nil)
(declare (fixnum len i))
(when (char/= #\. (schar name i)) (return i)))))
(when (char= #\. (char name 0))
(let* ((last-dot-position (or (find-non-dot name) (length name)))
(n-dots last-dot-position)
(name (subseq name last-dot-position)))
(cond ((= 1 n-dots)
;; relative to current package
(relative-to *package* name))
(t
;; relative to our (- n-dots 1)'th parent
(let ((p *package*)
tmp)
(dotimes (i (1- n-dots))
(when (not (setq tmp (package-parent p)))
(error "The parent of ~a does not exist." p))
(setq p tmp))
(relative-to p name))))))))
(defun package-parent (package-specifier)
;; Given package-specifier, a package, symbol or string, return the
;; parent package. If there is not a parent, signal an error.
;;
;; Because this function is called via the reader, we want it to be as
;; fast as possible.
(declare (optimize speed))
(flet ((find-last-dot (name)
(do* ((len (1- (length name)))
(i len (1- i)))
((= i -1) nil)
(declare (fixnum len i))
(when (char= #\. (schar name i)) (return i)))))
(let* ((child (cond ((packagep package-specifier)
(package-name package-specifier))
((symbolp package-specifier)
(symbol-name package-specifier))
((stringp package-specifier) package-specifier)
(t (error "Illegal package specifier: ~s."
package-specifier))))
(dot-position (find-last-dot child)))
(cond (dot-position
(let ((parent (subseq child 0 dot-position)))
(or (package-name-to-package parent)
(error "The parent of ~a does not exist." child))))
(t (error "There is no parent of ~a." child))))))
(defun package-children (package-specifier &key (recurse t))
;; Given package-specifier, a package, symbol or string, return all the
;; packages which are in the hierarchy "under" the given package. If
;; :recurse is nil, then only return the immediate children of the
;; package.
;;
;; While this function is not called via the reader, we do want it to be
;; fast.
(declare (optimize speed))
(let* ((res ())
(parent (cond ((packagep package-specifier)
(package-name package-specifier))
((symbolp package-specifier)
(symbol-name package-specifier))
((stringp package-specifier) package-specifier)
(t (error "Illegal package specifier: ~s." package-specifier))))
(parent-prefix (concatenate 'simple-string parent ".")))
(labels
((string-prefix-p (prefix string)
;; Return length of `prefix' if `string' starts with `prefix'.
;; We don't use `search' because it does much more than we need
;; and this version is about 10x faster than calling `search'.
(let ((prefix-len (length prefix))
(seq-len (length string)))
(declare (fixnum prefix-len seq-len))
(when (>= prefix-len seq-len)
(return-from string-prefix-p nil))
(do* ((i 0 (1+ i)))
((= i prefix-len) prefix-len)
(declare (fixnum i))
(when (not (char= (schar prefix i) (schar string i)))
(return nil))))))
(dolist (package (list-all-packages))
(let* ((package-name (package-name package))
(prefix (string-prefix-p parent-prefix package-name)))
(when (and prefix (or recurse (not (find #\. package-name :start prefix))))
(pushnew package res)))))))