mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-01 15:20:36 -08:00
Code Issues Projects Releases Packages Wiki Activity

src/c

Browse source
This commit is contained in:
jjgarcia 2003-10-22 07:27:44 +00:00
parent f8487086bb
commit fc8deffa71
18 changed files with 112 additions and 257 deletions
Download patch file Download diff file Expand all files Collapse all files

63
src/cmp/cmpbind.lsp
View file

@ -22,27 +22,27 @@
;; a constant, or (VAR var) from a let binding. ; ccb
(declare (type var var))
(case (var-kind var)
(CLOSURE
(let ((var-loc (var-loc var)))
(unless (sys:fixnump var-loc)
;; first binding: assign location
(setq var-loc (next-env))
(setf (var-loc var) var-loc))
(when (zerop var-loc) (wt-nl "env" *env-lvl* " = Cnil;"))
(wt-nl "CLV" var-loc "=&CAR(env" *env-lvl* "=CONS(")
(wt-coerce-loc :object loc)
(wt ",env" *env-lvl* "));")
(wt-comment (var-name var))))
(LEXICAL
(let ((var-loc (var-loc var)))
(if (var-ref-ccb var)
(progn
(unless (sys:fixnump var-loc)
;; first binding: assign location
(setq var-loc (next-env))
(setf (var-loc var) var-loc))
(when (zerop var-loc) (wt-nl "env" *env-lvl* " = Cnil;"))
(wt-nl "CLV" var-loc "=&CAR(env" *env-lvl* "=CONS(")
(wt-coerce-loc :object loc)
(wt ",env" *env-lvl* "));"))
(progn
(unless (consp var-loc)
;; first binding: assign location
(setq var-loc (next-lex))
(setf (var-loc var) var-loc))
(wt-nl) (wt-lex var-loc) (wt "= ")
(wt-coerce-loc :object loc)
(wt ";")))
(wt-comment (var-name var))))
(unless (consp var-loc)
;; first binding: assign location
(setq var-loc (next-lex))
(setf (var-loc var) var-loc))
(wt-nl) (wt-lex var-loc) (wt "= ")
(wt-coerce-loc :object loc)
(wt ";"))
(wt-comment (var-name var)))
(SPECIAL
(bds-bind loc var))
(t
@ -67,15 +67,16 @@
;; otherwise the increment to *env* or *lex* is done during
;; unwind-exit and will be shadowed by functions (like c2let)
;; which rebind *env* or *lex*.
(when (eq (var-kind var) 'LEXICAL)
(if (var-ref-ccb var)
(unless (si:fixnump (var-loc var))
(setf (var-loc var) (next-env)))
(unless (consp (var-loc var))
(setf (var-loc var) (next-lex)))))
(when (eq (var-kind var) 'SPECIAL)
;; prevent BIND from pushing BDS-BIND
(setf (var-ref-ccb var) t))
(case (var-kind var)
(CLOSURE
(unless (si:fixnump (var-loc var))
(setf (var-loc var) (next-env))))
(LEXICAL
(unless (consp (var-loc var))
(setf (var-loc var) (next-lex))))
(SPECIAL
;; prevent BIND from pushing BDS-BIND
(setf (var-bds-bound var) t)))
(c2expr* form)
(when (eq (var-kind var) 'SPECIAL)
;; now the binding is in effect
@ -94,10 +95,10 @@
;; push BDS-BIND only once:
;; bds-bind may be called several times on the same variable, e.g.
;; an optional has two alternative bindings.
;; We use field var-ref-ccb to record this fact.
(unless (var-ref-ccb var)
;; We use field var-bds-bound to record this fact.
(unless (var-bds-bound var)
(push 'BDS-BIND *unwind-exit*)
(setf (var-ref-ccb var) t))
(setf (var-bds-bound var) t))
(wt-comment (var-name var)))
(put-sysprop 'BIND 'SET-LOC 'bind)

17
src/cmp/cmpblock.lsp
View file

@ -12,22 +12,6 @@
(in-package "COMPILER")
#|
;;; Use a structure of type vector to avoid creating
;;; normal structures before booting CLOS:
(defstruct (blk (:type vector) :named)
name ;;; Block name.
(ref 0 :type fixnum) ;;; Number of references.
ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
ref-clb ;;; Cross local function reference.
;;; During Pass1, T or NIL.
;;; block id, or NIL.
exit ;;; Where to return. A label.
destination ;;; Where the value of the block to go.
var ;;; variable containing the block ID.
) |#
;;; During Pass 1, *blocks* holds a list of blk objects and the
;;; symbols 'CB' (Closure Boundary), 'LB' (Level Boundary) or
;;; 'UNWIND-PROTECT'. 'CB' will be pushed on *blocks* when the
@ -109,6 +93,7 @@
(var (blk-var blk)))
(cond (ccb (setf (blk-ref-ccb blk) t
type 'CCB
(var-kind var) 'CLOSURE
(var-ref-ccb var) T)
(incf (var-ref var)))
(clb (setf (blk-ref-clb blk) t

36
src/cmp/cmpdefs.lsp
View file

@ -38,6 +38,10 @@
ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the index into the closure env
ref-clb ;;; Cross local function reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the lex-address for the
;;; block id, or NIL.
)
(deftype OBJECT () `(not (or fixnum character short-float long-float)))
@ -46,9 +50,9 @@
; name ;;; Variable name.
; (ref 0 :type fixnum)
;;; Number of references to the variable (-1 means IGNORE).
;;; During Pass 2: set below *register-min* for non register.
; ref-ccb ;;; Cross closure reference: T or NIL.
kind ;;; One of LEXICAL, SPECIAL, GLOBAL, :OBJECT, :FIXNUM,
; ref-clb ;;; Cross local function reference: T or NIL.
kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM,
;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for
;;; LET variables).
(loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can
@ -63,12 +67,12 @@
;;; For REPLACED: the actual location of the variable.
;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT:
;;; the cvar for the C variable that holds the value.
;;; For LEXICAL: the frame-relative address for the variable.
;;; For LEXICAL or CLOSURE: the frame-relative address for the variable.
;;; For SPECIAL and GLOBAL: the vv-index for variable name.
(type t) ;;; Type of the variable.
(index -1) ;;; position in *vars*. Used by similar.
(bds-bound nil) ;;; BDS-BIND was already used on this variable.
)
;(deftype var () '(satisfies var-p))
;;; A function may be compiled into a CFUN, CCLOSURE or CCLOSURE+LISP_CLOSURE
;;; Here are examples of function FOO for the 3 cases:
@ -104,8 +108,14 @@
(defstruct (fun (:include ref))
; name ;;; Function name.
; (ref 0 :type fixnum) ;;; Number of references.
;;; During Pass1, T or NIL.
;;; During Pass2, the vs-address for the
;;; function closure, or NIL.
; ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the vs-address for the function
;;; closure, or NIL.
; ref-clb ;;; Unused.
cfun ;;; The cfun for the function.
(level 0) ;;; Level of lexical nesting for a function.
(env 0) ;;; Size of env of closure.
@ -113,7 +123,6 @@
var ;;; the variable holding the funob
description ;;; Text for the object, in case NAME == NIL.
)
;(deftype fun () '(satisfies fun-p))
(defstruct (blk (:include ref))
; name ;;; Block name.
@ -122,7 +131,7 @@
;;; During Pass1, T or NIL.
;;; During Pass2, the ccb-lex for the
;;; block id, or NIL.
ref-clb ;;; Cross local function reference.
; ref-clb ;;; Cross local function reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the lex-address for the
;;; block id, or NIL.
@ -131,21 +140,19 @@
var ;;; Variable containing the block ID.
(type 'NIL) ;;; Estimated type.
)
;(deftype blk () '(satisfies blk-p))
(defstruct (tag (:include ref))
; name ;;; Tag name.
; (ref 0 :type fixnum) ;;; Number of references.
; ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
ref-clb ;;; Cross local function reference.
; ref-clb ;;; Cross local function reference.
;;; During Pass1, T or NIL.
label ;;; Where to jump: a label.
unwind-exit ;;; Where to unwind-no-exit.
var ;;; Variable containing frame ID.
index ;;; An integer denoting the label.
)
;(deftype tag () '(satisfies tag-p))
(defstruct (info)
(changed-vars nil) ;;; List of var-objects changed by the form.
@ -163,7 +170,6 @@
;;; add-info) so that we can determine exactly which frame is used
;;; in the body of a function.
)
;(deftype info () '(satisfies info-p))
;;;
;;; VARIABLES
@ -243,7 +249,7 @@ The default value is NIL.")
;;;
;;; Compiled code uses the following kinds of variables:
;;; 1. Vi, declared explicitely, either unboxed or register (*lcl*, next-lcl)
;;; 1. Vi, declared explicitely, either unboxed or not (*lcl*, next-lcl)
;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp)
;;; 4. lexi[j], for lexical variables in local functions
;;; 5. CLVi, for lexical variables in closures
@ -332,11 +338,6 @@ The default value is NIL.")
;;; --cmptop.lsp--
;;;
(defvar *funarg-vars*)
;;; Number of address registers available not counting the
;;; frame pointer and the stack pointer
;;; To do: If the regs hold data then there are really more available;
(defvar *free-address-registers* 5)
(defvar *free-data-registers* 6)
(defvar *volatile*)
(defvar *setjmps* 0)
@ -389,6 +390,3 @@ The default value is NIL.")
(defvar *vars* nil)
(defvar *undefined-vars* nil)
(defvar *special-binding* nil)
(defvar *register-min* 3) ; criteria for putting in register.
(proclaim '(fixnum *register-min*))

7
src/cmp/cmpenv.lsp
View file

@ -339,13 +339,6 @@
"The object declaration ~s contains a non-symbol ~s."
decl var)
(push (cons var 'OBJECT) ts)))
(:REGISTER
(dolist (var (cdr decl))
(cmpck (not (symbolp var))
"The register declaration ~s contains a non-symbol ~s."
decl var)
(push (cons var 'REGISTER) ts)
))
;; read-only variable treatment. Beppe
(:READ-ONLY
#| obsolete

27
src/cmp/cmpflet.lsp
View file

@ -12,26 +12,6 @@
(in-package "COMPILER")
#|
;;; Use a structure of type vector to avoid creating
;;; normal structures before booting CLOS:
(defstruct (fun (:type vector) :named)
name ;;; Function name.
ref ;;; Referenced or not.
;;; During Pass1, T or NIL.
;;; During Pass2, the vs-address for the
;;; function closure, or NIL.
ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
;;; During Pass2, the vs-address for the
;;; function closure, or NIL.
cfun ;;; The cfun for the function.
level ;;; Level of nesting for a function.
env ;;; Size of env of closure.
closure ;;; During Pass1, T if the function is returned
;;; During Pass2, T if env is used inside the function
) |#
(defun c1flet (args &aux body ss ts is other-decl
(defs nil) (local-funs nil))
(check-args-number 'FLET args 1)
@ -103,7 +83,7 @@
(dolist (def funs)
(let* ((fun (car def)) (var (fun-var fun)))
(when (plusp (var-ref var)) ; the function is returned
(unless (eq 'LEXICAL (var-kind var))
(unless (member (var-kind var) '(LEXICAL CLOSURE))
(setf (var-loc var) (next-lcl))
(unless block-p
(setq block-p t) (wt-nl "{ "))
@ -267,9 +247,10 @@
(setf (fun-var fun)
(make-var :name fname :kind :OBJECT)))))
(cond (ccb (setf (var-ref-ccb var) t
(var-kind var) 'LEXICAL)
(var-kind var) 'CLOSURE)
(setf (fun-ref-ccb fun) t))
(clb (setf (var-kind var) 'LEXICAL))))
(clb (setf (var-ref-clb var) t
(var-kind var) 'LEXICAL))))
(return fun)))))
(defun c1call-local (fname)

2
src/cmp/cmplam.lsp
View file

@ -196,7 +196,7 @@
(declare (fixnum lcl))
(labels ((wt-decl (var)
(wt-nl)
(wt *volatile* (register var) (rep-type-name (var-rep-type var)) " ")
(wt *volatile* (rep-type-name (var-rep-type var)) " ")
(wt-lcl (incf lcl)) (wt ";")
`(LCL ,lcl))
(do-decl (var)

26
src/cmp/cmplet.lsp
View file

@ -145,8 +145,7 @@
(wt-nl)
(unless block-p
(wt "{") (setq block-p t))
(wt *volatile* (register var) (rep-type-name (var-rep-type var)) " "
var ";")
(wt *volatile* (rep-type-name (var-rep-type var)) " " var ";")
(when (local var)
(wt-comment (var-name var))))
(do-init (var form fl)
@ -188,9 +187,11 @@
(and (member (var-kind var1) '(SPECIAL GLOBAL))
(member (var-name var1) prev-ss)))
(do-init var form fl))
((and (can-be-replaced var body)
(member (var-kind var1) '(LEXICAL REPLACED :OBJECT))
(not (var-ref-ccb var1))
((and ;; Fixme! We should be able to replace variable
;; even if they are referenced across functions.
;; We just need to keep track of their uses.
(member (var-kind var1) '(REPLACED :OBJECT))
(can-be-replaced var body)
(not (member var1 (c1form-changed-vars body))))
(setf (var-kind var) 'REPLACED
(var-loc var) var1))
@ -365,7 +366,7 @@
var (car vl)
kind (local var))
(unless (unboxed var)
;; LEXICAL, SPECIAL, GLOBAL or OBJECT
;; LEXICAL, CLOSURE, SPECIAL, GLOBAL or OBJECT
(case (c1form-name form)
(LOCATION
(when (can-be-replaced* var body (cdr fl))
@ -374,9 +375,11 @@
(VAR
(let* ((var1 (c1form-arg 0 form)))
(declare (type var var1))
(when (and (can-be-replaced* var body (cdr fl))
(member (var-kind var1) '(LEXICAL REPLACED :OBJECT))
(not (var-ref-ccb var1))
(when (and ;; Fixme! We should be able to replace variable
;; even if they are referenced across functions.
;; We just need to keep track of their uses.
(member (var-kind var1) '(REPLACED :OBJECT))
(can-be-replaced* var body (cdr fl))
(not (var-changed-in-forms var1 (cdr fl)))
(not (member var1 (c1form-changed-vars body))))
(setf (var-kind var) 'REPLACED
@ -386,7 +389,7 @@
(when (and kind (not (eq (var-kind var) 'REPLACED)))
(bind (next-lcl) var)
(wt-nl) (unless block-p (wt "{") (setq block-p t))
(wt *volatile* (register var) (rep-type-name kind) " " var ";")
(wt *volatile* (rep-type-name kind) " " var ";")
(wt-comment (var-name var)))
)
@ -405,7 +408,7 @@
form (car fl))
(case (var-kind var)
(REPLACED)
((LEXICAL SPECIAL GLOBAL)
((LEXICAL CLOSURE SPECIAL GLOBAL)
(case (c1form-name form)
(LOCATION (bind (c1form-arg 0 form) var))
(VAR (bind (c1form-arg 0 form) var))
@ -438,7 +441,6 @@
(defun can-be-replaced (var body)
(declare (type var var))
(and (eq (var-kind var) :OBJECT)
(< (var-ref var) *register-min*)
(not (member var (c1form-changed-vars body)))))
#| (and (or (eq (var-kind var) 'LEXICAL)
(and (eq (var-kind var) :OBJECT)

2
src/cmp/cmpmulti.lsp
View file

@ -191,7 +191,7 @@
(if kind
(progn
(bind (next-lcl) var)
(wt-nl *volatile* (register var) (rep-type-name kind) " " var ";")
(wt-nl *volatile* (rep-type-name kind) " " var ";")
(wt-comment (var-name var)))
(unless env-grows (setq env-grows (var-ref-ccb var))))))

22
src/cmp/cmptag.lsp
View file

@ -13,22 +13,6 @@
(in-package "COMPILER")
#|
;;; Use a structure of type vector to avoid creating
;;; normal structures before booting CLOS:
(defstruct (tag (:type vector) :named)
name ;;; Tag name.
(ref 0 :type fixnum) ;;; Number of references.
ref-ccb ;;; Cross closure reference.
;;; During Pass1, T or NIL.
ref-clb ;;; Cross local function reference.
;;; During Pass1, T or NIL.
label ;;; Where to jump: a label.
unwind-exit ;;; Where to unwind-no-exit.
var ;;; Variable containing frame ID.
index ;;; Number of tag in the list.
) |#
;;; During Pass 1, *tags* holds a list of tag objects and the symbols 'CB'
;;; (Closure Boundary), 'LB' (Level Boundary) or 'UNWIND-PROTECT'.
;;; 'CB' will be pushed on *tags* when the compiler begins to process
@ -40,8 +24,7 @@
;;; label in the body.
;;; When a reference to a tag (go instruction) is found, the
;;; var-kind is stepped from NIL to OBJECT (if appearing inside an
;;; unwind-protect) to LEXICAL (if appearing across a boundary: with
;;; var-ref-ccb set to T in case of closure boundary).
;;; unwind-protect) to LEXICAL or CLOSURE (if appearing across a boundary).
;;; The tag-ref is also incremented.
;;; Therefore var-ref represents whether some tag is used at all and var-kind
;;; variable represents whether a tag identifier must be created and the
@ -207,8 +190,9 @@
(setq var (tag-var tag))
(cond (ccb (setf (tag-ref-ccb tag) t
(var-ref-ccb var) T
(var-kind var) 'LEXICAL))
(var-kind var) 'CLOSURE))
(clb (setf (tag-ref-clb tag) t
(var-ref-clb var) t
(var-kind var) 'LEXICAL))
(unw (unless (var-kind var)
(setf (var-kind var) :OBJECT))))

54
src/cmp/cmptop.lsp
View file

@ -29,10 +29,7 @@
(let ((fun (car form)) (args (cdr form)) fd setf-symbol) ; #+cltl2
(cond
((symbolp fun)
(cond ((get-sysprop fun 'PACKAGE-OPERATION)
(cmp-eval form)
(wt-data-package-operation form))
((setq fd (get-sysprop fun 'T1))
(cond ((setq fd (get-sysprop fun 'T1))
(when *compile-print* (print-current-form))
(funcall fd args))
((get-sysprop fun 'C1) (t1ordinary form))
@ -314,12 +311,6 @@
"Number of proclaimed args for ~a was ~a. ~
~%;;; Its definition had ~a." fname arg-p arg-c)))))
(defun register (var)
(if (and (equal *volatile* "")
(> (var-ref var) (the fixnum *register-min*)))
"register "
""))
(defun t2defun (fname cfun lambda-expr sp funarg-vars no-entry)
(declare (ignore sp funarg-vars))
(if no-entry
@ -344,7 +335,6 @@
(when lambda-expr ; Not sharing code.
(setq lambda-list (c1form-arg 0 lambda-expr)
requireds (car lambda-list))
(analyze-regs (c1form-referred-vars lambda-expr))
(if (setq inline-info (assoc fname *inline-functions* :test #'same-fname-p))
@ -380,7 +370,7 @@
;; so that c2lambda-expr will know its proper type.
(setf (var-kind var) rep-type))
(unless (eq vl requireds) (wt ","))
(wt *volatile* (register var) (rep-type-name rep-type) " ")
(wt *volatile* (rep-type-name rep-type) " ")
(wt-lcl lcl))
(wt ")"))))
(wt-h string ";")
@ -462,39 +452,6 @@
(wt-h1 ";"))
)
;;; Checks the register slots of variables, and finds which
;;; variables should be in registers, reducing the var-ref value
;;; in the remaining. Data and address variables are done separately.
(defun analyze-regs (vars)
(flet ((analyze-regs1 (vars want &aux (tem 0) (real-min 3) (this-min 100000)
(have 0))
(declare (fixnum want tem real-min this-min have))
(do ((vs vars) (v))
((null vs))
(setq v (pop vs)
tem (var-ref v))
(when (>= tem real-min)
(incf have)
(setq this-min (min this-min tem))
(when (> have want)
(setq have 0
real-min (1+ this-min)
this-min 1000000
vs vars))))
(when (< have want) (decf real-min))
(dolist (v vars)
(when (< (var-ref v) real-min)
;; don't put 1, otherwise optimization may discard
;; variable
(setf (var-ref v) (min (var-ref v) *register-min*))))))
(let (addr data)
(dolist (v vars)
(if (member-type (var-type v) '(FIXNUM CHARACTER SHORT-FLOAT LONG-FLOAT))
(pushnew v data)
(pushnew v addr)))
(analyze-regs1 addr *free-address-registers*)
(analyze-regs1 data *free-data-registers*))))
(defun wt-global-entry (fname cfun arg-types return-type)
(when (and (symbolp fname) (get-sysprop fname 'NO-GLOBAL-ENTRY))
(return-from wt-global-entry nil))
@ -762,7 +719,6 @@
(wt-h1 ");")
(wt ")")
(analyze-regs (c1form-referred-vars lambda-expr))
(let* ((*lcl* 0) (*temp* 0) (*max-temp* 0)
(*lex* 0) (*max-lex* 0)
(*env* (fun-env fun)) ; continue growing env
@ -972,9 +928,3 @@
;(put-sysprop 'DEFENTRY 'T3 't3defentry)
(put-sysprop 'DEFCBODY 'T3 't3defCbody) ; Beppe
;(put-sysprop 'DEFUNC 'T3 't3defunC) ; Beppe
;;; Package operations.
(put-sysprop 'si::select-package 'PACKAGE-OPERATION t)
(put-sysprop 'si::%defpackage 'PACKAGE-OPERATION t)

1
src/cmp/cmputil.lsp
View file

@ -172,7 +172,6 @@
(defun si::compiler-clear-compiler-properties (symbol)
#-:CCL
;(sys::unlink-symbol symbol)
(rem-sysprop symbol 'package-operation)
(rem-sysprop symbol 't1)
(rem-sysprop symbol 't2)
(rem-sysprop symbol 't3)

73
src/cmp/cmpvar.lsp
View file

@ -12,36 +12,6 @@
(in-package "COMPILER")
#|
;;; Use a structure of type vector to avoid creating
;;; normal structures before booting CLOS:
(defstruct (var (:type vector) :named)
name ;;; Variable name.
(ref 0 :type fixnum)
;;; Number of references to the variable (-1 means IGNORE).
;;; During Pass 2: set below *register-min* for non register.
ref-ccb ;;; Cross closure reference: T or NIL.
kind ;;; One of LEXICAL, SPECIAL, GLOBAL, OBJECT, FIXNUM,
;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, or REPLACED (used for
;;; LET 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
;;; the variable is referenced across Level Boundary and thus
;;; cannot be allocated on the C stack. Note that OBJECT is
;;; set during variable binding and CLB is set when the
;;; variable is used later, and therefore CLB may supersede
;;; OBJECT.
;;; During Pass 2:
;;; For REPLACED: the actual location of the variable.
;;; For FIXNUM, CHARACTER, LONG-FLOAT, SHORT-FLOAT, OBJECT:
;;; the cvar for the C variable that holds the value.
;;; For LEXICAL: the frame-relative address for the variable.
;;; For SPECIAL and GLOBAL: the vv-index for variable name.
(type t) ;;; Type of the variable.
(index -1) ;;; position in *vars*. Used by similar.
) |#
;;; A special binding creates a var object with the kind field SPECIAL,
;;; whereas a special declaration without binding creates a var object with
;;; the kind field GLOBAL. Thus a reference to GLOBAL may need to make sure
@ -110,11 +80,13 @@
(t
(dolist (v types)
(when (eq (car v) name)
(case (cdr v)
(setf (var-type var) (cdr v))
; (case (cdr v)
; (OBJECT (setf (var-loc var) 'OBJECT))
(REGISTER
(incf (var-ref var) 100))
(t (setf (var-type var) (cdr v))))))
; (REGISTER
; (incf (var-ref var) 100))
; (t (setf (var-type var) (cdr v))))
))
; (when (or (null (var-type var))
; (eq t (var-type var)))
; (setf (var-loc var) 'OBJECT))
@ -127,11 +99,10 @@
)
(defun check-vref (var)
(when (and (eq (var-kind var) 'LEXICAL)
(not (var-ref-ccb var)))
(when (eq (var-kind var) 'LEXICAL)
(when (zerop (var-ref var)) ;;; This field may be -1 (IGNORE). Beppe
(cmpwarn "The variable ~s is not used." (var-name var)))
(when (not (eq (var-loc var) 'CLB))
(when (not (var-ref-clb var))
;; if the variable can be stored locally, set it var-kind to its type
(setf (var-kind var)
(if (> (var-ref var) 1)
@ -177,9 +148,12 @@
(cmpwarn "The ignored variable ~s is used." name)
(setf (var-ref var) 0))
(when (eq (var-kind var) 'LEXICAL)
(cond (ccb (setf (var-ref-ccb var) t
(var-loc var) 'OBJECT)) ; replace a previous 'CLB
(clb (setf (var-loc var) 'CLB))))
(cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB
(var-ref-ccb var) t
(var-kind var) 'CLOSURE
(var-loc var) 'OBJECT))
(clb (setf (var-ref-clb var) t
(var-loc var) 'OBJECT))))
(incf (var-ref var))
(return-from c1vref var)))) ; ccb
(let ((var (sch-global name)))
@ -207,7 +181,7 @@
(not (eq (var-rep-type var) :object)))
(defun local (var)
(and (not (member (var-kind var) '(LEXICAL SPECIAL GLOBAL REPLACED)))
(and (not (member (var-kind var) '(LEXICAL CLOSURE SPECIAL GLOBAL REPLACED)))
(var-kind var)))
(defun c2var (vref) (unwind-exit vref))
@ -217,9 +191,8 @@
(defun wt-var (var &aux (var-loc (var-loc var))) ; ccb
(declare (type var var))
(case (var-kind var)
(LEXICAL (cond ;(ccb (wt-env var-loc))
((var-ref-ccb var) (wt-env var-loc))
(t (wt-lex var-loc))))
(CLOSURE (wt-env var-loc))
(LEXICAL (wt-lex var-loc))
(SPECIAL (wt "(" var-loc "->symbol.dbind)"))
(REPLACED (wt var-loc))
(GLOBAL (if *safe-compile*
@ -230,19 +203,19 @@
(defun var-rep-type (var)
(case (var-kind var)
((LEXICAL SPECIAL GLOBAL) :object)
((LEXICAL CLOSURE SPECIAL GLOBAL) :object)
(REPLACED (loc-representation-type (var-loc var)))
(t (var-kind var))))
(defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb
(if (var-p var)
(case (var-kind var)
(CLOSURE
(wt-nl)(wt-env var-loc)(wt "= ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
(LEXICAL
(wt-nl)
(if (var-ref-ccb var)
(wt-env var-loc)
(wt-lex var-loc))
(wt "= ")
(wt-nl)(wt-lex var-loc)(wt "= ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
(SPECIAL

17
src/cmp/cmpwt.lsp
View file

@ -139,20 +139,3 @@
(defun wt-data-end ()
(princ #\; *compiler-output-data*))
(defun wt-data-package-operation (form)
(ecase (car form)
(si::select-package
(let ((output (t1ordinary form)))
(cmp-eval form)
(let ((package-name (string (cadr form))))
(setq *compiler-package* (si::select-package package-name))
(setq package-name (package-name *compiler-package*))
(wt-filtered-data (format nil "#!0 ~s" package-name)))
output))
;#+nil(wt-filtered-data (format nil "#!0 ~s" (string package-name)))))
(si::%defpackage
(let ((output (t1ordinary `(eval ',form))))
(wt-filtered-data (format nil "#!1 ~s" (second form)))
(cmp-eval form)
output))))

3
src/h/internal.h
View file

@ -145,6 +145,9 @@ extern void cl_write_object(cl_object x);
/* read.d */
#define RTABSIZE CHAR_CODE_LIMIT /* read table size */
extern cl_object ecl_packages_to_be_created;
extern cl_object ecl_package_list;
#ifdef __cplusplus
}
#endif

2
src/lsp/defmacro.lsp
View file

@ -9,7 +9,7 @@
;;;; See file '../Copyright' for full details.
;;;; defines SYS:DEFMACRO*, the defmacro preprocessor
(si::select-package "SYSTEM")
(in-package "SYSTEM")
#-ecl-min
(defvar *dl*)

7
src/lsp/defpackage.lsp
View file

@ -164,7 +164,8 @@
(case num
(1 ':EXPORT)
(2 ':INTERN)))))
`(si::%defpackage
`(eval-when (eval compile load)
(si::dodefpackage
,name
',nicknames
,(car documentation)
@ -174,10 +175,10 @@
',exported-symbol-names
',shadowing-imported-from-symbol-names-list
',imported-from-symbol-names-list
',exported-from-package-names))))
',exported-from-package-names)))))
(defun %defpackage (name
(defun dodefpackage (name
nicknames
documentation
use

4
src/lsp/evalmacros.lsp
View file

@ -8,7 +8,7 @@
;;;;
;;;; See file '../Copyright' for full details.
(si::select-package "SYSTEM")
(in-package "SYSTEM")
(defmacro defun (name vl &body body &aux doc-string)
"Syntax: (defun name lambda-list {decl | doc}* {form}*)
@ -329,7 +329,7 @@ SECOND-FORM."
`(eval-when (compile) (proclaim ',(car decl-specs)))))
(defmacro in-package (name)
`(si::select-package ,(string name)))
`(eval-when (eval compile load) (si::select-package ,(string name))))
;; FIXME!
(defmacro the (type value)

6
src/lsp/export.lsp
View file

@ -9,7 +9,8 @@
;;;; See file '../Copyright' for full details.
;;;; Exporting external symbols of LISP package
(si::select-package "SI")
(eval-when (eval compile load)
(si::select-package "SI"))
;;; ----------------------------------------------------------------------
;;;
@ -31,7 +32,8 @@
t)
(si::fset 'in-package
#'(lambda-block in-package (def env)
`(si::select-package ,(string (second def))))
`(eval-when (eval compile load)
(si::select-package ,(string (second def)))))
t)
)