Commit 9771e915 authored by jjgarcia's avatar jjgarcia

+ New implementation of DESTRUCTURING-BIND

+ The bytecodes compiler now alloes a lambda list with &key and no keywords
+ WITH-HASHTABLE-ITERATOR implemented
+ QUIT is now silent
+ In MAKE-PATHNAME, values supplied with a value of NIL would be overwritten
  by the content of :DEFAULTS.
parent c935faf4
......@@ -1162,6 +1162,32 @@ ECL 0.8
operator. Complain when user tries to redefine a special operator
as a function.
ECLS 0.9
========
* Errors fixed:
- The PCL relied on the compiler to optimize certain method
combinations. However, the compiler is not always present, and
therefore it is safer to use interpreted functions instead.
* Visible changes:
- No "Bye" message in QUIT.
* ANSI compatibility:
- WITH-HASH-TABLE-ITERATOR implemented.
- In DEFGENERIC, only SPACE and SPEED declarations were allowed.
- The bytecodes compiler did not contemplate the possibility of
a lambda list with &key and no keyword variables.
- In MAKE-PATHNAME, values which are supplied (even if NIL), are not
overwritten by the :DEFAULTS. For instance, (MAKE-PATHNAME :TYPE
NIL :DEFAULTS "FOO.LISP") => #P"FOO"
TODO:
=====
......
......@@ -9,28 +9,26 @@
;;; * Load Common-Lisp base library
;;;
(if (member "ECL-MIN" *features* :test #'string-equal)
(load "lsp/load.lsp"))
(load "@abs_builddir@/lsp/load.lsp"))
(defun si::process-command-args () )
;;;
;;; * Load PCL-based Common-Lisp Object System
;;;
(setf sys::*gc-verbose* nil)
#+(and wants-clos ecl-min)
(load "clos/load.lsp")
(load "@abs_builddir@/clos/load.lsp")
;;;
;;; * Load the compiler.
;;;
(load #+ecl-min "cmp/load.lsp" #-ecl-min "./cmp.so")
(load "@srcdir@/doc/help.lsp")
(si::dump-documentation "help.doc")
(load #+ecl-min "@abs_builddir@/cmp/load.lsp" #-ecl-min "@abs_builddir@/cmp.so")
;;;
;;; * By redefining "SYS:" ECL will be able to
;;; find headers and libraries in the build directory.
;;;
(si::pathname-translations "SYS" '(("*.*" "./*.*")))
(si::pathname-translations "SYS" '(("*.*" "@abs_builddir@/*.*")))
;;;
;;; * Add include path to not yet installed headers
......
......@@ -19,6 +19,7 @@ static cl_object si_simple_toplevel ()
{
cl_object sentence;
cl_object lex_old = lex_env;
int i;
/* Simple minded top level loop */
printf(";*** Lisp core booted ****\nECLS (Embeddable Common Lisp) %d pages\n", MAXPAGE);
......@@ -27,6 +28,10 @@ static cl_object si_simple_toplevel ()
StdinResume();
#endif
lex_new();
for (i = 1; i<fix(si_argc()); i++) {
cl_object arg = si_argv(MAKE_FIXNUM(i));
cl_load(1, arg);
}
while (1) {
cl_object bytecodes = Cnil;
printf("\n> ");
......
......@@ -2016,6 +2016,33 @@ si_process_lambda(cl_object lambda)
return VALUES(0);
}
/*
* (si::process-lambda-list lambda-list context)
*
* Parses different types of lambda lists. CONTEXT may be MACRO, FUNCTION or
* DESTRUCTURING-BIND, and determines the valid sytax. The output is made of
* several values:
*
* VALUES(0) = (N req1 ... ) ; required values
* VALUES(1) = (N opt1 init1 flag1 ... ) ; optional values
* VALUES(2) = rest-var ; rest-variable, if any
* VALUES(3) = key-flag ; T if &key was supplied
* VALUES(4) = (N key1 var1 init1 flag1 ... ) ; keyword arguments
* VALUES(5) = allow-other-keys ; flag &allow-other-keys
* VALUES(6) = (N aux1 init1 ... ) ; auxiliary variables
*
* 1) The prefix "N" is an integer value denoting the number of
* variables which are declared within this section of the lambda
* list.
*
* 2) The INIT* arguments are lisp forms which are evaluated when
* no value is provided.
*
* 3) The FLAG* arguments is the name of a variable which holds a
* boolean value in case an optional or keyword argument was
* provided. If it is NIL, no such variable exists.
*/
cl_object
si_process_lambda_list(cl_object org_lambda_list, cl_object context)
{
......@@ -2030,6 +2057,7 @@ si_process_lambda_list(cl_object org_lambda_list, cl_object context)
cl_object reqs = Cnil, opts = Cnil, keys = Cnil, rest = Cnil, auxs = Cnil;
int nreq = 0, nopt = 0, nkey = 0, naux = 0, stage = 0;
cl_object allow_other_keys = Cnil;
cl_object key_flag = Cnil;
if (!CONSP(lambda_list) && lambda_list != Cnil)
goto ILLEGAL_LAMBDA;
......@@ -2061,12 +2089,13 @@ LOOP:
REST: if (stage >= AT_REST)
goto ILLEGAL_LAMBDA;
stage = AT_REST;
push_var(v, rest);
rest = v;
goto LOOP;
}
if (v == @'&key') {
if (stage >= AT_KEYS)
goto ILLEGAL_LAMBDA;
key_flag = Ct;
stage = AT_KEYS;
goto LOOP;
}
......@@ -2174,9 +2203,10 @@ OUTPUT:
org_lambda_list);
@(return CONS(MAKE_FIXNUM(nreq), cl_nreverse(reqs))
CONS(MAKE_FIXNUM(nopt), cl_nreverse(opts))
cl_nreverse(rest)
allow_other_keys
rest
key_flag
CONS(MAKE_FIXNUM(nkey), cl_nreverse(keys))
allow_other_keys
cl_nreverse(auxs))
ILLEGAL_LAMBDA:
......@@ -2216,7 +2246,7 @@ c_register_var2(register cl_object var, register cl_object *specials)
cl_object
make_lambda(cl_object name, cl_object lambda) {
cl_object reqs, opts, rest, keys, auxs, allow_other_keys;
cl_object reqs, opts, rest, key, keys, auxs, allow_other_keys;
cl_object specials, doc, decl, body, l;
cl_index specials_pc, opts_pc, keys_pc, label;
int nopts, nkeys;
......@@ -2228,13 +2258,14 @@ make_lambda(cl_object name, cl_object lambda) {
reqs = si_process_lambda(lambda);
opts = VALUES(1);
rest = VALUES(2);
allow_other_keys = VALUES(3);
key = VALUES(3);
keys = VALUES(4);
auxs = VALUES(5);
doc = VALUES(6);
specials = VALUES(7);
decl = VALUES(8);
body = VALUES(9);
allow_other_keys = VALUES(5);
auxs = VALUES(6);
doc = VALUES(7);
specials = VALUES(8);
decl = VALUES(9);
body = VALUES(10);
handle = asm_begin();
......@@ -2257,13 +2288,17 @@ make_lambda(cl_object name, cl_object lambda) {
nopts = fix(CAR(opts));
asm_list(opts);
asm_list(rest); /* Name of &rest argument */
asm1(allow_other_keys); /* Value of &allow-other-keys */
asm1(rest); /* Name of &rest argument */
keys_pc = current_pc()+1; /* Keyword arguments */
nkeys = fix(CAR(keys));
asm_list(keys);
if (Null(key)) {
asm1(MAKE_FIXNUM(0)); /* &key was not supplied */
nkeys = 0;
} else {
asm1(allow_other_keys); /* Value of &allow-other-keys */
keys_pc = current_pc()+1; /* Keyword arguments */
nkeys = fix(CAR(keys));
asm_list(keys);
}
asm1(doc);
asm1(decl);
......@@ -2275,7 +2310,7 @@ make_lambda(cl_object name, cl_object lambda) {
c_register_var2(asm_ref(opts_pc+2), &specials);
opts_pc+=3;
}
c_register_var2(cl_car(rest), &specials);
c_register_var2(rest, &specials);
while (nkeys--) {
c_default(keys_pc+2);
c_register_var2(asm_ref(keys_pc+1), &specials);
......
......@@ -86,12 +86,16 @@ disassemble_lambda(cl_object *vector) {
vector++;
/* Print keyword arguments */
if (vector[0] == MAKE_FIXNUM(0)) {
vector++;
goto NO_KEYS;
}
if (vector[0] != Cnil) {
print_arg("\nOther keys:\t", vector[0]);
}
vector++;
vector = disassemble_vars("Keywords:\t", vector, 4);
NO_KEYS:
/* Print aux arguments */
print_arg("\nDocumentation:\t", next_code(vector));
print_arg("\nDeclarations:\t", next_code(vector));
......
......@@ -535,6 +535,34 @@ cl_hash_table_count(cl_object ht)
@(return (MAKE_FIXNUM(ht->hash.entries)))
}
static cl_object
si_hash_table_iterate(int narg, cl_object env)
{
cl_object index = CAR(env);
cl_object ht = CADR(env);
cl_fixnum i;
if (!Null(index)) {
i = fix(index);
if (i < 0)
i = -1;
for (; ++i < ht->hash.size; )
if (ht->hash.data[i].key != OBJNULL) {
@(return (CAR(env) = MAKE_FIXNUM(i))
ht->hash.data[i].key
ht->hash.data[i].value)
}
CAR(env) = Cnil;
}
@(return Cnil)
}
cl_object
si_hash_table_iterator(cl_object ht)
{
@(return cl_make_cclosure_va((cl_objectfn)si_hash_table_iterate,
cl_list(2, MAKE_FIXNUM(-1), ht),
@'si::hash-table-iterator'))
}
cl_object
cl_hash_table_rehash_size(cl_object ht)
{
......
......@@ -284,7 +284,11 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
}
data++;
/* 4) ALLOW-OTHER-KEYS: { T | NIL } */
/* 4) ALLOW-OTHER-KEYS: { T | NIL | 0} */
if (data[0] == MAKE_FIXNUM(0)) {
data++; other_keys = 0;
goto NO_KEYS;
}
other_keys = !Null(next_code(data));
/* 5) KEYWORDS: N key1 var1 value1 flag1 ... keyN varN valueN flagN */
......@@ -335,10 +339,11 @@ lambda_bind(int narg, cl_object lambda_list, cl_index sp)
lambda_bind_var(data[3],(spp[i] != OBJNULL)? Ct : Cnil,specials);
}
}
NO_KEYS:
if (narg && !other_keys && check_remaining)
FEprogram_error("LAMBDA: Too many arguments to function ~S.", 1,
lambda_list->bytecodes.data[0]);
/* Skip documentation and declarations */
return &data[2];
}
......
/*
</*
main.c --
*/
/*
......@@ -168,7 +168,6 @@ cl_boot(int argc, char **argv)
/* never reached */
}
#endif
printf("Bye.\n");
exit(i);
@)
......
......@@ -746,8 +746,9 @@ L:
@(return merge_pathnames(path, defaults, default_version))
@)
@(defun make_pathname (&key host device directory name
type version defaults
@(defun make_pathname (&key (host OBJNULL) (device OBJNULL) (directory OBJNULL)
(name OBJNULL) (type OBJNULL) (version OBJNULL)
defaults
&aux x)
@
if (Null(defaults)) {
......@@ -759,8 +760,12 @@ L:
Cnil, Cnil, Cnil, Cnil, Cnil);
} else
defaults = cl_pathname(defaults);
x = make_pathname(host, device, directory, name, type, version);
x = merge_pathnames(x, defaults, Cnil);
x = make_pathname(host != OBJNULL? host : defaults->pathname.host,
device != OBJNULL? device : defaults->pathname.device,
directory != OBJNULL? directory : defaults->pathname.directory,
name != OBJNULL? name : defaults->pathname.name,
type != OBJNULL? type : defaults->pathname.type,
version != OBJNULL? version : defaults->pathname.version);
@(return x)
@)
......
......@@ -599,8 +599,8 @@ semicolon_reader(cl_object in, cl_object c)
int auxc;
do
auxc = ecl_getc_noeof(in);
while (auxc != '\n');
auxc = ecl_getc(in);
while (auxc != '\n' && auxc != EOF);
/* no result */
@(return)
}
......
......@@ -840,6 +840,7 @@ cl_symbols[] = {
{"WARNING", CL_ORDINARY, NULL, -1},
{"WHEN", FORM_ORDINARY, NULL, -1},
{"WITH-COMPILATION-UNIT", CL_ORDINARY, NULL, -1},
{"WITH-HASH-TABLE-ITERATOR", CL_ORDINARY, NULL, -1},
{"WITH-INPUT-FROM-STRING", CL_ORDINARY, NULL, -1},
{"WITH-OPEN-FILE", CL_ORDINARY, NULL, -1},
{"WITH-OPEN-STREAM", CL_ORDINARY, NULL, -1},
......@@ -979,6 +980,7 @@ cl_symbols[] = {
{"SI::GET-STRING-INPUT-STREAM-INDEX", SI_ORDINARY, si_get_string_input_stream_index, 1},
{"SI::GETENV", SI_ORDINARY, si_getenv, 1},
{"SI::HASH-SET", SI_ORDINARY, si_hash_set, 3},
{"SI::HASH-TABLE-ITERATOR", SI_ORDINARY, si_hash_table_iterator, 1},
{"SI::IHS-ENV", SI_ORDINARY, si_ihs_env, 1},
{"SI::IHS-FUN", SI_ORDINARY, si_ihs_fun, 1},
{"SI::IHS-NEXT", SI_ORDINARY, si_ihs_next, 1},
......
......@@ -123,7 +123,7 @@
superclasses-names
direct-slots all-slots
default-initargs documentation)
(declare (ignore class-slots default-initargs documentation))
(declare (ignore default-initargs direct-slots))
(dolist (slot all-slots)
(unless (eq :INSTANCE (slotd-allocation slot))
(error "The structure class ~S can't have shared slots" name)))
......
......@@ -69,7 +69,9 @@
(setq entry
(multiple-value-bind (template predicate constructor)
(compile-effective-method-template-entry form)
(list template predicate (compile () constructor)
(list template predicate
#+ecl(coerce constructor 'function)
#-ecl(compile () constructor)
'ON-THE-FLY 0)))
(add-effective-method-template-entry entry))
(incf (fifth entry))
......
......@@ -236,18 +236,18 @@
(dolist (subclass (nreverse inferiors))
(let* ((subclass-superclasses
(mapcar #'(lambda (x) (class-name x)) (class-superiors subclass)))
(subclass-name (class-name subclass)))
(subclass-name (class-name subclass))
(slots (collect-slotds
(compute-class-precedence-list
subclass-name (mapcar #'find-class superclasses-names))
(slot-value subclass 'DIRECT-SLOTS))))
(print subclass)
(pushnew
(ensure-class (class-name (si:instance-class subclass))
subclass-name
subclass-superclasses
(slot-value subclass 'DIRECT-SLOTS)
(collect-slotds
(compute-class-precedence-list
subclass-name
(mapcar #'find-class superclasses-names))
(slot-value subclass 'DIRECT-SLOTS))
slots
(default-initargs-of subclass)
(documentation-of subclass))
(class-inferiors new-class))
......
......@@ -316,8 +316,10 @@ than once")
(do* ((d (cdr decl) (cdr d))
(first (car d) (car d)))
((null d) decl)
(unless (member (car first) '(SPEED SPACE))
(error "The only qualities allowed are speed and space"))))
(when (atom first)
(setq first (cons first 3)))
(unless (member (car first) '(SPEED SPACE COMPILATION-SPEED DEBUG SAFETY))
(error "The only qualities allowed are speed and space"))))
(defun parse-legal-documentation (doc)
(declare (si::c-local))
......
......@@ -630,8 +630,6 @@
(push `(,(caar scan)
(slot-value ,temp ',(cadar scan))) res)))))
`(let ((,temp ,instance-form))
,@(and (symbolp instance-form)
`((declare (variable-rebinding ,temp ,instance-form))))
(symbol-macrolet ,accessors ,@body))))
;(with-slots (x (y2 y)) inst (setq x y2))
......@@ -646,8 +644,6 @@
((null scan) (nreverse res))
(push `(,(caar scan) (,(cadar scan) ,temp)) res))))
`(let ((,temp ,instance-form))
,@(and (symbolp instance-form)
`((declare (variable-rebinding ,temp ,instance-form))))
(symbol-macrolet ,accessors ,@body))))
......
......@@ -61,20 +61,20 @@
(defpackage "WALKER"
(:export define-walker-template
walk-form
#+NEW
walk-form-expand-macros-p
#-ecl nested-walk-form
variable-lexical-p
variable-special-p
*variable-declarations*
variable-declaration
#+NEW
macroexpand-all
))
(in-package "WALKER")
(declaim (notinline note-lexical-binding walk-bindings-1 walk-let/let*
walk-form-internal))
(push :new *features*)
;;;
;;; On the following pages are implementations of the implementation specific
......@@ -251,18 +251,14 @@
(push declaration (third (env-lock env))))
(defun note-lexical-binding (thing env)
(push #+NEW (list thing :LEXICAL-VAR) #-NEW thing (fourth (env-lock env))))
(push (list thing :LEXICAL-VAR) (fourth (env-lock env))))
(defun VARIABLE-LEXICAL-P (var env)
(declare (si::c-local))
#+NEW
(let ((entry (member var (env-lexical-variables env) :key #'car)))
(when (eq (cadar entry) :LEXICAL-VAR)
entry))
#-NEW
(member var (env-lexical-variables env)))
entry)))
#+NEW
(defun variable-symbol-macro-p (var env)
(declare (si::c-local))
(let ((entry (member var (env-lexical-variables env) :key #'car)))
......@@ -272,7 +268,6 @@
(defvar *VARIABLE-DECLARATIONS* '(SPECIAL TYPE)) ; Beppe
(defun VARIABLE-DECLARATION (declaration var env)
(declare (si::c-local))
(if (not (member declaration *variable-declarations*))
(error "~S is not a recognized variable declaration." declaration)
(let ((id (or (variable-lexical-p var env) var)))
......@@ -284,7 +279,6 @@
(return decl))))))
(defun VARIABLE-SPECIAL-P (var env)
(declare (si::c-local))
(or (not (null (variable-declaration 'SPECIAL var env)))
(variable-globally-special-p var)))
......@@ -402,27 +396,18 @@
(define-walker-template LAMBDA walk-lambda)
(define-walker-template LET walk-let)
(define-walker-template LET* walk-let*)
#+NEW
(define-walker-template LOCALLY walk-locally)
(define-walker-template MACROLET walk-macrolet)
(define-walker-template MULTIPLE-VALUE-CALL (NIL EVAL REPEAT (EVAL)))
(define-walker-template MULTIPLE-VALUE-PROG1 (NIL RETURN REPEAT (EVAL)))
#+NEW
(define-walker-template MULTIPLE-VALUE-SETQ walk-multiple-value-setq)
#-NEW
(define-walker-template MULTIPLE-VALUE-SETQ (NIL (REPEAT (SET)) EVAL))
(define-walker-template MULTIPLE-VALUE-BIND walk-multiple-value-bind)
(define-walker-template PROGN (NIL REPEAT (EVAL)))
(define-walker-template PROGV (NIL EVAL EVAL REPEAT (EVAL)))
(define-walker-template QUOTE (NIL QUOTE))
(define-walker-template RETURN-FROM (NIL QUOTE REPEAT (RETURN)))
#+NEW
(define-walker-template SETQ walk-setq)
#-NEW
(define-walker-template SETQ (NIL REPEAT (SET EVAL)))
#+NEW
(define-walker-template SYMBOL-MACROLET walk-symbol-macrolet)
#-NEW
(define-walker-template TAGBODY walk-tagbody)
(define-walker-template THE (NIL QUOTE EVAL))
(define-walker-template THROW (NIL EVAL EVAL))
......@@ -453,9 +438,8 @@
;;; Controls whether macros are expanded by walk-form
#+NEW
(defvar WALK-FORM-EXPAND-MACROS-P nil)
#+NEW
(defun macroexpand-all (form &optional environment)
(let ((walk-form-expand-macros-p t))
(walk-form form environment)))
......@@ -566,7 +550,6 @@
((not (eq form newform))
(walk-form-internal newform context env))
((not (consp newform))
#+NEW
(let ((symmac (car (variable-symbol-macro-p newform env))))
(if symmac
(let ((newnewform (walk-form-internal (cddr symmac)
......@@ -574,9 +557,7 @@
(if (eq newnewform (cddr symmac))
(if walk-form-expand-macros-p newnewform newform)
newnewform))
newform))
#-NEW
newform)
newform)))
((setq template (get-walker-template (setq fn (car newform))))
(if (symbolp template)
(funcall template newform context env)
......@@ -587,14 +568,11 @@
(macroexpand-1 newform new-env))
(cond
(macrop
#+NEW
(let ((newnewnewform
(walk-form-internal newnewform context env)))
(if (eq newnewnewform newnewform)
(if walk-form-expand-macros-p newnewform newform)
newnewnewform))
#-NEW
(walk-form-internal newnewform context env))
newnewnewform)))
((and (symbolp fn)
(not (fboundp fn))
(special-operator-p fn))
......@@ -699,7 +677,6 @@
(walk-repeat-eval (cdr form) env))))
(defun recons (x car cdr)
(declare (si::c-local))
(if (or (not (eq (car x) car))
(not (eq (cdr x) cdr)))
(cons car cdr)
......@@ -850,7 +827,6 @@
(relist*
form let/let* walked-bindings walked-body))))
#+NEW
(defun walk-locally (form context env)
(declare (ignore context))
(let* ((locally (car form))
......@@ -926,7 +902,6 @@
(walk-bindings-2 bindings walked-bindings context new-env)
walked-body))))
#+NEW
(defun walk-multiple-value-setq (form context env)
(let ((vars (cadr form)))
(if (some #'(lambda (var)
......@@ -1035,7 +1010,6 @@
walked-arglist
walked-body))))
#+NEW
(defun walk-setq (form context env)
(if (cdddr form)
(let* ((expanded (let* ((rforms nil)
......@@ -1060,7 +1034,6 @@
(walk-form-internal var :set env)
(walk-form-internal val :eval env))))))
#+NEW
(defun walk-symbol-macrolet (form context old-env)
(declare (ignore context))
(let* ((bindings (second form)))
......
......@@ -50,8 +50,6 @@
kind ;;; One of LEXICAL, SPECIAL, GLOBAL, OBJECT, FIXNUM,
;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, or REPLACED (used for
;;; LET variables).
;;; A value DUMMY is used for missing supplied-p keyword
;;; variables
(loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can
;;; be allocated on the c-stack: OBJECT means
;;; the variable is declared as OBJECT, and CLB means
......@@ -346,8 +344,6 @@ The default value is NIL.")
(defvar *compile-time-too* nil)
(defvar *not-compile-time* nil)
(defvar *non-package-operation* nil)
(defvar *objects* nil) ; holds { ( object text vv-index ) }*
(defvar *keywords* nil) ; holds { ( key-list text vv-index ) }*
(defvar *load-time-values* nil) ; holds { ( vv-index form ) }*,
......
......@@ -33,7 +33,6 @@
(setq *reservations* nil)
(setq *top-level-forms* nil)
(setq *compile-time-too* nil)
(setq *non-package-operation* nil)
(setq *function-declarations* nil)
(setq *inline-functions* nil)
(setq *inline-blocks* 0)
......
This diff is collapsed.
......@@ -112,11 +112,10 @@
(cmpck (endp (cdr fun))
"The lambda expression ~s is illegal." fun)
(let* ((name (second fun))
(funob (c1lambda-expr (cddr fun)))
(funob (c1lambda-expr (cddr fun) name))
(info (second funob))
(closure (closure-p funob))
(body `(BLOCK ,name ,@(cdddr fun)))
(fun (make-fun :name name
(fun (make-fun :name (list name)
:cfun (next-cfun)
:closure closure)))
(if closure
......
......@@ -30,9 +30,6 @@
(cond
((symbolp fun)
(cond ((get fun 'PACKAGE-OPERATION)
(when *non-package-operation*
(cmpwarn "The package operation ~s was in a bad place."
form))
(cmp-eval form)
(wt-data-package-operation form))
((setq fd (get fun 'T1))
......@@ -233,7 +230,6 @@
(when (not (symbolp (car args)))
(return-from t1defun (t1expr* (macroexpand (cons 'defun args)))))
(when *compile-time-too* (cmp-eval (cons 'DEFUN args)))
(setq *non-package-operation* t)
(let* (lambda-expr
(fname (car args))
(cfun (exported-fname fname))
......@@ -573,7 +569,6 @@
(cmpck (not (symbolp (car args)))
"The macro name ~s is not a symbol." (car args))
(cmp-eval (cons 'DEFMACRO args))
(setq *non-package-operation* t)
(let (macro-lambda (cfun (next-cfun)) (doc nil) (ppn nil))
(setq macro-lambda (c1dm (car args) (second args) (cddr args)))
(when (second macro-lambda) (setq ppn (add-object (second macro-lambda))))
......@@ -615,7 +610,6 @@
(defun t1ordinary (form)
(when *compile-time-too* (cmp-eval form))
(setq *non-package-operation* t)
(setq form (c1expr form))
(add-load-time-values)
(list 'ORDINARY form))
......@@ -652,7 +646,6 @@
(defun t1defvar (args &aux form (doc nil) (name (car args)))
(when *compile-time-too* (cmp-eval `(defvar ,@args)))
(setq *non-package-operation* nil)
(push name *global-vars*)
(if (endp (cdr args))
(list 'DECLARE (add-symbol name))
......@@ -814,6 +807,8 @@
(or
;; non closure variable
(not (ref-ref-ccb x))
;; special variable
(eq (var-kind x) 'special)
;; parameter of this closure
;; (not yet bound, therefore var-loc is OBJECT)
(eq (var-loc x) 'OBJECT)))
......
......@@ -74,9 +74,10 @@
(setq form expansion)
(return-from chk-symbol-macrolet form))))
;; Search for a SYMBOL-MACROLET definition
(cond ((and (consp v) (eq (first v) form))
(setq form (second v))
(return))
(cond ((consp v)
(when (eq (first v) form)
(setq form (second v))
(return)))
((symbolp v))
((eq (var-name v) form)
;; Any macro definition has been shadowed by LET/LET*, etc.
......@@ -160,8 +161,9 @@
(declare (type var var))
(cond ((eq var 'CB) (setq ccb t)) ; closure boundary
((eq var 'LB) (setq clb t)) ; level boundary
((and (consp var) (eq (first var) name)) ; symbol macrolet
(c1expr (second var)))
((consp var)
(when (eq (first var) name) ; symbol macrolet
(return-from c1vref (c1expr (second var)))))
((eq (var-name var) name)
(when (minusp (var-ref var)) ; IGNORE.
(cmpwarn "The ignored variable ~s is used." name)
......
(load "@srcdir@/cmpdefs")
(load "@srcdir@/cmpmac")
(load "@srcdir@/cmpinline")
(load "@srcdir@/cmputil")
(load "@srcdir@/cmptype")
(load "@srcdir@/cmpbind")
(load "@srcdir@/cmpblock")
(load "@srcdir@/cmpcall")
(load "@srcdir@/cmpcatch")
(load "@srcdir@/cmpenv")
(load "@srcdir@/cmpeval")
(load "@srcdir@/cmpexit")
(load "@srcdir@/cmpflet")
(load "@srcdir@/cmpfun")
(load "@srcdir@/cmpif")
(load "@srcdir@/cmplam")
(load "@srcdir@/cmplet")
(load "@srcdir@/cmploc")
(load "@srcdir@/cmpmap")
(load "@srcdir@/cmpmulti")
(load "@srcdir@/cmpspecial")
(load "@srcdir@/cmptag")
(load "@srcdir@/cmptop")
(load "@srcdir@/cmpvar")
(load "@srcdir@/cmpwt")
(load "@srcdir@/cmpmain")
(load "@srcdir@/sysfun")