;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox PARC
;;;   3333 Coyote Hill Rd.
;;;   Palo Alto, CA 94304
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;
;;; The version of low for CLISP.

(in-package 'pcl)

(defun printing-random-thing-internal (thing stream)
  (format stream "#x~8,'0X" (sys::address-of thing))
)

(defconstant *slot-unbound* '..slot-unbound..)

(defsetf sys::%record-ref sys::%record-store)

(defun function-arglist (function)
  (if (sys::closurep function)
    (let ((h (sys::%record-ref function 1))) ; lambdabody or code-vector
      (if (consp h)
        (car h) ; lambda list
        nil ; unknown
    ) )
    nil ; unknown
) )

(defun function-pretty-arglist (function)
  (function-arglist function)
)

(defsetf function-pretty-arglist set-function-pretty-arglist)

(defun set-function-pretty-arglist (function new-value)
  (if (sys::closurep function)
    (let ((h (sys::%record-ref function 1))) ; lambdabody or code-vector
      (if (consp h)
        (setf (car h) new-value) ; replace lambda list
    ) )
  )
  new-value
)

(defun set-function-name-1 (function new-name uninterned-name)
  (declare (ignore uninterned-name))
  (if (sys::closurep function)
    (setf (sys::%record-ref function 0) new-name)
  )
  function
)

(defconstant *compiler-present-p* (if (member 'COMPILER *features*) t nil))

(defvar *compiler-speed* :SLOW)

(defvar *compiler-reentrant-p* t)

(defun in-the-compiler-p () sys::*compiling*)

(defun compile-lambda-uncompiled (uncompiled)
  (eval `(function ,uncompiled))
)

(defmacro define-compiler-macro (name lambdalist &body body)
  (let ((handler (gensym))
        (dummyname (gensym)))
    `(EVAL-WHEN (COMPILE)
       (DEFMACRO ,dummyname ,lambdalist ,@body)
       (DEFUN ,handler ()
         (COMPILER::C-FORM (CONS ',dummyname (CDR COMPILER::*FORM*)))
       )
       (SETF (GETHASH ',name COMPILER::C-FORM-TABLE) ',handler)
     )
) )

;; Low level functions for structures

(defun structure-functions-exist-p () t)

(defun declare-structure (name included-name slot-description-list)
  (declare (ignore slot-description-list))
  (let ((included-descr (get included-name 'SYSTEM::DEFSTRUCT-DESCRIPTION)))
    (setf (get name 'SYS::DEFSTRUCT-DESCRIPTION)
          (vector (cons name (if included-descr (svref included-descr 0) '()))
                  'T
                  NIL
                  (if included-descr (copy-list (svref included-descr 3)) '())
) ) )     )

; Functions on arbitrary objects

(defun structurep (x)
  (let ((type (type-of x)))
    (and (symbolp type) (get type 'SYSTEM::DEFSTRUCT-DESCRIPTION)
         (SYSTEM::%STRUCTURE-TYPE-P type x)
) ) )

(defun structure-type (x)
  (type-of x)
)

(defun structure-instance-p (x)
  (let ((type (type-of x)))
    (and (symbolp type) (get type 'SYSTEM::DEFSTRUCT-DESCRIPTION)
         (not (eq type 'std-instance)) (SYSTEM::%STRUCTURE-TYPE-P type x)
) ) )

; Functions on symbols naming structures

(defun structure-type-p (type)
  (and (symbolp type) (get type 'SYSTEM::DEFSTRUCT-DESCRIPTION))
)

(defun structure-type-included-type-name (type)
  (and (symbolp type)
       (let ((descr (get type 'SYSTEM::DEFSTRUCT-DESCRIPTION)))
         (and descr
              (let ((names (svref descr 0)))
                (and (consp names) (assert (eq type (car names)))
                     (setq names (cdr names))
                     (if (consp names) (car names) names)
) )    ) )    ) )

(defun structure-type-whole-slot-description-list (type)
  (and (symbolp type)
       (let ((descr (get type 'SYSTEM::DEFSTRUCT-DESCRIPTION)))
         (and descr
              (svref descr 3)
) )    ) )

(defun structure-type-slot-description-list (type)
  (let ((incl-type (structure-type-included-type-name type)))
    (copy-list
      (nthcdr (length (and incl-type (structure-type-whole-slot-description-list incl-type)))
              (structure-type-whole-slot-description-list type)
) ) ) )

; Functions on slot-descriptions (returned by the function above)

(defun structure-slotd-name (structure-slot-description)
  (first structure-slot-description)
)

(defun structure-slotd-accessor-symbol (structure-slot-description)
  (let ((index (second structure-slot-description)))
    (let ((sym (intern (concatenate 'string "RECORD-ACCESSOR-"
                                            (SYSTEM::DECIMAL-STRING index)
                       )
                       "PCL"
         ))    )
      (unless (fboundp sym)
        (eval `(DEFUN ,sym (OBJECT) (DECLARE (COMPILE)) (SYSTEM::%RECORD-REF OBJECT ,index)))
        (eval `(DEFSETF ,sym (OBJECT) (NEW-VALUE) (DECLARE (COMPILE)) `(SYSTEM::%RECORD-STORE ,OBJECT ,',index ,NEW-VALUE)))
      )
      sym
) ) )

(defun structure-slotd-reader-function (structure-slot-description)
  (let ((index (second structure-slot-description)))
    (let ((sym (intern (concatenate 'string "RECORD-READER-"
                                            (SYSTEM::DECIMAL-STRING index)
                       )
                       "PCL"
         ))    )
      (unless (fboundp sym)
        (eval `(DEFUN ,sym (OBJECT) (DECLARE (COMPILE)) (SYSTEM::%RECORD-REF OBJECT ,index)))
      )
      sym
) ) )

(defun structure-slotd-writer-function (structure-slot-description)
  (unless (fifth structure-slot-description)
    (let ((index (second structure-slot-description)))
      (let ((sym (intern (concatenate 'string "RECORD-WRITER-"
                                              (SYSTEM::DECIMAL-STRING index)
                         )
                         "PCL"
           ))    )
        (unless (fboundp sym)
          (eval `(DEFUN ,sym (NEW-VALUE OBJECT) (DECLARE (COMPILE)) (SYSTEM::%RECORD-STORE OBJECT ,index NEW-VALUE)))
        )
        sym
) ) ) )

(defun structure-slotd-type (structure-slot-description)
  (fourth structure-slot-description)
)

(defun structure-slotd-init-form (structure-slot-description)
  (third structure-slot-description)
)

