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

cmp: don't USE the package EXT

Browse source
This commit is contained in:
Daniel Kochmański 2023-02-14 11:42:20 +01:00
parent e74826b9cd
commit e4988d1f7c
18 changed files with 63 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

24
src/cmp/cmparray.lsp
View file

@ -80,8 +80,8 @@
,%displaced-to ,%displaced-index-offset)))
;; Then we may fill the array with a given value
(when initial-element-supplied-p
(setf form `(si::fill-array-with-elt ,form ,%initial-element 0 nil)))
(setf form `(truly-the (array ,guessed-element-type ,dimensions-type)
(setf form `(si:fill-array-with-elt ,form ,%initial-element 0 nil)))
(setf form `(ext:truly-the (array ,guessed-element-type ,dimensions-type)
,form))))
form)
@ -92,7 +92,7 @@
(defun expand-vector-push (whole env extend &aux (args (rest whole)))
(declare (si::c-local)
(ignore env))
(with-clean-symbols (value vector index dimension)
(ext:with-clean-symbols (value vector index dimension)
(when (or (eq (first args) 'value) ; No infinite recursion
(not (policy-open-code-aref/aset)))
(return-from expand-vector-push
@ -114,8 +114,8 @@
(declare (fixnum index dimension)
(:read-only index dimension))
(cond ((< index dimension)
(sys::fill-pointer-set vector (truly-the fixnum (+ 1 index)))
(sys::aset vector index value)
(si:fill-pointer-set vector (ext:truly-the fixnum (+ 1 index)))
(si:aset vector index value)
index)
(t ,(if extend
`(vector-push-extend value vector ,@(cddr args))
@ -137,7 +137,7 @@
form))
(defun expand-aref (array indices env)
(with-clean-symbols (%array)
(ext:with-clean-symbols (%array)
`(let ((%array ,array))
(declare (:read-only %array)
(optimize (safety 0)))
@ -162,11 +162,11 @@
`(let* ((,%array ,array))
(declare (:read-only ,%array)
(optimize (safety 0)))
(si::row-major-aset ,%array ,(expand-row-major-index %array indices env) ,value))))
(si:row-major-aset ,%array ,(expand-row-major-index %array indices env) ,value))))
(define-compiler-macro array-row-major-index (&whole form array &rest indices &environment env)
(if (policy-open-code-aref/aset env)
(with-clean-symbols (%array)
(ext:with-clean-symbols (%array)
`(let ((%array ,array))
(declare (:read-only %array)
(optimize (safety 0)))
@ -188,7 +188,7 @@
(check-vector-in-bounds ,a ,index)
,index)))
(if (policy-type-assertions env)
(with-clean-symbols (%array-index)
(ext:with-clean-symbols (%array-index)
`(let ((%array-index ,index))
(declare (:read-only %array-index))
,(expansion a '%array-index)))
@ -207,7 +207,7 @@
for index in indices
collect `(,(gentemp "DIM") (array-dimension-fast ,a ,i))))
(dim-names (mapcar #'first dims)))
(with-clean-symbols (%ndx-var %output-var %dim-var)
(ext:with-clean-symbols (%ndx-var %output-var %dim-var)
`(let* (,@dims
(%output-var 0))
(declare (type ext:array-index %output-var ,@dim-names)
@ -221,12 +221,12 @@
for dim-var in dim-names
when (plusp i)
collect `(setf %output-var
(truly-the ext:array-index (* %output-var ,dim-var)))
(ext:truly-the ext:array-index (* %output-var ,dim-var)))
collect `(let ((%ndx-var ,index))
(declare (ext:array-index %ndx-var))
,(and check `(check-index-in-bounds ,a %ndx-var ,dim-var))
(setf %output-var
(truly-the ext:array-index (+ %output-var %ndx-var)))))
(ext:truly-the ext:array-index (+ %output-var %ndx-var)))))
%output-var))))
;(trace c::expand-row-major-index c::expand-aset c::expand-aref)

2
src/cmp/cmpc-wt.lsp
View file

@ -178,7 +178,7 @@
:element-type 'base-char
:adjustable t
:fill-pointer 0))
(stream (make-sequence-output-stream output :external-format format)))
(stream (ext:make-sequence-output-stream output :external-format format)))
(write-string string stream)
output))

2
src/cmp/cmpenv-api.lsp
View file

@ -49,7 +49,7 @@ the closure in let/flet forms for variables/functions it closes over."
`(progn ,@(rest record-def)))
record-lexenv env)))
(setf definition
`(flet ((,(compiled-function-name record)
`(flet ((,(ext:compiled-function-name record)
,@record-def))
,definition))))
((and (listp record) (symbolp (car record)))

4
src/cmp/cmpmac.lsp
View file

@ -32,8 +32,8 @@
(declare (type (integer 0 1023) hash)
(type (array t (*)) ,cache-name))
(if (and elt ,@(loop for arg in lambda-list
collect `(,test (pop (truly-the cons elt)) ,arg)))
(first (truly-the cons elt))
collect `(,test (pop (ext:truly-the cons elt)) ,arg)))
(first (ext:truly-the cons elt))
(let ((output (,name ,@lambda-list)))
(setf (aref ,cache-name hash) (list ,@lambda-list output))
output))))))))

2
src/cmp/cmpmap.lsp
View file

@ -46,7 +46,7 @@
(MAPCAN (setf do-or-collect 'NCONC))
(MAPCON (setf in-or-on :ON do-or-collect 'NCONC)))
(when (eq in-or-on :ON)
(setf args (mapcar #'(lambda (arg) `(checked-value list ,arg)) args)))
(setf args (mapcar #'(lambda (arg) `(ext:checked-value list ,arg)) args)))
(when (eq do-or-collect :DO)
(let ((var (gensym)))
(setf list-1-form `(with ,var = ,(first args))

12
src/cmp/cmpnum.lsp
View file

@ -23,12 +23,12 @@
(define-compiler-macro boole (&whole form op-code op1 op2)
(or (and (constantp op-code *cmp-env*)
(case (ext:constant-form-value op-code *cmp-env*)
(#. boole-clr `(progn (checked-value integer ,op1) (checked-value integer ,op2) 0))
(#. boole-set `(progn (checked-value integer ,op1) (checked-value integer ,op2) -1))
(#. boole-1 `(prog1 (checked-value integer ,op1) (checked-value integer ,op2)))
(#. boole-2 `(progn (checked-value integer ,op1) (checked-value integer ,op2)))
(#. boole-c1 `(prog1 (lognot ,op1) (checked-value integer ,op2)))
(#. boole-c2 `(progn (checked-value integer ,op1) (lognot ,op2)))
(#. boole-clr `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) 0))
(#. boole-set `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2) -1))
(#. boole-1 `(prog1 (ext:checked-value integer ,op1) (ext:checked-value integer ,op2)))
(#. boole-2 `(progn (ext:checked-value integer ,op1) (ext:checked-value integer ,op2)))
(#. boole-c1 `(prog1 (lognot ,op1) (ext:checked-value integer ,op2)))
(#. boole-c2 `(progn (ext:checked-value integer ,op1) (lognot ,op2)))
(#. boole-and `(logand ,op1 ,op2))
(#. boole-ior `(logior ,op1 ,op2))
(#. boole-xor `(logxor ,op1 ,op2))

8
src/cmp/cmpopt-bits.lsp
View file

@ -30,7 +30,7 @@
(define-compiler-macro ldb (&whole whole bytespec integer)
(if (inline-bytespec bytespec)
(with-clean-symbols (%pos %size)
(ext:with-clean-symbols (%pos %size)
`(with-let*-type-check ((%size ,(second bytespec) unsigned-byte)
(%pos ,(third bytespec) unsigned-byte))
(logand (lognot (ash -1 %size)) (ash ,integer (- %pos)))))
@ -43,7 +43,7 @@
(define-compiler-macro mask-field (&whole whole bytespec integer)
(if (inline-bytespec bytespec)
(with-clean-symbols (%pos %size)
(ext:with-clean-symbols (%pos %size)
`(with-let*-type-check ((%size ,(second bytespec) unsigned-byte)
(%pos ,(third bytespec) unsigned-byte))
(logand (ash (lognot (ash -1 %size)) %pos)
@ -52,7 +52,7 @@
(define-compiler-macro dpb (&whole whole newbyte bytespec integer)
(if (inline-bytespec bytespec)
(with-clean-symbols (%pos %size %mask)
(ext:with-clean-symbols (%pos %size %mask)
`(with-let*-type-check ((%size ,(second bytespec) unsigned-byte)
(%pos ,(third bytespec) unsigned-byte)
(%mask (ash (lognot (ash -1 %size)) %pos) t))
@ -62,7 +62,7 @@
(define-compiler-macro deposit-field (&whole whole newbyte bytespec integer)
(if (inline-bytespec bytespec)
(with-clean-symbols (%pos %size %mask)
(ext:with-clean-symbols (%pos %size %mask)
`(with-let*-type-check ((%size ,(second bytespec) unsigned-byte)
(%pos ,(third bytespec) unsigned-byte)
(%mask (ash (lognot (ash -1 %size)) %pos) t))

2
src/cmp/cmpopt-cons.lsp
View file

@ -22,7 +22,7 @@
(loop for v in values
for value-and-type in arg-types
collect (if (consp value-and-type)
`(checked-value ,(second value-and-type) ,v)
`(ext:checked-value ,(second value-and-type) ,v)
v)))
,@inline-form))

14
src/cmp/cmpopt-sequence.lsp
View file

@ -41,7 +41,7 @@
#+(or)
(define-compiler-macro si::make-seq-iterator (seq &optional (start 0))
(with-clean-symbols (%seq %start)
(ext:with-clean-symbols (%seq %start)
`(let ((%seq (optional-type-check ,seq sequence))
(%start ,start))
(cond ((consp %seq)
@ -53,7 +53,7 @@
#+(or)
(define-compiler-macro si::seq-iterator-ref (seq iterator)
(with-clean-symbols (%seq %iterator)
(ext:with-clean-symbols (%seq %iterator)
`(let* ((%seq ,seq)
(%iterator ,iterator))
(declare (optimize (safety 0)))
@ -61,18 +61,18 @@
;; Fixnum iterators are always fine
(aref %seq %iterator)
;; Error check in case we may have been passed an improper list
(si:cons-car (checked-value cons %iterator))))))
(si:cons-car (ext:checked-value cons %iterator))))))
#+(or)
(define-compiler-macro si::seq-iterator-next (seq iterator)
(with-clean-symbols (%seq %iterator)
(ext:with-clean-symbols (%seq %iterator)
`(let* ((%seq ,seq)
(%iterator ,iterator))
(declare (optimize (safety 0)))
(if (si::fixnump %iterator)
(let ((%iterator (1+ (truly-the fixnum %iterator))))
(if (ext:fixnump %iterator)
(let ((%iterator (1+ (ext:truly-the fixnum %iterator))))
(declare (fixnum %iterator))
(and (< %iterator (length (truly-the vector %seq)))
(and (< %iterator (length (ext:truly-the vector %seq)))
%iterator))
(si:cons-cdr %iterator)))))

6
src/cmp/cmpopt.lsp
View file

@ -138,7 +138,7 @@
(type ,first ,var2))
(AND (TYPEP ,var1 ',first)
(locally (declare (optimize (speed 3) (safety 0) (space 0)))
(setf ,var2 (truly-the ,first ,var1))
(setf ,var2 (ext:truly-the ,first ,var1))
(AND ,@(expand-in-interval-p var2 rest)))))))
;;
;; Compound COMPLEX types.
@ -188,7 +188,7 @@
(list-var (gensym))
(typed-var (if (policy-assume-no-errors env)
list-var
`(truly-the cons ,list-var))))
`(ext:truly-the cons ,list-var))))
`(block nil
(let* ((,list-var ,expression))
(si::while ,list-var
@ -351,7 +351,7 @@
(c-type (lisp-type->rep-type float)))
`(let ((value ,value))
(declare (:read-only value))
(compiler-typecase value
(ext:compiler-typecase value
(,float value)
(t
(ffi:c-inline (value) (:object) ,c-type

3
src/cmp/cmppackage.lsp
View file

@ -16,7 +16,8 @@
(defpackage #:c
(:nicknames #:compiler)
(:use #:cl #:ext)
(:use #:cl)
(:import-from #:ext #:install-c-compiler)
(:export
;; Flags controlling the compiler behavior.
#:*compiler-break-enable*

4
src/cmp/cmppass1-call.lsp
View file

@ -272,10 +272,10 @@
call-arguments-limit
(+ (first requireds) (first optionals))))
(apply-constant-args-p (and apply-p (constantp apply-list)
(listp (constant-form-value apply-list))))
(listp (ext:constant-form-value apply-list))))
(n-args-got-min (if apply-constant-args-p
(+ (length arguments)
(length (constant-form-value apply-list)))
(length (ext:constant-form-value apply-list)))
(length arguments)))
(n-args-got-max (cond ((and apply-p (not apply-constant-args-p))
nil) ; unknown maximum number of arguments

6
src/cmp/cmppass1-special.lsp
View file

@ -32,7 +32,7 @@
(c1truly-the args))))
(defun c1truly-the (args)
(check-args-number 'TRULY-THE args 2 2)
(check-args-number 'ext:truly-the args 2 2)
(let* ((form (c1expr (second args)))
(the-type (first args))
type)
@ -43,7 +43,7 @@
form))
(defun c1compiler-let (args &aux (symbols nil) (values nil))
(when (endp args) (too-few-args 'COMPILER-LET 1 0))
(when (endp args) (too-few-args 'ext:compiler-let 1 0))
(dolist (spec (car args))
(cond ((consp spec)
(cmpck (not (and (symbolp (car spec))
@ -59,7 +59,7 @@
(setq symbols (nreverse symbols))
(setq values (nreverse values))
(setq args (progv symbols values (c1progn (cdr args))))
(make-c1form 'COMPILER-LET args symbols values args))
(make-c1form 'ext:compiler-let args symbols values args))
(defun c1function (args &aux fd)
(check-args-number 'FUNCTION args 1 1)

8
src/cmp/cmppass1-var.lsp
View file

@ -96,7 +96,7 @@
((trivial-type-p type)
(c1expr (first form)))
(t
(c1expr `(checked-value ,type ,(first form)))))))
(c1expr `(ext:checked-value ,type ,(first form)))))))
;; :read-only variable handling. Beppe
(when (read-only-variable-p name other-decls)
(if (global-var-p var)
@ -309,7 +309,7 @@
(type (var-type name))
(form (c1expr (if (trivial-type-p type)
form
`(checked-value ,type ,form)))))
`(ext:checked-value ,type ,form)))))
(add-to-set-nodes name (make-c1form* 'SETQ
:type (c1form-type form)
:args name form)))
@ -356,7 +356,7 @@
(push vref vrefs)
(push (c1expr (if (trivial-type-p type)
form
`(checked-value ,type ,form)))
`(ext:checked-value ,type ,form)))
forms))))
(defun c1multiple-value-bind (args)
@ -402,7 +402,7 @@
(let ((new-var (gensym)))
(push new-var vars)
(push new-var value-bindings)
(push `(setf ,var-or-form (checked-value ,type ,new-var)) storing-forms))))
(push `(setf ,var-or-form (ext:checked-value ,type ,new-var)) storing-forms))))
(multiple-value-bind (setf-vars setf-vals stores storing-form get-form)
(get-setf-expansion var-or-form *cmp-env*)
(push (first stores) vars)

6
src/cmp/cmptables.lsp
View file

@ -152,7 +152,7 @@
'((ext:with-backend . c1with-backend) ; t1
(cl:defmacro . t1defmacro)
(si:compiler-let . c1compiler-let)
(ext:compiler-let . c1compiler-let)
(cl:eval-when . c1eval-when)
(cl:progn . c1progn)
(cl:macrolet . c1macrolet)
@ -235,7 +235,7 @@
(cl:multiple-value-bind . c2multiple-value-bind)
(cl:function . c2function)
(si:compiler-let . c2compiler-let)
(ext:compiler-let . c2compiler-let)
(with-stack . c2with-stack)
(stack-push-values . c2stack-push-values)
@ -256,7 +256,7 @@
))
(defconstant +t2-dispatch-alist+
'((si:compiler-let . t2compiler-let)
'((ext:compiler-let . t2compiler-let)
(cl:progn . t2progn)
(ordinary . t2ordinary)
(cl:load-time-value . t2load-time-value)

10
src/cmp/cmptype-assert.lsp
View file

@ -75,7 +75,7 @@
(symbol-macro-p value))
;; If multiple references to the value cost time and space,
;; or may cause side effects, we save it.
(with-clean-symbols (%asserted-value)
(ext:with-clean-symbols (%asserted-value)
`(let* ((%asserted-value ,value))
(declare (:read-only %asserted-value))
,(expand-type-assertion '%asserted-value type env compulsory))))
@ -126,14 +126,14 @@
value type)
(cmpdebug "Checking type of ~S to be ~S" value type))
(let ((full-check
(with-clean-symbols (%checked-value)
(ext:with-clean-symbols (%checked-value)
`(let* ((%checked-value ,value))
(declare (:read-only %checked-value))
,(expand-type-assertion '%checked-value type *cmp-env* nil)
,(if (null and-type)
'%checked-value
`(truly-the ,type %checked-value))))))
(make-c1form* 'CHECKED-VALUE
`(ext:truly-the ,type %checked-value))))))
(make-c1form* 'ext:CHECKED-VALUE
:type type
:args type form (c1expr full-check)))))))
@ -149,7 +149,7 @@ expression, ensuring that it is satisfied."
(when (and (policy-type-assertions env)
(not (trivial-type-p type)))
(cmpdebug "Checking type of ~A to be ~A" value type)
`(checked-value ,type ,value)))
`(ext:checked-value ,type ,value)))
(defmacro type-assertion (&whole whole value type &environment env)
"Generates a type check on an expression, ensuring that it is satisfied."

6
src/cmp/cmptype.lsp
View file

@ -119,7 +119,7 @@
;; later due to this assertion...
(setf (var-type var) t
checks (list* `(type-assertion ,name ,type) checks)
new-auxs (list* `(truly-the ,type ,name) name new-auxs))
new-auxs (list* `(ext:truly-the ,type ,name) name new-auxs))
;; Or simply enforce the variable's type.
(setf (var-type var) (type-and (var-type var) type))))
finally
@ -191,10 +191,10 @@
((multiple-value-setq (valid value) (constant-value-p value env))
(si::maybe-quote value))
(t
(with-clean-symbols (%value)
(ext:with-clean-symbols (%value)
`(let* ((%value ,value))
,(type-error-check '%value (replace-invalid-types type))
(truly-the ,type %value)))))))
(ext:truly-the ,type %value)))))))
(defun replace-invalid-types (type)
;; Some types which are acceptable in DECLARE are not

6
src/cmp/cmputil.lsp
View file

@ -270,13 +270,13 @@
(return nil))
(flag
(setf flag nil
fast (cdr (truly-the cons fast))))
fast (cdr (ext:truly-the cons fast))))
((eq slow fast)
(return nil))
(t
(setf flag t
slow (cdr (truly-the cons slow))
fast (cdr (truly-the cons fast)))))
slow (cdr (ext:truly-the cons slow))
fast (cdr (ext:truly-the cons fast)))))
finally (return l)))
(defun check-args-number (operator args &optional (min 0) (max most-positive-fixnum))