-*- Mode : Lisp ; Package : CCL -*-
;;;
  Copyright 1994 - 2009 Clozure Associates
;;;
  Licensed under the Apache License , Version 2.0 ( the " License " ) ;
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     -2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an " AS IS " BASIS ,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(in-package "CCL")

;;; primitives that manipulate function & variable definitions.





(defun functionp (arg)
  "Return true if OBJECT is a FUNCTION, and NIL otherwise."
  (functionp arg))

(defun lfunp (arg)
  (functionp arg))

(defun %proclaim-special (sym &optional initp)
  (let* ((oldbits (%symbol-bits sym)))
    (declare (fixnum oldbits))
    (%symbol-bits sym (bitset $sym_vbit_special oldbits))
    initp))

(setq *lfun-names* (make-hash-table :test 'eq :weak t))

(defun lookup-lfun-name (lfun) 
  (gethash lfun *lfun-names*))


(defun function-name (fun)
  (or (and (functionp fun) (lfun-name fun))
      (if (compiled-function-p (setq fun (closure-function fun)))
        (lfun-name fun))))


(defun bootstrapping-fmakunbound (name)
  (when (consp name)
    (unless (eq (%car name) 'setf)
      (error "Function spec handler not loaded yet"))
    (setq name (setf-function-name (cadr name))))
  (%unfhave name)
  name)

  redefined in sysutils .
(%fhave 'fmakunbound #'bootstrapping-fmakunbound)

(defun bootstrapping-fset (name fn)
  (fmakunbound name)
  (%fhave name fn)
  fn)

Redefined in sysutils .
(%fhave 'fset #'bootstrapping-fset)

(defun fset-symbol (name fn)
  (fset (require-type name 'symbol) fn))


(defun bootstrapping-record-source-file (fn &optional type)
  (declare (ignore fn type))
  nil)

;Redefined in l1-utils.
(%fhave 'record-source-file #'bootstrapping-record-source-file)


(setq *fasload-print* nil)
(setq *save-doc-strings* t)



(%fhave '%defun-encapsulated-maybe ;Redefined in encapsulate
        (qlfun bootstrapping-defun-encapsulated (name fn)
          (declare (ignore name fn))
          nil))

(%fhave 'encapsulated-function-name  ;Redefined in encapsulate - used in l1-io
        (qlfun bootstrapping-encapsulated-function-name (fn)
          (declare (ignore fn))
          nil))

(%fhave 'set-function-info (qlfun set-function-info  (name info)
                                  (if (typep info 'string)
                                    (set-documentation name 'function info))
                                  name))

(defun %defun (named-fn &optional info)
  (unless (typep named-fn 'function)
    (dbg named-fn))
  (let* ((name (function-name named-fn)))
    (unless (and name
                 (or (symbolp name)
                     (setf-function-name-p name)))
      (dbg named-fn))
  (record-source-file name 'function)
  (when (not (%defun-encapsulated-maybe name named-fn))
    (when (and (symbolp name) (macro-function name nil))
      (warn "The macro ~s is being redefined as a function." name)
      (fmakunbound name))
    (fset name named-fn))
  (set-function-info name info)
  (when *fasload-print* (format t "~&~S~%" name))
  name))

(defun validate-function-name (name)
  (if (symbolp name)
    name
    (if (setf-function-name-p name)
      (setf-function-name (cadr name))
      (report-bad-arg name 'function-name))))

     There are three kinds of things which can go in the function
     cell of a symbol : 1 ) A function .   2 ) The thing which is the
     value of % unbound - function% : a 1 - element vector whose 0th
;;;    element is a code vector which causes an "undefined function"
     error to be signalled .   3 ) A macro or special - form definition ,
     which is a 2 - element vector whose 0th element is a code vector
;;;    which signals a "can't apply macro or special form" error when
     executed and whose 1st element is a macro or special - operator
     name .   It does n't matter what type of gvector cases 2 and 3
;;;    are.  Once that's decided, it wouldn't hurt if %FHAVE
     typechecked its second arg .

(defun %fhave (name def)
  (let* ((fname (validate-function-name name)))
    (setf (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell) def)))

;;; FBOUNDP is true of any symbol whose function-cell contains something other
;;; than %unbound-function%; we expect FBOUNDP to return that something.
(defun fboundp (name)
  "Return true if name has a global function definition."
  (let* ((fname (validate-function-name name))
         (def (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell)))
    (unless (eq def %unbound-function%)
      def)))

  % UNFHAVE does n't seem to want to deal with SETF names or function specs .
;;; Who does ?

(defun %unfhave (sym)
  (let* ((symvec (symptr->symvector (%symbol->symptr sym)))
         (old (%svref symvec target::symbol.fcell-cell))
         (unbound %unbound-function%))
    (setf (%svref symvec target::symbol.fcell-cell) unbound)
    (not (eq old unbound))))

  It 's guaranteed that lfun - bits is a fixnum .   Might be a 30 - bit fixnum ...





(defun lfun-vector-name (fun &optional (new-name nil set-name-p))
  (let* ((bits (lfun-bits fun)))
    (declare (fixnum bits))
    (if (and (logbitp $lfbits-gfn-bit bits)
	     (not (logbitp $lfbits-method-bit bits)))
      (progn
        (if set-name-p
          (%gf-name fun new-name)
          (%gf-name fun)))
      (let* ((has-name-cell (not (logbitp $lfbits-noname-bit bits))))
	(if has-name-cell
	  (let* ((lfv (lfun-vector fun))
                 (name-idx (- (the fixnum (uvsize lfv)) 2))
		 (old-name (%svref lfv name-idx)))
	    (declare (fixnum name-idx))
	    (if (and set-name-p (not (eq old-name new-name)))
	      (setf (%svref lfv name-idx) new-name))
	    old-name))))))

(defun lfun-name (fun &optional (new-name nil set-name-p))
  (multiple-value-bind (stored-name stored?) (lookup-lfun-name fun)
    (unless stored?
      (setq stored-name (lfun-vector-name fun)))
    (when (and set-name-p (neq new-name stored-name))
      (if (and stored? (eq new-name (lfun-vector-name fun)))
        (remhash fun *lfun-names*)
        (if (logbitp $lfbits-noname-bit (the fixnum (lfun-bits fun)))   ; no name-cell in function vector.
          (puthash fun *lfun-names* new-name)
          (lfun-vector-name fun new-name))))
    stored-name))

(defun lfun-bits (function &optional new)
  (unless (functionp function)
    (setq function (require-type function 'function)))
  (let* ((lfv (lfun-vector function))
         (idx (1- (the fixnum (uvsize lfv))))
         (old (%svref lfv idx)))
    (declare (fixnum idx))
    (if new
      (setf (%svref lfv idx) new))
    old))
    
(defun %macro-have (symbol macro-function)
  (declare (special %macro-code%))      ; magically set by xloader.
  (%fhave symbol
          #-arm-target (vector %macro-code% macro-function)
          #+arm-target (%fix-fn-entrypoint (gvector :pseudofunction 0 %macro-code% macro-function))))


(defun special-operator-p (symbol)
  "If the symbol globally names a special form, return T, otherwise NIL."
  (let ((def (fboundp symbol)))
    (and #-arm-target (typep def 'simple-vector)
         #+arm-target (= (typecode def) arm::subtag-pseudofunction)
         (not (lfunp #-arm-target (svref def 1)
                     #+arm-target (uvref def 2))))))

(defun special-form-p (x) (special-operator-p x))

(defun setf-function-name-p (thing)
  (and (consp thing)
       (consp (%cdr thing))
       (null (%cddr thing))
       (eq (%car thing) 'setf)
       (symbolp (%cadr thing))))

(defun macro-function (form &optional env)
  "If SYMBOL names a macro in ENV, returns the expansion function,
   else returns NIL. If ENV is unspecified or NIL, use the global
   environment only."
  (setq form (require-type form 'symbol))
  (when env
    ;; A definition-environment isn't a lexical environment, but it can
  be an ancestor of one .
    (unless (istruct-typep env 'lexical-environment)
        (report-bad-arg env 'lexical-environment))
      (let ((cell nil))
        (tagbody
          top
          (if (setq cell (%cdr (assq form (lexenv.functions env))))
            (return-from macro-function 
              (if (eq (car cell) 'macro) (%cdr cell))))
          (unless (listp (setq env (lexenv.parent-env env)))
            (go top)))))
      ;; Not found in env, look in function cell.
  (%global-macro-function form))

(defun %fixnum-ref-macptr (fixnum &optional (offset 0))
  (%int-to-ptr (%fixnum-ref-natural fixnum offset)))

(defun %fixnum-set-macptr (fixnum offset &optional (newval offset newval-p))
  (%fixnum-set-natural fixnum (if newval-p offset 0) (%ptr-to-int newval))
  newval)

(defun nth-catch-frame-tag (n)
  (declare (fixnum n))
  (let* ((frame (%catch-top (%current-tcr))))
    (dotimes (i n (%svref frame target::catch-frame.catch-tag-cell))
      (setq frame (%svref frame target::catch-frame.link-cell)))))

;;; This function is magic, and it can only be called from
;;; an unwind-protect cleanup form (making it even more magic.)
;;; If we can tell that we reached the unwind-protect via THROW,
;;; return a list of the target catch tag and all values being
;;; thrown.
#+x86-target
(defun %throwing-through-cleanup-p ()
  ;; when we enter and unwind-protect cleanup on x8664, the
  ;; top frame on the tstack contains state information that's
  used both by THROW and by normal exit from the protected
  ;; form.  That state information contains a count of the number
  ;; of catch/unwind-protect frames still to be processed (non-zero
  ;; only in the case where we're actually throwing), the value(s)
  ;; being thrown, and a return address that isn't interesting to
  ;; us.  It's an historical accident that that information is stored
  ;; differently in the cases where a single value is being thrown
  ;; and multiple values are thrown.
  A tstack frame is always doubleword aligned , and the first two
  ;; words are a backpointer to the previous tstack frame and a
  ;; pointer into the main lisp stack.  In the single value case,
  we then have 3 words : return address , frame count , value ;
  in the multiple - value we have 3 fixed words ( value count ,
  ;; return address, frame count) with the values following the
  frame count ( value 0 follows immediately . )
  ;; A cleanup form is always called from either .SPnthrowvalues
  of .SPnthrow1value , and those subprims can be called either
  by .SPthrow ( in which case the return address in the frame
  ;; will have no function associated with it) or by Lisp code
  ;; (in which case it will.)
  ;; We (have to) just assume that the frame on top of the temp
  stack is context info for the nthrow stuff .   Tracing this
  ;; function may violate this assumption and cause misbehavior
  ;; here.
  (let* ((frame (%current-tsp))
         (single-value-case (not (typep (%lisp-word-ref frame 2) 'fixnum)))
         (frame-count (%lisp-word-ref frame (if single-value-case 3 4)))
         (throwing (null (%return-address-function (if single-value-case
                                                     (%lisp-word-ref frame 2)
                                                     (%lisp-word-ref frame 3))))))
    (declare (fixnum frame))
    (if throwing
      (collect ((info))
        (info (nth-catch-frame-tag frame-count))
        (if single-value-case
          (info (%lisp-word-ref frame 4))
          (let* ((valptr (+ frame 5)))
            (declare (fixnum valptr))
            (dotimes (i (%lisp-word-ref frame 2))
              (declare (fixnum i))
              (info (%lisp-word-ref valptr i)))))
        (info)))))

;;; end of l0-def.lisp

 Package : CCL -*-



 you may not use this file except in compliance with the License.
 You may obtain a copy of the License at

     -2.0

 Unless required by applicable law or agreed to in writing, software
 WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 See the License for the specific language governing permissions and
 limitations under the License.
 primitives that manipulate function & variable definitions.
Redefined in l1-utils.
Redefined in encapsulate
Redefined in encapsulate - used in l1-io
    element is a code vector which causes an "undefined function"
    which signals a "can't apply macro or special form" error when
    are.  Once that's decided, it wouldn't hurt if %FHAVE
 FBOUNDP is true of any symbol whose function-cell contains something other
 than %unbound-function%; we expect FBOUNDP to return that something.
 Who does ?
 no name-cell in function vector.
 magically set by xloader.
 A definition-environment isn't a lexical environment, but it can
 Not found in env, look in function cell.
 This function is magic, and it can only be called from
 an unwind-protect cleanup form (making it even more magic.)
 If we can tell that we reached the unwind-protect via THROW,
 return a list of the target catch tag and all values being
 thrown.
 when we enter and unwind-protect cleanup on x8664, the
 top frame on the tstack contains state information that's
 form.  That state information contains a count of the number
 of catch/unwind-protect frames still to be processed (non-zero
 only in the case where we're actually throwing), the value(s)
 being thrown, and a return address that isn't interesting to
 us.  It's an historical accident that that information is stored
 differently in the cases where a single value is being thrown
 and multiple values are thrown.
 words are a backpointer to the previous tstack frame and a
 pointer into the main lisp stack.  In the single value case,

 return address, frame count) with the values following the
 A cleanup form is always called from either .SPnthrowvalues
 will have no function associated with it) or by Lisp code
 (in which case it will.)
 We (have to) just assume that the frame on top of the temp
 function may violate this assumption and cause misbehavior
 here.
 end of l0-def.lisp
  Copyright 1994 - 2009 Clozure Associates
  distributed under the License is distributed on an " AS IS " BASIS ,

(in-package "CCL")






(defun functionp (arg)
  "Return true if OBJECT is a FUNCTION, and NIL otherwise."
  (functionp arg))

(defun lfunp (arg)
  (functionp arg))

(defun %proclaim-special (sym &optional initp)
  (let* ((oldbits (%symbol-bits sym)))
    (declare (fixnum oldbits))
    (%symbol-bits sym (bitset $sym_vbit_special oldbits))
    initp))

(setq *lfun-names* (make-hash-table :test 'eq :weak t))

(defun lookup-lfun-name (lfun) 
  (gethash lfun *lfun-names*))


(defun function-name (fun)
  (or (and (functionp fun) (lfun-name fun))
      (if (compiled-function-p (setq fun (closure-function fun)))
        (lfun-name fun))))


(defun bootstrapping-fmakunbound (name)
  (when (consp name)
    (unless (eq (%car name) 'setf)
      (error "Function spec handler not loaded yet"))
    (setq name (setf-function-name (cadr name))))
  (%unfhave name)
  name)

  redefined in sysutils .
(%fhave 'fmakunbound #'bootstrapping-fmakunbound)

(defun bootstrapping-fset (name fn)
  (fmakunbound name)
  (%fhave name fn)
  fn)

Redefined in sysutils .
(%fhave 'fset #'bootstrapping-fset)

(defun fset-symbol (name fn)
  (fset (require-type name 'symbol) fn))


(defun bootstrapping-record-source-file (fn &optional type)
  (declare (ignore fn type))
  nil)

(%fhave 'record-source-file #'bootstrapping-record-source-file)


(setq *fasload-print* nil)
(setq *save-doc-strings* t)



        (qlfun bootstrapping-defun-encapsulated (name fn)
          (declare (ignore name fn))
          nil))

        (qlfun bootstrapping-encapsulated-function-name (fn)
          (declare (ignore fn))
          nil))

(%fhave 'set-function-info (qlfun set-function-info  (name info)
                                  (if (typep info 'string)
                                    (set-documentation name 'function info))
                                  name))

(defun %defun (named-fn &optional info)
  (unless (typep named-fn 'function)
    (dbg named-fn))
  (let* ((name (function-name named-fn)))
    (unless (and name
                 (or (symbolp name)
                     (setf-function-name-p name)))
      (dbg named-fn))
  (record-source-file name 'function)
  (when (not (%defun-encapsulated-maybe name named-fn))
    (when (and (symbolp name) (macro-function name nil))
      (warn "The macro ~s is being redefined as a function." name)
      (fmakunbound name))
    (fset name named-fn))
  (set-function-info name info)
  (when *fasload-print* (format t "~&~S~%" name))
  name))

(defun validate-function-name (name)
  (if (symbolp name)
    name
    (if (setf-function-name-p name)
      (setf-function-name (cadr name))
      (report-bad-arg name 'function-name))))

     There are three kinds of things which can go in the function
     cell of a symbol : 1 ) A function .   2 ) The thing which is the
     value of % unbound - function% : a 1 - element vector whose 0th
     error to be signalled .   3 ) A macro or special - form definition ,
     which is a 2 - element vector whose 0th element is a code vector
     executed and whose 1st element is a macro or special - operator
     name .   It does n't matter what type of gvector cases 2 and 3
     typechecked its second arg .

(defun %fhave (name def)
  (let* ((fname (validate-function-name name)))
    (setf (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell) def)))

(defun fboundp (name)
  "Return true if name has a global function definition."
  (let* ((fname (validate-function-name name))
         (def (%svref (symptr->symvector (%symbol->symptr fname)) target::symbol.fcell-cell)))
    (unless (eq def %unbound-function%)
      def)))

  % UNFHAVE does n't seem to want to deal with SETF names or function specs .

(defun %unfhave (sym)
  (let* ((symvec (symptr->symvector (%symbol->symptr sym)))
         (old (%svref symvec target::symbol.fcell-cell))
         (unbound %unbound-function%))
    (setf (%svref symvec target::symbol.fcell-cell) unbound)
    (not (eq old unbound))))

  It 's guaranteed that lfun - bits is a fixnum .   Might be a 30 - bit fixnum ...





(defun lfun-vector-name (fun &optional (new-name nil set-name-p))
  (let* ((bits (lfun-bits fun)))
    (declare (fixnum bits))
    (if (and (logbitp $lfbits-gfn-bit bits)
	     (not (logbitp $lfbits-method-bit bits)))
      (progn
        (if set-name-p
          (%gf-name fun new-name)
          (%gf-name fun)))
      (let* ((has-name-cell (not (logbitp $lfbits-noname-bit bits))))
	(if has-name-cell
	  (let* ((lfv (lfun-vector fun))
                 (name-idx (- (the fixnum (uvsize lfv)) 2))
		 (old-name (%svref lfv name-idx)))
	    (declare (fixnum name-idx))
	    (if (and set-name-p (not (eq old-name new-name)))
	      (setf (%svref lfv name-idx) new-name))
	    old-name))))))

(defun lfun-name (fun &optional (new-name nil set-name-p))
  (multiple-value-bind (stored-name stored?) (lookup-lfun-name fun)
    (unless stored?
      (setq stored-name (lfun-vector-name fun)))
    (when (and set-name-p (neq new-name stored-name))
      (if (and stored? (eq new-name (lfun-vector-name fun)))
        (remhash fun *lfun-names*)
          (puthash fun *lfun-names* new-name)
          (lfun-vector-name fun new-name))))
    stored-name))

(defun lfun-bits (function &optional new)
  (unless (functionp function)
    (setq function (require-type function 'function)))
  (let* ((lfv (lfun-vector function))
         (idx (1- (the fixnum (uvsize lfv))))
         (old (%svref lfv idx)))
    (declare (fixnum idx))
    (if new
      (setf (%svref lfv idx) new))
    old))
    
(defun %macro-have (symbol macro-function)
  (%fhave symbol
          #-arm-target (vector %macro-code% macro-function)
          #+arm-target (%fix-fn-entrypoint (gvector :pseudofunction 0 %macro-code% macro-function))))


(defun special-operator-p (symbol)
  "If the symbol globally names a special form, return T, otherwise NIL."
  (let ((def (fboundp symbol)))
    (and #-arm-target (typep def 'simple-vector)
         #+arm-target (= (typecode def) arm::subtag-pseudofunction)
         (not (lfunp #-arm-target (svref def 1)
                     #+arm-target (uvref def 2))))))

(defun special-form-p (x) (special-operator-p x))

(defun setf-function-name-p (thing)
  (and (consp thing)
       (consp (%cdr thing))
       (null (%cddr thing))
       (eq (%car thing) 'setf)
       (symbolp (%cadr thing))))

(defun macro-function (form &optional env)
  "If SYMBOL names a macro in ENV, returns the expansion function,
   else returns NIL. If ENV is unspecified or NIL, use the global
   environment only."
  (setq form (require-type form 'symbol))
  (when env
  be an ancestor of one .
    (unless (istruct-typep env 'lexical-environment)
        (report-bad-arg env 'lexical-environment))
      (let ((cell nil))
        (tagbody
          top
          (if (setq cell (%cdr (assq form (lexenv.functions env))))
            (return-from macro-function 
              (if (eq (car cell) 'macro) (%cdr cell))))
          (unless (listp (setq env (lexenv.parent-env env)))
            (go top)))))
  (%global-macro-function form))

(defun %fixnum-ref-macptr (fixnum &optional (offset 0))
  (%int-to-ptr (%fixnum-ref-natural fixnum offset)))

(defun %fixnum-set-macptr (fixnum offset &optional (newval offset newval-p))
  (%fixnum-set-natural fixnum (if newval-p offset 0) (%ptr-to-int newval))
  newval)

(defun nth-catch-frame-tag (n)
  (declare (fixnum n))
  (let* ((frame (%catch-top (%current-tcr))))
    (dotimes (i n (%svref frame target::catch-frame.catch-tag-cell))
      (setq frame (%svref frame target::catch-frame.link-cell)))))

#+x86-target
(defun %throwing-through-cleanup-p ()
  used both by THROW and by normal exit from the protected
  A tstack frame is always doubleword aligned , and the first two
  in the multiple - value we have 3 fixed words ( value count ,
  frame count ( value 0 follows immediately . )
  of .SPnthrow1value , and those subprims can be called either
  by .SPthrow ( in which case the return address in the frame
  stack is context info for the nthrow stuff .   Tracing this
  (let* ((frame (%current-tsp))
         (single-value-case (not (typep (%lisp-word-ref frame 2) 'fixnum)))
         (frame-count (%lisp-word-ref frame (if single-value-case 3 4)))
         (throwing (null (%return-address-function (if single-value-case
                                                     (%lisp-word-ref frame 2)
                                                     (%lisp-word-ref frame 3))))))
    (declare (fixnum frame))
    (if throwing
      (collect ((info))
        (info (nth-catch-frame-tag frame-count))
        (if single-value-case
          (info (%lisp-word-ref frame 4))
          (let* ((valptr (+ frame 5)))
            (declare (fixnum valptr))
            (dotimes (i (%lisp-word-ref frame 2))
              (declare (fixnum i))
              (info (%lisp-word-ref valptr i)))))
        (info)))))

