diff --git a/src/CHANGELOG b/src/CHANGELOG index d497d7950..6b4d9e6a3 100755 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -6,6 +6,12 @@ ECL 13.7.1 - DEFUN functions not defined as toplevel forms were also directly referenced other code in the same file. +* Extensions: + +- In compiled code it is possible to declare variables to have a C type + such as in (declare (:double a)) and then the variable is enforced to + be unboxed to such type. + ;;; Local Variables: *** ;;; mode:text *** ;;; fill-column:79 *** diff --git a/src/cmp/cmpenv-declare.lsp b/src/cmp/cmpenv-declare.lsp index 0df540a73..f0c96f9b8 100644 --- a/src/cmp/cmpenv-declare.lsp +++ b/src/cmp/cmpenv-declare.lsp @@ -105,7 +105,9 @@ and a possible documentation string (only accepted when DOC-P is true)." (policy-declaration-name-p decl-name)) (push decl others) (multiple-value-bind (ok type) - (valid-type-specifier decl-name) + (if (machine-c-type-p decl-name) + (values t decl-name) + (valid-type-specifier decl-name)) (cmpassert ok "Unknown declaration specifier ~s" decl-name) (setf types (collect-declared type decl-args types)))))) diff --git a/src/cmp/cmptypes.lsp b/src/cmp/cmptypes.lsp index b48483278..9b909b74d 100644 --- a/src/cmp/cmptypes.lsp +++ b/src/cmp/cmptypes.lsp @@ -51,8 +51,8 @@ ; ref-clb ;;; Cross local function reference: T or NIL. ; read-nodes ;;; Nodes (c1forms) in which the reference occurs set-nodes ;;; Nodes in which the variable is modified - kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, :FIXNUM, - ;;; :CHAR, :DOUBLE, :FLOAT. + kind ;;; One of LEXICAL, CLOSURE, SPECIAL, GLOBAL, :OBJECT, + ;;; or some C representation type (:FIXNUM, :CHAR, etc) (function *current-function*) ;;; For local variables, in which function it was created. ;;; For global variables, it doesn't have a meaning. diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 80398b658..5e56e0f5e 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -72,6 +72,7 @@ (mapcar #'first (var-read-nodes var))) (defun assert-var-ref-value (var) + #+debug-compiler (unless (let ((ref (var-ref var))) (or (> ref (/ most-positive-fixnum 2)) (= (var-ref var) (+ (length (var-read-nodes var)) @@ -172,18 +173,23 @@ (cmpck (not (symbolp name)) "The variable ~s is not a symbol." name) (cmpck (constantp name) "The constant ~s is being bound." name) (let ((ignorable (cdr (assoc name ignores))) - type) - (setq type (if (setq type (assoc name types)) - (cdr type) - 'T)) + (kind 'LEXICAL) ; we rely on check-vref to fix it + (type (assoc name types))) + (cond ((null type) + (setq type 'T)) + ((machine-c-type-p (setq type (cdr type))) + (setf kind type + type (rep-type->lisp-type type)))) (cond ((or (member name specials) (special-variable-p name)) - (unless type + (unless (eq kind 'LEXICAL) + (cmperr "Special variable ~A cannot be declared to have C type ~A" + name type)) + (when (eq type 'T) (setf type (or (get-sysprop name 'CMP-TYPE) 'T))) (c1make-global-variable name :kind 'SPECIAL :type type)) (t (make-var :name name :type type :loc 'OBJECT - :kind 'LEXICAL ; we rely on check-vref to fix it - :ignorable ignorable + :kind kind :ignorable ignorable :ref 0))))) (defun check-vref (var) @@ -229,15 +235,20 @@ ;; symbol-macrolet (baboon)) (t - (assert-var-ref-value var) - (assert-var-not-ignored var) - (when (eq (var-kind var) 'LEXICAL) - (cond (ccb (setf (var-ref-clb var) nil ; replace a previous 'CLB + (case (var-kind var) + ((SPECIAL GLOBAL)) + ((CLOSURE)) + ((LEXICAL) + (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)))) + (t + (when (or clb ccb) + (cmperr "Variable ~A declared of C type cannot be referenced across function boundaries." + (var-name var))))) var)))) (defun push-vars (v)