Commit e8b1a4b4 authored by jjgarcia's avatar jjgarcia

LOAD-LOGICAL-PATHNAME-TRANSLATIONS now implemented (uses sys:host.translation)

WILD-PATHNAME-P implemented.
PROBE-FILE and TRUENAME now complain when passed a pathname with wild components.
Fixed a bug in GENTEMP.
Some missing symbols are now defined (*PRINT-MARGIN*, etc), even though not used.
Destructuring lambda lists now identify NIL or '() as an empty list.
Fixed INTEGER-LENGTH and LOGCOUNT (they now work with bignums).
SYMBOL-MACROLET now complains about redefinition of global variables.
ENSURE-DIRECTORIES-EXIST now outputs the two requird values and produces some informative messages if requested.
parent a5af1f45
......@@ -1741,6 +1741,9 @@ ECL 0.9d
- COMPILE-FILE now handles files with relative pathnames (like
"foo/faa.lsp").
- In destructuring lambda lists, () or NIL is understood as an empty
list.
* Documentation:
- New manual page documents the scripting facilities of ECL
......@@ -1827,7 +1830,8 @@ ECL 0.9d
class A and this class is renamed as B, the method still
specializes on the same class.
- Implemented WILD-PATHNAME-P, and LOAD-LOGICAL-PATHNAME-TRANSLATIONS.
- Implemented WILD-PATHNAME-P, and LOAD-LOGICAL-PATHNAME-TRANSLATIONS
(which similar to CMUCL looks for the translations at sys:host.translation).
TODO:
=====
......
......@@ -165,7 +165,7 @@ make_this_symbol(int i, cl_object s, int code, const char *name,
case ORDINARY_SYMBOL: stp = stp_ordinary; break;
case SPECIAL_SYMBOL: stp = stp_special; break;
case CONSTANT_SYMBOL: stp = stp_constant; break;
case FORM_SYMBOL: form = 1;
case FORM_SYMBOL: form = 1; stp = stp_ordinary;
}
switch (code & 12) {
case CL_PACKAGE: package = cl_core.lisp_package; break;
......
......@@ -436,8 +436,8 @@ c_var_ref(cl_object var, int allow_symbol_macro)
symbol macro */
if (allow_symbol_macro)
return -1;
FEerror("Internal error: symbol macro ~S used as variable",
1, var);
FEprogram_error("Internal error: symbol macro ~S used as variable",
1, var);
} else {
return Null(special)? n : -2;
}
......@@ -1779,7 +1779,6 @@ c_symbol_macrolet(cl_object args, int flags)
def_list = pop(&args);
body = c_process_declarations(args);
specials = VALUES(3);
c_register_vars(specials);
/* Scan the list of definitions */
for (; !endp(def_list); ) {
......@@ -1788,13 +1787,17 @@ c_symbol_macrolet(cl_object args, int flags)
cl_object expansion = pop(&definition);
cl_object arglist = cl_list(2, @gensym(0), @gensym(0));
cl_object function;
if (name->symbol.stype == stp_special || c_var_ref(name,1) == -2)
if (name->symbol.stype != stp_ordinary ||
c_var_ref(name,1) == -2)
{
FEprogram_error("SYMBOL-MACROLET: Symbol ~A cannot be \
declared special and appear in a symbol-macrolet.", 1, name);
}
definition = cl_list(2, arglist, cl_list(2, @'quote', expansion));
function = make_lambda(name, definition);
c_register_symbol_macro(name, function);
}
c_register_vars(specials);
flags = compile_body(body, flags);
ENV->variables = old_variables;
return flags;
......
......@@ -24,6 +24,7 @@
#include <ecl.h>
#include "ecl-inl.h"
#include "internal.h"
#include <string.h>
#ifdef HAVE_SELECT
#include <sys/select.h>
......@@ -1725,6 +1726,8 @@ cl_open_stream_p(cl_object strm)
/* ANSI and Cltl2 specify that open-stream-p should work
on closed streams, and that a stream is only closed
when #'close has been applied on it */
if (type_of(strm) != t_stream)
FEwrong_type_argument(@'stream', strm);
@(return (strm->stream.mode != smm_closed ? Ct : Cnil))
}
......
......@@ -621,7 +621,7 @@ cl_object
cl_sxhash(cl_object key)
{
cl_index output = _hash_equal(~(cl_hashkey)0, 0, key);
const cl_index mask = (1 << (FIXNUM_BITS - 3)) - 1;
const cl_index mask = ((cl_index)1 << (FIXNUM_BITS - 3)) - 1;
@(return MAKE_FIXNUM(output & mask))
}
......
......@@ -17,6 +17,7 @@
#include "ecl.h"
#include <stdlib.h>
#include "internal.h"
#include "mp.h"
/*
* BIT OPERATIONS FOR FIXNUMS
......@@ -408,7 +409,7 @@ count_bits(cl_object x)
cl_fixnum i = fix(x);
cl_fixnum j = (i < 0) ? ~i : i;
for (count=0 ; j ; j >>= 1)
if (j & 1) count++;
if (j & 1) count++;
break;
}
case t_bignum:
......@@ -417,7 +418,7 @@ count_bits(cl_object x)
else {
cl_object z = big_register0_get();
mpz_com(z->big.big_num, x->big.big_num);
count = mpz_popcount(x->big.big_num);
count = mpz_popcount(z->big.big_num);
big_register_free(z);
}
break;
......@@ -470,12 +471,12 @@ ecl_ash(cl_object x, cl_fixnum w)
static int
int_bit_length(cl_fixnum i)
{
register int count, j;
count = 0;
for (j = 0; j < (sizeof(cl_index)/sizeof(uint8_t))*8-1; j++)
if (((i >> j) & 1) == 1) count = j + 1;
return(count);
int count;
if (i < 0)
i = ~i;
for (count = 0; i && (count < FIXNUM_BITS); i >>= 1, count++)
;
return count;
}
@(defun logior (&rest nums)
......@@ -644,15 +645,13 @@ cl_integer_length(cl_object x)
switch (type_of(x)) {
case t_fixnum:
i = fix(x);
count = int_bit_length((i < 0) ? ~i : i);
count = int_bit_length(i);
break;
case t_bignum: {
/* FIXME! We should not be using internals of GMP here */
int last = abs(x->big.big_size) - 1;
i = x->big.big_limbs[last];
count = last * (sizeof(mp_limb_t) * 8) + int_bit_length(i);
case t_bignum:
if (mpz_sgn(x->big.big_num) < 0)
x = cl_lognot(x);
count = mpz_sizeinbase(x->big.big_num, 2);
break;
}
default:
FEtype_error_integer(x);
}
......
......@@ -607,8 +607,13 @@ cl_object
cl_logical_pathname(cl_object x)
{
x = cl_pathname(x);
if (!x->pathname.logical)
FEerror("~S cannot be coerced to a logical pathname.", 1, x);
if (!x->pathname.logical) {
cl_error(9, @'simple-type-error', @':format-control',
make_simple_string("~S cannot be coerced to a logical pathname."),
@':format-arguments', cl_list(1, x),
@':expected-type', @'logical-pathname',
@':datum', x);
}
@(return x);
}
......@@ -674,8 +679,6 @@ cl_object
coerce_to_file_pathname(cl_object pathname)
{
pathname = coerce_to_physical_pathname(pathname);
if (!Null(cl_wild_pathname_p(1, pathname)))
cl_error(3, @'file-error', @':pathname', pathname);
pathname = cl_merge_pathnames(1, pathname);
#if !defined(cygwin) && !defined(mingw32)
if (pathname->pathname.device != Cnil)
......@@ -696,7 +699,7 @@ coerce_to_physical_pathname(cl_object x)
{
x = cl_pathname(x);
if (x->pathname.logical)
return cl_translate_logical_pathname(x);
return cl_translate_logical_pathname(1, x);
return x;
}
......@@ -1372,11 +1375,9 @@ copy_list_wildcards(cl_object *wilds, cl_object to)
return l;
}
cl_object
cl_translate_pathname(cl_object source, cl_object from, cl_object to)
{
@(defun translate-pathname (source from to &key)
cl_object wilds, out, d;
@
source = cl_pathname(source);
from = cl_pathname(from);
to = cl_pathname(to);
......@@ -1434,26 +1435,25 @@ cl_translate_pathname(cl_object source, cl_object from, cl_object to)
FEerror("~S is not a specialization of path ~S", 2, source, from);
error2:
FEerror("Number of wildcards in ~S do not match ~S", 2, from, to);
}
@)
cl_object
cl_translate_logical_pathname(cl_object source)
{
@(defun translate-logical-pathname (source &key)
cl_object l, pair;
source = cl_pathname(source);
if (!source->pathname.logical)
goto error;
cl_object pathname;
@
pathname = cl_pathname(source);
begin:
l = @si::pathname-translations(1, source->pathname.host);
if (!pathname->pathname.logical) {
@(return pathname)
}
l = @si::pathname-translations(1, pathname->pathname.host);
for(; !endp(l); l = CDR(l)) {
pair = CAR(l);
if (!Null(cl_pathname_match_p(source, CAR(pair)))) {
source = cl_translate_pathname(source, CAR(pair), CADR(pair));
if (source->pathname.logical)
goto begin;
return source;
if (!Null(cl_pathname_match_p(pathname, CAR(pair)))) {
pathname = cl_translate_pathname(3, pathname, CAR(pair),
CADR(pair));
goto begin;
}
}
error:
FEerror("~S admits no logical pathname translations", 1, source);
}
FEerror("~S admits no logical pathname translations", 1, pathname);
@)
......@@ -302,9 +302,8 @@ cl_symbol_name(cl_object x)
@
assert_type_string(prefix);
assert_type_package(pack);
s = cl_alloc_adjustable_string(64);
ONCE_MORE:
output = make_string_output_stream_from_string(s);
output = make_string_output_stream(64);
bds_bind(@'*print-base*', MAKE_FIXNUM(10));
bds_bind(@'*print-radix*', Cnil);
princ(prefix, output);
......
......@@ -72,9 +72,13 @@ cl_symbols[] = {
{"*PRINT-GENSYM*", CL_SPECIAL, NULL, -1, Ct},
{"*PRINT-LENGTH*", CL_SPECIAL, NULL, -1, Cnil},
{"*PRINT-LEVEL*", CL_SPECIAL, NULL, -1, Cnil},
{"*PRINT-LINES*", CL_SPECIAL, NULL, -1, Cnil},
{"*PRINT-MISER-WIDTH*", CL_SPECIAL, NULL, -1, Cnil},
{"*PRINT-PPRINT-DISPATCH*", CL_SPECIAL, NULL, -1, Cnil},
{"*PRINT-PRETTY*", CL_SPECIAL, NULL, -1, Ct},
{"*PRINT-RADIX*", CL_SPECIAL, NULL, -1, Cnil},
{"*PRINT-READABLY*", CL_SPECIAL, NULL, -1, Cnil},
{"*PRINT-RIGHT-MARGIN*", CL_SPECIAL, NULL, -1, Cnil},
{"*QUERY-IO*", CL_SPECIAL, NULL, -1, OBJNULL},
{"*RANDOM-STATE*", CL_SPECIAL, NULL, -1, OBJNULL},
{"*READ-BASE*", CL_SPECIAL, NULL, -1, MAKE_FIXNUM(10)},
......@@ -274,6 +278,7 @@ cl_symbols[] = {
{"CONTROL-ERROR", CL_ORDINARY, NULL, -1, OBJNULL},
{"COPY-ALIST", CL_ORDINARY, cl_copy_alist, 1, OBJNULL},
{"COPY-LIST", CL_ORDINARY, cl_copy_list, 1, OBJNULL},
{"COPY-PPRINT-DISPATCH", CL_ORDINARY, NULL, -1, OBJNULL},
{"COPY-READTABLE", CL_ORDINARY, cl_copy_readtable, -1, OBJNULL},
{"COPY-SEQ", CL_ORDINARY, cl_copy_seq, 1, OBJNULL},
{"COPY-STRUCTURE", CL_ORDINARY, cl_copy_structure, 1, OBJNULL},
......@@ -663,6 +668,16 @@ cl_symbols[] = {
{"POSITION-IF", CL_ORDINARY, NULL, -1, OBJNULL},
{"POSITION-IF-NOT", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT", CL_ORDINARY, cl_pprint, -1, OBJNULL},
{"PPRINT-DISPATCH", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT-EXIT-IF-LIST-EXHAUSTED", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT-FILL", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT-INDENT", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT-LINEAR", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT-LOGICAL-BLOCK", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT-NEWLINE", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT-POP", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT-TAB", CL_ORDINARY, NULL, -1, OBJNULL},
{"PPRINT-TABULAR", CL_ORDINARY, NULL, -1, OBJNULL},
{"PRIN1", CL_ORDINARY, cl_prin1, -1, OBJNULL},
{"PRIN1-TO-STRING", CL_ORDINARY, NULL, -1, OBJNULL},
{"PRINC", CL_ORDINARY, cl_princ, -1, OBJNULL},
......@@ -753,6 +768,7 @@ cl_symbols[] = {
{"SET-DISPATCH-MACRO-CHARACTER", CL_ORDINARY, cl_set_dispatch_macro_character, -1, OBJNULL},
{"SET-EXCLUSIVE-OR", CL_ORDINARY, NULL, -1, OBJNULL},
{"SET-MACRO-CHARACTER", CL_ORDINARY, cl_set_macro_character, -1, OBJNULL},
{"SET-PPRINT-DISPATCH", CL_ORDINARY, NULL, -1, OBJNULL},
{"SET-SYNTAX-FROM-CHAR", CL_ORDINARY, cl_set_syntax_from_char, -1, OBJNULL},
{"SETF", CL_ORDINARY, NULL, -1, OBJNULL},
{"SETQ", CL_FORM, NULL, -1, OBJNULL},
......@@ -865,8 +881,8 @@ cl_symbols[] = {
{"THROW", CL_FORM, NULL, -1, OBJNULL},
{"TIME", CL_ORDINARY, NULL, -1, OBJNULL},
{"TRACE", CL_ORDINARY, NULL, -1, OBJNULL},
{"TRANSLATE-LOGICAL-PATHNAME", CL_ORDINARY, cl_translate_logical_pathname, 1, OBJNULL},
{"TRANSLATE-PATHNAME", CL_ORDINARY, cl_translate_pathname, 3, OBJNULL},
{"TRANSLATE-LOGICAL-PATHNAME", CL_ORDINARY, cl_translate_logical_pathname, -1, OBJNULL},
{"TRANSLATE-PATHNAME", CL_ORDINARY, cl_translate_pathname, -1, OBJNULL},
{"TREE-EQUAL", CL_ORDINARY, cl_tree_equal, -1, OBJNULL},
{"TRUENAME", CL_ORDINARY, cl_truename, 1, OBJNULL},
{"TRUNCATE", CL_ORDINARY, cl_truncate, -1, OBJNULL},
......@@ -957,6 +973,8 @@ cl_symbols[] = {
{"INVALID-METHOD-ERROR", CL_ORDINARY, NULL, -1, OBJNULL},
{"MAKE-INSTANCE", CL_ORDINARY, NULL, -1, OBJNULL},
{"MAKE-INSTANCES-OBSOLETE", CL_ORDINARY, NULL, -1, OBJNULL},
{"MAKE-LOAD-FORM", CL_ORDINARY, NULL, -1, OBJNULL},
{"MAKE-LOAD-FORM-SAVING-SLOTS", CL_ORDINARY, NULL, -1, OBJNULL},
{"MAKE-METHOD", CL_ORDINARY, NULL, -1, OBJNULL},
{"METHOD", CL_ORDINARY, NULL, -1, OBJNULL},
{"METHOD-COMBINATION-ERROR", CL_ORDINARY, NULL, -1, OBJNULL},
......
......@@ -157,12 +157,13 @@ cl_truename(cl_object pathname)
pathname = coerce_to_file_pathname(pathname);
if (pathname->pathname.directory == Cnil)
pathname = merge_pathnames(previous, pathname, @':newest');
if (cl_wild_pathname_p(1, pathname) != Cnil)
cl_error(3, @'file-error', @':pathname', pathname);
/* First we ensure that PATHNAME itself does not point to a symlink. */
filename = si_follow_symlink(pathname);
if (filename == Cnil) {
FEerror("truename: file ~S does not exist or cannot be accessed", 1,
pathname);
FEcannot_open(pathname);
} else {
filename = cl_parse_namestring(3, filename, Cnil, Cnil);
}
......@@ -253,6 +254,8 @@ cl_delete_file(cl_object file)
cl_object
cl_probe_file(cl_object file)
{
if (cl_wild_pathname_p(1, file) != Cnil)
cl_error(3, @'file-error', @':pathname', file);
@(return (si_file_kind(file, Ct) != Cnil? cl_truename(file) : Cnil))
}
......
......@@ -1002,8 +1002,8 @@ extern cl_object cl_directory_namestring(cl_object pname);
extern cl_object cl_host_namestring(cl_object pname);
extern cl_object si_logical_pathname_p(cl_object pname);
extern cl_object cl_pathname_match_p(cl_object path, cl_object mask);
extern cl_object cl_translate_pathname(cl_object source, cl_object from, cl_object to);
extern cl_object cl_translate_logical_pathname(cl_object source);
extern cl_object cl_translate_pathname _ARGS((int narg, cl_object source, cl_object from, cl_object to, ...));
extern cl_object cl_translate_logical_pathname _ARGS((int narg, cl_object source, ...));
extern cl_object cl_parse_namestring _ARGS((int narg, cl_object thing, ...));
extern cl_object cl_parse_logical_namestring _ARGS((int narg, cl_object thing, ...));
extern cl_object cl_merge_pathnames _ARGS((int narg, cl_object path, ...));
......@@ -1387,7 +1387,6 @@ extern void assert_type_symbol(cl_object p);
extern void assert_type_package(cl_object p);
extern void assert_type_string(cl_object p);
extern void assert_type_cons(cl_object p);
extern void assert_type_stream(cl_object p);
extern void assert_type_readtable(cl_object p);
extern void assert_type_hash_table(cl_object p);
extern void assert_type_array(cl_object p);
......
......@@ -154,9 +154,9 @@
ppn))
(dm-v (v init)
(cond ((symbolp v)
(cond ((and v (symbolp v))
(push (if init (list v init) v) *dl*))
((atom v)
((and v (atom v))
(error "destructure: ~A is not a list nor a symbol" v))
((eq (first v) '&whole)
(let ((whole-var (second v)))
......
......@@ -22,7 +22,7 @@
(values (member t nil)))
(let ((*autoload-translations* nil))
(unless (or (string-equal host "sys")
(find-logical-host host nil))
(si::pathname-translations host))
(with-open-file (in-str (make-pathname :defaults "sys:"
:name (string-downcase host)
:type "translations"))
......@@ -38,13 +38,13 @@
"Syntax: (time form)
Evaluates FORM, outputs the realtime and runtime used for the evaluation to
*TRACE-OUTPUT*, and then returns all values of FORM."
(let*((real-start (gentemp))
(real-end (gentemp))
(run-start (gentemp))
(run-end (gentemp))
#-boehm-gc(gc-start (gentemp))
(gc-end (gentemp))
(x (gentemp)))
(let*((real-start (gensym))
(real-end (gensym))
(run-start (gensym))
(run-end (gensym))
#-boehm-gc(gc-start (gensym))
(gc-end (gensym))
(x (gensym)))
`(let*((,real-start (get-internal-real-time))
(,run-start (get-internal-run-time))
#-boehm-gc(,gc-start (sys:gc-time))
......@@ -155,13 +155,23 @@ Returns the current day-and-time as nine values:
Sunday is the *last* day of the week!!"
(decode-universal-time (get-universal-time)))
(defun ensure-directories-exist (a-pathname)
(let* (d)
(defun ensure-directories-exist (a-pathname &key verbose)
(let* ((created nil)
d)
(when (or (wild-pathname-p a-pathname :directory)
(wild-pathname-p a-pathname :host)
(wild-pathname-p a-pathname :device))
(error 'file-error :pathname a-pathname))
(dolist (item (pathname-directory a-pathname))
(setf d (nconc d (list item)))
(let ((p (make-pathname :directory d :defaults a-pathname)))
(let ((p (make-pathname :name nil :type nil :directory d
:defaults a-pathname)))
(unless (or (symbolp item) (si::file-kind p nil))
(si::mkdir p #o777))))))
(setf created t)
(when verbose
(format t "~%;;; Making directory ~A" p))
(si::mkdir p #o777))))
(values a-pathname created)))
(defmacro with-hash-table-iterator ((iterator package) &body body)
`(let ((,iterator (hash-table-iterator ,package)))
......
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