mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2026-01-13 12:52:08 -08:00
Remove public function putprop(); use si_putprop() instead.
Removed public functions FEtype_error_plist(). Low level function getf() and get() renamed as ecl_get[f](). Simplified the loops which deal with property lists. Assertions ASSERT and CHECK-TYPE moved from conditions.lisp to assert.lisp; old definitions removed.
This commit is contained in:
jjgarcia
parent
aabafc3c6c
commit
8bb27d3094
15 changed files with 144 additions and 218 deletions
|
|
@ -1264,8 +1264,8 @@ ECLS 0.9
|
|||
- The interpreter now detects syntax errors in function calls: such
|
||||
as in (setq a ("foo")).
|
||||
|
||||
- Functions remf() and remprop() removed. Use si_rem_f and cl_remprop
|
||||
instead.
|
||||
- Functions remf(), remprop() and putprop() removed. Use si_rem_f,
|
||||
cl_remprop and cl_putprop instead.
|
||||
|
||||
* ANSI compatibility:
|
||||
|
||||
|
|
|
|||
|
|
@ -70,7 +70,7 @@ si_setf_namep(cl_object arg)
|
|||
if (mflag)
|
||||
FEerror("Cannot define a macro with name (SETF ~S).", 1, fun);
|
||||
fun = CADR(fun);
|
||||
putprop(fun, sym, @'si::setf-symbol');
|
||||
si_putprop(fun, sym, @'si::setf-symbol');
|
||||
cl_remprop(fun, @'si::setf-lambda');
|
||||
cl_remprop(fun, @'si::setf-method');
|
||||
cl_remprop(fun, @'si::setf-update');
|
||||
|
|
@ -94,8 +94,7 @@ si_setf_namep(cl_object arg)
|
|||
}
|
||||
fun->symbol.mflag = !Null(macro);
|
||||
if (pprint != Cnil)
|
||||
fun->symbol.plist
|
||||
= putf(fun->symbol.plist, pprint, @'si::pretty-print-format');
|
||||
si_putprop(fun, pprint, @'si::pretty-print-format');
|
||||
@(return fun)
|
||||
@)
|
||||
|
||||
|
|
|
|||
10
src/c/eval.d
10
src/c/eval.d
|
|
@ -127,10 +127,10 @@ link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list args)
|
|||
out = APPLY_fixed(narg, fun->cfun.entry, cl_stack_top - narg);
|
||||
} else {
|
||||
if (pLK) {
|
||||
putprop(sym, CONS(CONS(make_unsigned_integer((cl_index)pLK),
|
||||
make_unsigned_integer((cl_index)*pLK)),
|
||||
getf(sym->symbol.plist, @'si::link-from', Cnil)),
|
||||
@'si::link-from');
|
||||
si_putprop(sym, CONS(CONS(make_unsigned_integer((cl_index)pLK),
|
||||
make_unsigned_integer((cl_index)*pLK)),
|
||||
ecl_get(sym, @'si::link-from', Cnil)),
|
||||
@'si::link-from');
|
||||
*pLK = fun->cfun.entry;
|
||||
}
|
||||
out = APPLY(narg, fun->cfun.entry, cl_stack + sp);
|
||||
|
|
@ -165,7 +165,7 @@ si_unlink_symbol(cl_object s)
|
|||
|
||||
if (!SYMBOLP(s))
|
||||
FEtype_error_symbol(s);
|
||||
pl = getf(s->symbol.plist, @'si::link-from', Cnil);
|
||||
pl = ecl_get(s, @'si::link-from', Cnil);
|
||||
if (!endp(pl)) {
|
||||
for (; !endp(pl); pl = CDR(pl))
|
||||
*(void **)(fixnnint(CAAR(pl))) = (void *)fixnnint(CDAR(pl));
|
||||
|
|
|
|||
|
|
@ -32,11 +32,11 @@ search_symbol_macro(cl_object name, cl_object env)
|
|||
{
|
||||
cl_object record = assq(name, CAR(env));
|
||||
if (Null(record))
|
||||
return get(name, @'si::symbol-macro', Cnil);
|
||||
return ecl_get(name, @'si::symbol-macro', Cnil);
|
||||
else if (CADR(record) == @'si::symbol-macro')
|
||||
return CADDR(record);
|
||||
return CADDR(record);
|
||||
else
|
||||
return Cnil;
|
||||
return Cnil;
|
||||
}
|
||||
|
||||
cl_object
|
||||
|
|
|
|||
|
|
@ -527,9 +527,8 @@ call_structure_print_function(cl_object x, int level)
|
|||
#ifdef CLOS
|
||||
funcall(3, @'print-object', x, PRINTstream);
|
||||
#else
|
||||
funcall(4, getf(x->str.name->symbol.plist,
|
||||
@'si::structure-print-function', Cnil),
|
||||
x, PRINTstream, MAKE_FIXNUM(level));
|
||||
funcall(4, ecl_get(x->str.name, @'si::structure-print-function', Cnil),
|
||||
x, PRINTstream, MAKE_FIXNUM(level));
|
||||
#endif
|
||||
bds_unwind_n(10);
|
||||
} CL_UNWIND_PROTECT_EXIT {
|
||||
|
|
@ -979,8 +978,7 @@ _write_object(cl_object x, int level)
|
|||
write_ch(SET_INDENT);
|
||||
if (PRINTpretty && CAR(x) != OBJNULL &&
|
||||
type_of(CAR(x)) == t_symbol &&
|
||||
(r = getf(CAR(x)->symbol.plist,
|
||||
@'si::pretty-print-format', Cnil)) != Cnil)
|
||||
(r = ecl_get(CAR(x), @'si::pretty-print-format', Cnil)) != Cnil)
|
||||
goto PRETTY_PRINT_FORMAT;
|
||||
for (i = 0; ; i++) {
|
||||
if (!PRINTreadably && PRINTlength >= 0 && i >= PRINTlength) {
|
||||
|
|
@ -1146,8 +1144,8 @@ _write_object(cl_object x, int level)
|
|||
if (type_of(x->str.name) != t_symbol)
|
||||
FEwrong_type_argument(@'symbol', x->str.name);
|
||||
if (PRINTstructure ||
|
||||
Null(getf(x->str.name->symbol.plist,
|
||||
@'si::structure-print-function', Cnil))) {
|
||||
Null(ecl_get(x->str.name, @'si::structure-print-function', Cnil)))
|
||||
{
|
||||
write_str("#S");
|
||||
/* structure_to_list conses slot names and values into a list to be printed.
|
||||
* print shouldn't allocate memory - Beppe
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ structure_subtypep(cl_object x, cl_object y)
|
|||
return(FALSE);
|
||||
if (x == y)
|
||||
return(TRUE);
|
||||
x = get(x, @'si::structure-include', Cnil);
|
||||
x = ecl_get(x, @'si::structure-include', Cnil);
|
||||
} while (x != Cnil);
|
||||
return(FALSE);
|
||||
}
|
||||
|
|
@ -62,8 +62,7 @@ structure_to_list(cl_object x)
|
|||
cl_object *p, r, s;
|
||||
int i, n;
|
||||
|
||||
s = getf(SNAME(x)->symbol.plist,
|
||||
@'si::structure-slot-descriptions', Cnil);
|
||||
s = ecl_get(SNAME(x), @'si::structure-slot-descriptions', Cnil);
|
||||
p = &CDR(r = CONS(SNAME(x), Cnil));
|
||||
for (i=0, n=SLENGTH(x); !endp(s) && i<n; s=CDR(s), i++) {
|
||||
p = &(CDR(*p = CONS(cl_car(CAR(s)), Cnil)));
|
||||
|
|
|
|||
120
src/c/symbol.d
120
src/c/symbol.d
|
|
@ -27,6 +27,8 @@ cl_object cl_token;
|
|||
static cl_object gensym_prefix;
|
||||
static cl_object gentemp_prefix;
|
||||
static cl_object gentemp_counter;
|
||||
static void FEtype_error_plist(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
|
||||
|
||||
cl_object
|
||||
cl_make_symbol(cl_object str)
|
||||
|
|
@ -98,23 +100,31 @@ symbol_value(cl_object s)
|
|||
return(SYM_VAL(s));
|
||||
}
|
||||
|
||||
cl_object
|
||||
getf(cl_object place, cl_object indicator, cl_object deflt)
|
||||
static void
|
||||
FEtype_error_plist(cl_object x)
|
||||
{
|
||||
cl_object slow, l;
|
||||
cl_error(9, @'simple-type-error', @':format-control',
|
||||
make_simple_string("Not a valid property list ~D"),
|
||||
@':format-arguments', cl_list(1, x),
|
||||
@':expected-type', @'list',
|
||||
@':datum', x);
|
||||
}
|
||||
|
||||
/* This loop guarantees finishing for circular lists */
|
||||
slow = l = place;
|
||||
while (CONSP(l)) {
|
||||
cl_object
|
||||
ecl_getf(cl_object place, cl_object indicator, cl_object deflt)
|
||||
{
|
||||
cl_object l;
|
||||
|
||||
#ifdef ECL_SAFE
|
||||
assert_type_proper_list(place);
|
||||
#endif
|
||||
for (l = place; CONSP(l); ) {
|
||||
cl_object cdr_l = CDR(l);
|
||||
if (!CONSP(cdr_l))
|
||||
FEtype_error_plist(place);
|
||||
break;
|
||||
if (CAR(l) == indicator)
|
||||
return CAR(cdr_l);
|
||||
l = CDR(cdr_l);
|
||||
slow = CDR(slow);
|
||||
if (l == slow)
|
||||
FEcircular_list(place);
|
||||
}
|
||||
if (l != Cnil)
|
||||
FEtype_error_plist(place);
|
||||
|
|
@ -122,50 +132,41 @@ getf(cl_object place, cl_object indicator, cl_object deflt)
|
|||
}
|
||||
|
||||
cl_object
|
||||
get(cl_object s, cl_object p, cl_object d)
|
||||
ecl_get(cl_object s, cl_object p, cl_object d)
|
||||
{
|
||||
if (!SYMBOLP(s))
|
||||
FEtype_error_symbol(s);
|
||||
return(getf(s->symbol.plist, p, d));
|
||||
return ecl_getf(s->symbol.plist, p, d);
|
||||
}
|
||||
|
||||
/*
|
||||
Putf(p, v, i) puts value v for property i to property list p
|
||||
and returns the resulting property list.
|
||||
(SI:PUT-F plist value indicator)
|
||||
returns the new property list with value for property indicator.
|
||||
It will be used in SETF for GETF.
|
||||
*/
|
||||
cl_object
|
||||
putf(cl_object place, cl_object value, cl_object indicator)
|
||||
si_put_f(cl_object place, cl_object value, cl_object indicator)
|
||||
{
|
||||
cl_object slow, l;
|
||||
cl_object l;
|
||||
|
||||
#ifdef ECL_SAFE
|
||||
assert_type_proper_list(place);
|
||||
#endif
|
||||
/* This loop guarantees finishing for circular lists */
|
||||
slow = l = place;
|
||||
while (CONSP(l)) {
|
||||
for (l = place; CONSP(l); ) {
|
||||
cl_object cdr_l = CDR(l);
|
||||
if (!CONSP(cdr_l))
|
||||
FEtype_error_plist(place);
|
||||
break;
|
||||
if (CAR(l) == indicator) {
|
||||
CAR(cdr_l) = value;
|
||||
return place;
|
||||
@(return place);
|
||||
}
|
||||
l = CDR(cdr_l);
|
||||
slow = CDR(slow);
|
||||
if (l == slow)
|
||||
FEcircular_list(place);
|
||||
}
|
||||
if (l != Cnil)
|
||||
FEtype_error_plist(place);
|
||||
place = CONS(value, place);
|
||||
return CONS(indicator, place);
|
||||
}
|
||||
|
||||
cl_object
|
||||
putprop(cl_object s, cl_object v, cl_object p)
|
||||
{
|
||||
if (!SYMBOLP(s))
|
||||
FEtype_error_symbol(s);
|
||||
s->symbol.plist = putf(s->symbol.plist, v, p);
|
||||
return(v);
|
||||
@(return CONS(indicator, place));
|
||||
}
|
||||
|
||||
/*
|
||||
|
|
@ -180,22 +181,20 @@ putprop(cl_object s, cl_object v, cl_object p)
|
|||
static bool
|
||||
remf(cl_object *place, cl_object indicator)
|
||||
{
|
||||
cl_object *slow, *l;
|
||||
cl_object *l;
|
||||
|
||||
/* This loop guarantees finishing for circular lists */
|
||||
slow = l = place;
|
||||
while (CONSP(*l)) {
|
||||
#ifdef ECL_SAFE
|
||||
assert_type_proper_list(*place);
|
||||
#endif
|
||||
for (l = place; CONSP(*l); ) {
|
||||
cl_object cdr_l = CDR(*l);
|
||||
if (!CONSP(cdr_l))
|
||||
FEtype_error_plist(*place);
|
||||
break;
|
||||
if (CAR(*l) == indicator) {
|
||||
*l = CDR(cdr_l);
|
||||
return TRUE;
|
||||
}
|
||||
l = &CDR(cdr_l);
|
||||
slow = &CDR(*slow);
|
||||
if (l == slow)
|
||||
FEcircular_list(*place);
|
||||
}
|
||||
if (*l != Cnil)
|
||||
FEtype_error_plist(*place);
|
||||
|
|
@ -211,7 +210,7 @@ keywordp(cl_object s)
|
|||
@(defun get (sym indicator &optional deflt)
|
||||
@
|
||||
assert_type_symbol(sym);
|
||||
@(return getf(sym->symbol.plist, indicator, deflt))
|
||||
@(return ecl_getf(sym->symbol.plist, indicator, deflt))
|
||||
@)
|
||||
|
||||
cl_object
|
||||
|
|
@ -230,25 +229,24 @@ cl_symbol_plist(cl_object sym)
|
|||
|
||||
@(defun getf (place indicator &optional deflt)
|
||||
@
|
||||
@(return getf(place, indicator, deflt))
|
||||
@(return ecl_getf(place, indicator, deflt))
|
||||
@)
|
||||
|
||||
cl_object
|
||||
cl_get_properties(cl_object place, cl_object indicator_list)
|
||||
{
|
||||
cl_object slow, cdr_l, l;
|
||||
cl_object l;
|
||||
|
||||
/* This loop guarantees finishing for circular lists */
|
||||
for (slow = l = place; CONSP(l); ) {
|
||||
cdr_l = CDR(l);
|
||||
#ifdef ECL_SAFE
|
||||
assert_type_proper_list(place);
|
||||
#endif
|
||||
for (l = place; CONSP(l); ) {
|
||||
cl_object cdr_l = CDR(l);
|
||||
if (!CONSP(cdr_l))
|
||||
FEtype_error_plist(place);
|
||||
break;
|
||||
if (member_eq(CAR(l), indicator_list))
|
||||
@(return CAR(l) CADR(l) l)
|
||||
l = CDR(cdr_l);
|
||||
slow = CDR(slow);
|
||||
if (l == slow)
|
||||
FEcircular_list(place);
|
||||
}
|
||||
if (l != Cnil)
|
||||
FEtype_error_plist(place);
|
||||
|
|
@ -339,17 +337,6 @@ cl_keywordp(cl_object sym)
|
|||
@(return ((SYMBOLP(sym) && keywordp(sym))? Ct: Cnil))
|
||||
}
|
||||
|
||||
/*
|
||||
(SI:PUT-F plist value indicator)
|
||||
returns the new property list with value for property indicator.
|
||||
It will be used in SETF for GETF.
|
||||
*/
|
||||
cl_object
|
||||
si_put_f(cl_object plist, cl_object value, cl_object indicator)
|
||||
{
|
||||
@(return putf(plist, value, indicator))
|
||||
}
|
||||
|
||||
/*
|
||||
(SI:REM-F plist indicator) returns two values:
|
||||
|
||||
|
|
@ -380,18 +367,17 @@ cl_object
|
|||
si_putprop(cl_object sym, cl_object value, cl_object indicator)
|
||||
{
|
||||
assert_type_symbol(sym);
|
||||
sym->symbol.plist = putf(sym->symbol.plist, value, indicator);
|
||||
sym->symbol.plist = si_put_f(sym->symbol.plist, value, indicator);
|
||||
@(return value)
|
||||
}
|
||||
|
||||
/* Added for defstruct. Beppe */
|
||||
@(defun si::put_properties (sym &rest ind_values)
|
||||
cl_object prop;
|
||||
@
|
||||
while (--narg >= 2) {
|
||||
prop = cl_va_arg(ind_values);
|
||||
putprop(sym, cl_va_arg(ind_values), prop);
|
||||
narg--;
|
||||
cl_object prop = cl_va_arg(ind_values);
|
||||
si_putprop(sym, cl_va_arg(ind_values), prop);
|
||||
narg--;
|
||||
}
|
||||
@(return sym)
|
||||
@)
|
||||
|
|
|
|||
|
|
@ -630,6 +630,7 @@ cl_symbols[] = {
|
|||
{"PRINC-TO-STRING", CL_ORDINARY, NULL, -1},
|
||||
{"PRINT", CL_ORDINARY, cl_print, -1},
|
||||
{"PRINT-NOT-READABLE", CL_ORDINARY, NULL, -1},
|
||||
{"PRINT-NOT-READABLE-OBJECT", CL_ORDINARY, NULL, -1},
|
||||
{"PROBE-FILE", CL_ORDINARY, cl_probe_file, 1},
|
||||
{"PROCLAIM", CL_ORDINARY, NULL, -1},
|
||||
{"PROG", FORM_ORDINARY, NULL, -1},
|
||||
|
|
|
|||
|
|
@ -77,16 +77,6 @@ FEtype_error_alist(cl_object x)
|
|||
@':datum', x);
|
||||
}
|
||||
|
||||
void
|
||||
FEtype_error_plist(cl_object x)
|
||||
{
|
||||
cl_error(9, @'simple-type-error', @':format-control',
|
||||
make_simple_string("Not a valid property list ~D"),
|
||||
@':format-arguments', cl_list(1, x),
|
||||
@':expected-type', @'list',
|
||||
@':datum', x);
|
||||
}
|
||||
|
||||
void
|
||||
FEcircular_list(cl_object x)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -352,72 +352,6 @@ strings."
|
|||
|#
|
||||
|
||||
|
||||
(defun assert-report (names stream)
|
||||
(format stream "Retry assertion")
|
||||
(if names
|
||||
(format stream " with new value~P for ~{~S~^, ~}."
|
||||
(length names) names)
|
||||
(format stream ".")))
|
||||
|
||||
(defun assert-prompt (name value)
|
||||
(cond ((y-or-n-p "The old value of ~S is ~S.~
|
||||
~%Do you want to supply a new value? "
|
||||
name value)
|
||||
(format *query-io* "~&type a form to be evaluated:~%")
|
||||
(flet ((read-it () (eval (read *query-io*))))
|
||||
(if (symbolp name) ;Help user debug lexical variables
|
||||
(progv (list name) (list value) (read-it))
|
||||
(read-it))))
|
||||
(t value)))
|
||||
|
||||
(defun simple-assertion-failure (assertion)
|
||||
(error 'SIMPLE-TYPE-ERROR
|
||||
:DATUM assertion
|
||||
:EXPECTED-TYPE nil ; This needs some work in next revision. -kmp
|
||||
:FORMAT-CONTROL "The assertion ~S failed."
|
||||
:FORMAT-ARGUMENTS (list assertion)))
|
||||
|
||||
(defmacro assert (test-form &optional places datum &rest arguments)
|
||||
(let ((tag (gensym)))
|
||||
`(tagbody ,tag
|
||||
(unless ,test-form
|
||||
(restart-case ,(if datum
|
||||
`(error ,datum ,@arguments)
|
||||
`(simple-assertion-failure ',test-form))
|
||||
(continue ()
|
||||
:REPORT (lambda (stream) (assert-report ',places stream))
|
||||
,@(mapcar #'(lambda (place)
|
||||
`(setf ,place (assert-prompt ',place ,place)))
|
||||
places)
|
||||
(go ,tag)))))))
|
||||
|
||||
|
||||
|
||||
(defun read-evaluated-form ()
|
||||
(format *query-io* "~&Type a form to be evaluated:~%")
|
||||
(list (eval (read *query-io*))))
|
||||
|
||||
(defmacro check-type (place type &optional type-string)
|
||||
(let* ((tag1 (gensym))
|
||||
(tag2 (gensym)))
|
||||
`(block ,tag1
|
||||
(tagbody ,tag2
|
||||
(if (typep ,place ',type) (return-from ,tag1 nil))
|
||||
(restart-case ,(if type-string
|
||||
`(error "The value of ~S is ~S, ~
|
||||
which is not ~A."
|
||||
',place ,place ,type-string)
|
||||
`(error "The value of ~S is ~S, ~
|
||||
which is not of type ~S."
|
||||
',place ,place ',type))
|
||||
(store-value (value)
|
||||
:REPORT (lambda (stream)
|
||||
(format stream "Supply a new value of ~S."
|
||||
',place))
|
||||
:INTERACTIVE read-evaluated-form
|
||||
(setf ,place value)
|
||||
(go ,tag2)))))))
|
||||
|
||||
(defvar *handler-clusters* nil)
|
||||
|
||||
(defmacro handler-bind (bindings &body forms)
|
||||
|
|
@ -604,9 +538,9 @@ returns with NIL."
|
|||
|
||||
(define-condition print-not-readable (error)
|
||||
((object :INITARG :OBJECT :READER print-not-readable-object))
|
||||
(:REPORT (lambda (c s)
|
||||
(format s "Cannot print object ~A readably."
|
||||
(print-not-readable-object c)))))
|
||||
(:REPORT (lambda (condition stream)
|
||||
(format stream "Cannot print object ~A readably."
|
||||
(print-not-readable-object condition)))))
|
||||
|
||||
#+nil
|
||||
(defun simple-condition-class-p (type)
|
||||
|
|
|
|||
|
|
@ -747,7 +747,7 @@
|
|||
(loc1 `(LCL ,lcl1)))
|
||||
(wt-nl "{cl_object " loc1 ";")
|
||||
(dolist (kwd keywords)
|
||||
(wt-nl loc1 "=getf(") (wt-lcl lcl)
|
||||
(wt-nl loc1 "=ecl_getf(") (wt-lcl lcl)
|
||||
(wt "," (add-symbol (car kwd)) ",OBJNULL);")
|
||||
(wt-nl "if(" loc1 "==OBJNULL){")
|
||||
(let ((*env* *env*)
|
||||
|
|
|
|||
|
|
@ -583,7 +583,7 @@
|
|||
(declare (ignore macro-lambda sp))
|
||||
(when (< *space* 3)
|
||||
(when ppn
|
||||
(wt-nl "(void)putprop(" vv "," ppn "," (add-symbol 'si::pretty-print-format) ");")
|
||||
(wt-nl "si_putprop(" vv "," ppn "," (add-symbol 'si::pretty-print-format) ");")
|
||||
(wt-nl)))
|
||||
(wt-h "static cl_object L" cfun "();")
|
||||
(wt-nl "cl_def_c_macro_va(" vv ",(cl_objectfn)L" cfun ");"))
|
||||
|
|
|
|||
|
|
@ -953,10 +953,8 @@ type_of(#0)==t_bitvector"))
|
|||
|
||||
; file symbol.d
|
||||
(GET (symbol t *) T nil nil
|
||||
:inline-always ((t t t) t nil nil "get(#0,#1,#2)")
|
||||
:inline-always ((t t) t nil nil "get(#0,#1,Cnil)")
|
||||
:inline-unsafe ((t t t) t nil nil "getf((#0)->symbol.plist,#1,#2)")
|
||||
:inline-unsafe ((t t) t nil nil "getf((#0)->symbol.plist,#1,Cnil)"))
|
||||
:inline-always ((t t t) t nil nil "ecl_get(#0,#1,#2)")
|
||||
:inline-always ((t t) t nil nil "ecl_get(#0,#1,Cnil)"))
|
||||
(REMPROP (symbol t) T nil nil)
|
||||
(SYMBOL-PLIST (symbol) T nil T
|
||||
:inline-always ((t) t nil nil "((#0)->symbol.plist)"))
|
||||
|
|
@ -978,8 +976,7 @@ type_of(#0)==t_bitvector"))
|
|||
(SI::PUT-F NIL (T T))
|
||||
(SI::REM-F NIL (T T))
|
||||
(si::SET-SYMBOL-PLIST (symbol t) T)
|
||||
(SI::PUTPROP (T T T) T NIL NIL
|
||||
:inline-always ((t t t) t t nil "putprop(#0,#1,#2)"))
|
||||
(SI::PUTPROP (T T T) T NIL NIL)
|
||||
|
||||
; file tcp.c
|
||||
(si::OPEN-TCP-STREAM (T T) T)
|
||||
|
|
|
|||
|
|
@ -1188,12 +1188,9 @@ extern void cl_defparameter(cl_object s, cl_object v);
|
|||
extern cl_object make_symbol(cl_object st);
|
||||
extern cl_object make_keyword(const char *s);
|
||||
extern cl_object symbol_value(cl_object s);
|
||||
extern cl_object getf(cl_object place, cl_object indicator, cl_object deflt);
|
||||
extern cl_object get(cl_object s, cl_object p, cl_object d);
|
||||
extern cl_object putf(cl_object p, cl_object v, cl_object i);
|
||||
extern cl_object putprop(cl_object s, cl_object v, cl_object p);
|
||||
extern cl_object ecl_getf(cl_object place, cl_object indicator, cl_object deflt);
|
||||
extern cl_object ecl_get(cl_object s, cl_object p, cl_object d);
|
||||
extern bool keywordp(cl_object s);
|
||||
extern cl_object symbol_name(cl_object x);
|
||||
extern void init_symbol(void);
|
||||
|
||||
|
||||
|
|
@ -1301,7 +1298,6 @@ extern void FEtype_error_float(cl_object x) __attribute__((noreturn,regparm(2)))
|
|||
extern void FEtype_error_integer(cl_object x) __attribute__((noreturn,regparm(1)));
|
||||
extern void FEtype_error_list(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEtype_error_proper_list(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEtype_error_plist(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEtype_error_alist(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEtype_error_stream(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
extern void FEcircular_list(cl_object x) __attribute__((noreturn,regparm(2)));
|
||||
|
|
|
|||
|
|
@ -10,54 +10,80 @@
|
|||
|
||||
(in-package "SYSTEM")
|
||||
|
||||
(defmacro check-type (place typespec &optional (string nil s))
|
||||
(defun read-evaluated-form ()
|
||||
(format *query-io* "~&Type a form to be evaluated:~%")
|
||||
(list (eval (read *query-io*))))
|
||||
|
||||
(defmacro check-type (place type &optional type-string)
|
||||
"Args: (check-type place typespec [string-form])
|
||||
Signals a continuable error, if the value of PLACE is not of the specified
|
||||
type. Before continuing, receives a new value of PLACE from the user and
|
||||
checks the type again. Repeats this process until the value of PLACE becomes
|
||||
of the specified type. STRING-FORM, if given, is evaluated only once and the
|
||||
value is used to indicate the expected type in the error message."
|
||||
`(do ((*print-level* 4)
|
||||
(*print-length* 4))
|
||||
((typep ,place ',typespec) nil)
|
||||
(cerror ""
|
||||
"The value of ~:@(~S~), ~:@(~S~), is not ~A."
|
||||
',place ,place
|
||||
,(if s string `',typespec))
|
||||
(setf ,place (si::ask-for-form2 ',place))))
|
||||
(let* ((tag1 (gensym))
|
||||
(tag2 (gensym)))
|
||||
`(block ,tag1
|
||||
(tagbody ,tag2
|
||||
(if (typep ,place ',type) (return-from ,tag1 nil))
|
||||
(restart-case ,(if type-string
|
||||
`(error "The value of ~S is ~S, ~
|
||||
which is not ~A."
|
||||
',place ,place ,type-string)
|
||||
`(error "The value of ~S is ~S, ~
|
||||
which is not of type ~S."
|
||||
',place ,place ',type))
|
||||
(store-value (value)
|
||||
:REPORT (lambda (stream)
|
||||
(format stream "Supply a new value of ~S."
|
||||
',place))
|
||||
:INTERACTIVE read-evaluated-form
|
||||
(setf ,place value)
|
||||
(go ,tag2)))))))
|
||||
|
||||
(defun assert-report (names stream)
|
||||
(format stream "Retry assertion")
|
||||
(if names
|
||||
(format stream " with new value~P for ~{~S~^, ~}."
|
||||
(length names) names)
|
||||
(format stream ".")))
|
||||
|
||||
(defmacro assert (test-form &optional places string &rest args)
|
||||
(defun assert-prompt (name value)
|
||||
(cond ((y-or-n-p "The old value of ~S is ~S.~
|
||||
~%Do you want to supply a new value? "
|
||||
name value)
|
||||
(format *query-io* "~&type a form to be evaluated:~%")
|
||||
(flet ((read-it () (eval (read *query-io*))))
|
||||
(if (symbolp name) ;Help user debug lexical variables
|
||||
(progv (list name) (list value) (read-it))
|
||||
(read-it))))
|
||||
(t value)))
|
||||
|
||||
(defun simple-assertion-failure (assertion)
|
||||
(error 'SIMPLE-TYPE-ERROR
|
||||
:DATUM assertion
|
||||
:EXPECTED-TYPE nil ; This needs some work in next revision. -kmp
|
||||
:FORMAT-CONTROL "The assertion ~S failed."
|
||||
:FORMAT-ARGUMENTS (list assertion)))
|
||||
|
||||
(defmacro assert (test-form &optional places datum &rest arguments)
|
||||
"Args: (assert form [({place}*) [string {arg}*]])
|
||||
Evaluates FORM and signals a continuable error if the value is NIL. Before
|
||||
continuing, receives new values of PLACEs from user. Repeats this process
|
||||
until FORM returns a non-NIL value. Returns NIL. STRING is the format string
|
||||
for the error message and ARGs are arguments to the format string."
|
||||
`(do ((*print-level* 4)
|
||||
(*print-length* 4))
|
||||
(,test-form nil)
|
||||
,(if string
|
||||
`(cerror "" ,string ,@args)
|
||||
`(cerror "" "The assertion ~:@(~S~) is failed." ',test-form))
|
||||
,@(mapcar #'ask-for-form places)
|
||||
(format *error-output* "Now continuing ...~%")))
|
||||
|
||||
|
||||
(defun ask-for-form (place)
|
||||
(declare (si::c-local))
|
||||
`(progn (format *error-output*
|
||||
"Please input the new value for the place ~:@(~S~): "
|
||||
',place)
|
||||
(finish-output *error-output*)
|
||||
(setf ,place (read))))
|
||||
|
||||
(defun ask-for-form2 (place)
|
||||
(format *error-output*
|
||||
"Please input the new value for the place ~:@(~S~): "
|
||||
place)
|
||||
(finish-output *error-output*)
|
||||
(prog1 (read)
|
||||
(format *error-output* "Now continuing ...~%")))
|
||||
(let ((tag (gensym)))
|
||||
`(tagbody ,tag
|
||||
(unless ,test-form
|
||||
(restart-case ,(if datum
|
||||
`(error ,datum ,@arguments)
|
||||
`(simple-assertion-failure ',test-form))
|
||||
(continue ()
|
||||
:REPORT (lambda (stream) (assert-report ',places stream))
|
||||
,@(mapcar #'(lambda (place)
|
||||
`(setf ,place (assert-prompt ',place ,place)))
|
||||
places)
|
||||
(go ,tag)))))))
|
||||
|
||||
(defun accumulate-cases (macro-name cases list-is-atom-p)
|
||||
(do ((c cases (cdr c))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue