1;-*- *cold-load:t; 1Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10; Fonts:(CPTFONT CPTFONTB) -*-

;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1986-1989 Texas Instruments Incorporated.  All rights reserved.*

;1; printer definitions*


(Defvar *PRINT-LEVEL* nil
        1"If non-NIL, maximum depth for printing list structure.
Any structure nested more deeply that this amount
is replaced by \"**\"."*) 
(Defvar ZLC:PRINLEVEL nil)1   ;; old name for *print-level**
(forward-value-cell 'zlc:prinlevel '*print-level*) 


(Defvar *PRINT-LENGTH* ()
        1"If non-NIL, maximum length of list to print.
Any elements past that many are replaced by \"...\"."*) 
(Defvar ZLC:PRINLENGTH ())  ;1; old name for *print-length**
(forward-value-cell 'zlc:prinlength '*print-length*) 


(Defvar *PRINT-BASE* :unbound 1"Radix for output of integers and rational numbers."*) 
(Defvar ZLC:BASE :unbound)  ;1; old name for *print-base**
(forward-value-cell 'zlc:base '*print-base*) 


(Defvar *NOPOINT :unbound 1"Non-NIL means do not print a period after decimal fixnums."*) 


(Defvar *PRINT-RADIX* () 1"Non-NIL means print a radix specifier when printing an integer."*) 


(Defvar *PRINT-ESCAPE* t
        1"Non-NIL means print readably (PRIN1).  NIL means print with no quoting chars (PRINC)."*) 


(Defvar *PRINT-CIRCLE* ()
        1"Non-NIL means try to represent circular structure with #n# and #n= labels when printing."*) 

(Defvar *PRINT-CASE* :upcase
        1"Controls case used for printing uppercase letters in symbol pnames.
Value is :UPCASE, :DOWNCASE or :CAPITALIZE."*) 

(Defvar *PRINT-PRETTY* () 1"Non-NIL means print objects with extra whitespace for clarity."*)

(Defvar *PRINT-GENSYM* t 1"Non-NIL means print #: before a gensym symbol."*) 

(Defvar *PRINT-STRUCTURE* T
        1"Non-NIL means print *structures 1so they can be read back in.  NIL means use #< syntax."*)

(Defvar *PRINT-ARRAY* ()
        1"Non-NIL means print arrays so they can be read back in.  NIL means use #< syntax."*) 

(Defvar *PRINT-BASE-SUBSCRIPT* ()
        1"If non-NIL and not printing readably, a subscript is printed (in decimal)
after a FIXNUM or BIGNUM being printed in a base other than *PRINT-BASE*."*) 

(Defvar PRINT-READABLY ()
        1"Non-NIL means signal SYS:PRINT-NOT-READABLE if attempt is made to print
some object whose printed representation cannot be read back in."*) 


;1;; stream definitions


; The initial environment.
;   The initial binding of streams (set up by LISP-REINITIALIZE) is
;      as follows:
;   *TERMINAL-IO*     - This is how to get directly to the user's terminal.  It is set
;                     up to go to the TV initially.  Other places it might go are to
;                     the SUPDUP server, etc.  It is initially bound to a TV-MAKE-STREAM
;                     of CONSOLE-IO-PC-PPR.
;   *STANDARD-INPUT*  - This is initially bound to SYN to TERMINAL-IO.
;   *STANDARD-OUTPUT* - This is initially bound to SYN to TERMINAL-IO. *STANDARD-INPUT*
;                     and *STANDARD-OUTPUT* are the default streams for READ, PRINT and
;                     other things.  *STANDARD-OUTPUT* gets hacked when the session is
;                     being scripted, for example.
;   *ERROR-OUTPUT*    - This is where error messages should eventually get sent. Initially
;                     SYNned to TERMINAL-IO.
;   *QUERY-IO*        - This is for unexpected user queries
;                     of the "Do you really want to ..." variety.  Initially SYNned to
;                     TERMINAL-IO.  It supersedes "QUERY-INPUT".
;   *TRACE-OUTPUT*    - Output produced by TRACE goes here.  Initially SYNned to *ERROR-OUTPUT*.*

(Defvar *TERMINAL-IO* :unbound
   1"Stream to use for \"terminal\" I/O.  Normally the selected window.
*STANDARD-INPUT* and other default streams are usually set up
as synonym streams which will use the value of TERMINAL-IO."*)
(Defvar ZLC:TERMINAL-IO :unbound) ;1; old name*
(forward-value-cell 'zlc:terminal-io '*terminal-io*)


(Defvar *STANDARD-INPUT* :unbound 1"Default stream for input functions such as READ."*)
(Defvar ZLC:STANDARD-INPUT :unbound ) ;1; old name*
(forward-value-cell 'zlc:standard-input '*standard-input*)


(Defvar *STANDARD-OUTPUT* :unbound
  "2Default output stream for PRINT and TYO and many other functions.
Normally it is a synonym stream pointing at *TERMINAL-IO**")
(Defvar ZLC:STANDARD-OUTPUT :unbound)  ;1; old name*
(forward-value-cell 'zlc:standard-output '*standard-output*)


(Defvar *ERROR-OUTPUT* :unbound
   1"Stream to use for unanticipated noninteractive output, such as warnings."*)
(Defvar ZLC:ERROR-OUTPUT :unbound) ;1; old name*
(forward-value-cell 'zlc:error-output '*error-output*)


(Defvar *QUERY-IO* :unbound
   1"Stream to use for unanticipated questions, and related prompting, echoing, etc."*) 
(Defvar QUERY-IO :unbound) ;1; old name*
(forward-value-cell 'query-io '*query-io*)



;1;; reader definitions*

(Defvar *READTABLE* :unbound
  1"Syntax table which controls operation of READ (and also PRINT, in limited ways)."*)
(Defvar zlc:READTABLE :unbound)  ;1; old name*
(forward-value-cell 'zlc:readtable '*readtable*)


(Defvar *READ-BASE* :unbound  1"Default radix for reading integers."*)
(Defvar ZLC:IBASE :unbound)
(forward-value-cell 'zlc:ibase '*read-base*)


;;checked by the reader everytime we have to grow the input buffer.
;;used to limit the number of characters read when there is a stray | in the file.
(defvar *MAXIMUM-READ-BUFFER-SIZE* nil)


(DEFPROP COMMON-LISP-READTABLE (VARIABLE "The readtable used when in Common Lisp Mode.") DOCUMENTATION-PROPERTY)

(DEFPROP COMMON-LISP-READTABLE T SPECIAL)

(DEFPROP STANDARD-READTABLE (VARIABLE "The readtable used when in Zetalisp Mode.") DOCUMENTATION-PROPERTY)

(DEFPROP STANDARD-READTABLE T SPECIAL)

(DEFVAR INITIAL-READTABLE :UNBOUND
  1"A readtable defining the standard Zetalisp syntax.
This is a copy of the readtable that was current when the system was built.
It does not contain any changes you have made to the default readtable."*)

(DEFVAR INITIAL-COMMON-LISP-READTABLE :UNBOUND
  1"A readtable defining the standard Common Lisp syntax.
This is a copy of the readtable that defined when the system was built.
It does not contain any changes you have made to COMMON-LISP-READTABLE."*)

(DEFVAR *READER-SYMBOL-SUBSTITUTIONS* NIL
  1"Alist of substitutions to make in symbols read."*)

(DEFPARAMETER *COMMON-LISP-SYMBOL-SUBSTITUTIONS* nil
  1"Alist used as *READER-SYMBOL-SUBSTITUTIONS* for reading Common Lisp code."*)

;;PAD 4/2/87 Remove substitution of decode-float.
;;They should be identical for release3.[SPR 4506] (CR:PHD).
(DEFPARAMETER *ZETALISP-SYMBOL-SUBSTITUTIONS*
	  '((LISP:/ . ZLC:/) 
	    (LISP:*DEFAULT-PATHNAME-DEFAULTS* . ZLC:*DEFAULT-PATHNAME-DEFAULTS*)
	    (LISP:APPLYHOOK . ZLC:APPLYHOOK)	; jlm 4/24/89
	    (ticl:AR-1 . ZLC:AR-1)
	    (ticl:AR-1-FORCE . ZLC:AR-1-FORCE)
	    (LISP:AREF . ZLC:AREF)
	    (LISP:ASSOC . ZLC:ASSOC)
	    (LISP:ATAN . ZLC:ATAN)
	    (LISP:CHARACTER . ZLC:CHARACTER)
	    (LISP:CLOSE . ZLC:CLOSE)
;	    (LISP:DECODE-FLOAT . ZLC:DECODE-FLOAT)
	    (LISP:DEFSTRUCT . ZLC:DEFSTRUCT)
	    (LISP:DELETE . ZLC:DELETE)
	    (LISP:EVAL . ZLC:EVAL)
	    (LISP:EVALHOOK . ZLC:EVALHOOK)	; jlm 4/24/89
	    (LISP:EVERY . ZLC:EVERY)
	    (LISP:FLOAT . ZLC:FLOAT)
	    (LISP:FORMAT . ZLC:FORMAT)
	    (LISP:INTERSECTION . ZLC:INTERSECTION)
	    (LISP:LAMBDA . ZLC:LAMBDA)
	    (LISP:LISTP . ZLC:LISTP)
	    (LISP:MAKE-HASH-TABLE . ZLC:MAKE-HASH-TABLE)
	    (LISP:MAP . ZLC:MAP)
	    (LISP:MEMBER . ZLC:MEMBER)
	    (ticl:NAMED-LAMBDA . ZLC:NAMED-LAMBDA)
	    (ticl:NAMED-SUBST . ZLC:NAMED-SUBST)
	    (LISP:NINTERSECTION . ZLC:NINTERSECTION)
	    (ticl:NLISTP . ZLC:NLISTP)
	    (LISP:NUNION . ZLC:NUNION)
	    (LISP:PACKAGE . ZLC:PACKAGE)	; jlm 4/24/89
	    (LISP:RASSOC . ZLC:RASSOC)
	    (LISP:READ . ZLC:READ)
	    (LISP:READ-FROM-STRING . ZLC:READ-FROM-STRING)
	    (LISP:READTABLE . ZLC:READTABLE)	; jlm 4/24/89
	    (LISP:REM . ZLC:REM)
	    (LISP:REMOVE . ZLC:REMOVE)
	    (LISP:SOME . ZLC:SOME)
            (LISP:STRING . ZLC:STRING)
;;;	    (LISP:STRING= . ZLC:STRING=)
;;;	    (LISP:STRING-EQUAL . ZLC:STRING-EQUAL)
	    (LISP:SUBST . ZLC:SUBST)
	    (LISP:TERPRI . ZLC:TERPRI)
	    (LISP:UNION . ZLC:UNION)
)
  1"Alist used as *READER-SYMBOL-SUBSTITUTIONS* for reading Zetalisp code."*)


;1;; Package definitions*


(Defvar *PACKAGE* :unbound
1  "The current package, the default for most package operations including INTERN.")*
(Defvar ZLC:PACKAGE :unbound)
(forward-value-cell 'zlc:package '*package*)

(Defvar *KEYWORD-PACKAGE* NIL 1"The keyword package"*)
(Defvar PKG-KEYWORD-PACKAGE NIL)  ;1 old name*
(forward-value-cell 'pkg-keyword-package '*keyword-package*)

(Defvar *USER-PACKAGE* nil 1"The default package for user code"*)
(Defvar PKG-USER-PACKAGE NIL)   ;1 old name*
(forward-value-cell 'pkg-user-package '*user-package*)

(Defvar *COMMON-LISP-USER-PACKAGE* nil 1"The default package for common-lisp* 1user code"*)

(Defvar *GLOBAL-PACKAGE* NIL 1"The Zetalisp-Global package"*)
(Defvar PKG-GLOBAL-PACKAGE NIL)1  ; old name*
(forward-value-cell 'pkg-global-package '*global-package*)

(Defvar *LISP-PACKAGE* NIL2 1"The standard Common Lisp package"**)
(Defvar PKG-LISP-PACKAGE NIL)  ;1 old name*
(forward-value-cell 'pkg-lisp-package '*lisp-package*)

(Defvar *COMMON-LISP-PACKAGE* NIL 1"The True* 1Common Lisp package"*)

(Defvar *TICL-PACKAGE* NIL 1"The TI-extended Common Lisp package"*)

(Defvar *ZLC-PACKAGE* NIL 1"The Zetalisp-Compatibility package"*)

(Defvar *SYSTEM-PACKAGE* NIL 1"The System package"*)
(Defvar PKG-SYSTEM-PACKAGE NIL)1 ; old name*
(forward-value-cell 'pkg-system-package '*system-package*)

(Defvar PKG-SYSTEM-INTERNALS-PACKAGE NIL 1"The System-Internals package (now a nickname for the System package)"*)
(forward-value-cell 'pkg-system-internals-package '*system-package*)

;Any property name which is in the Compiler package
;is assumed to be related to the function definition
;of the symbol that has the property.
(DEFVAR PKG-COMPILER-PACKAGE NIL
  "The Compiler package.")

(Defconstant *PACKAGE-HASH-TABLE-SIZE* 127)

(Defvar *PACKAGE-HASH-TABLE* :UNBOUND)

;;; evaluator

(DEFCONSTANT LAMBDA-PARAMETERS-LIMIT 64.  ;;; (1- (ash 1 (byte-size sys:%%call-info-number-of-arguments)))
1  "the limit of the number of formal variables which can appear in an argument list")*

(DEFCONSTANT CALL-ARGUMENTS-LIMIT 64. ;;; (1- (ash 1 (byte-size sys:%%call-info-number-of-arguments)))
1  "the limit of the number of arguments which may be passed to a function")*

(DEFCONSTANT MULTIPLE-VALUES-LIMIT 64. ;;; (1- (ash 1 (byte-size sys:%%call-info-number-of-results)))
1  "the limit of the number of values which can be returned from a function")*

;;; characters

(Defconstant CHAR-CODE-LIMIT 256.
  1"Character code values must be less than this."*)

(Defconstant CHAR-FONT-LIMIT 256.
  1"Font codes in characters must be less than this."*)

;;PAD 2/6/87  Updated value of char-bits-limit.
(Defconstant CHAR-BITS-LIMIT 64.
  1"All the special bits in a character must be less than this.
They are Control, Meta, Super*,1 Hyper*, 1Mouse, and Keypad.")*

(Defconstant CHAR-CONTROL-BIT 1
  1"The weight of the Control bit in a character's bits."*)

(Defconstant CHAR-META-BIT 2
  1"The weight of the Meta bit in a character's bits."*)

(Defconstant CHAR-SUPER-BIT 4
  1"The weight of the Super bit in a character's bits."*)

(Defconstant CHAR-HYPER-BIT 8.
  1"The weight of the Hyper bit in a character's bits."*)

;; AB 6/24/87.  Added next 2 and changed doc strings. [SPR 5108 5110]
(Defconstant CHAR-MOUSE-BIT 16.
  1"The weight of the Mouse bit in a character's bits."*)

(Defconstant CHAR-KEYPAD-BIT 32.
  1"The weight of the Keypad bit in a character's bits."*)


;;; FQUERY AND PALS

(Defvar Y-OR-N-P-CHOICES '(((t "Yes.") #\Y #\T #\SPACE #\) ((nil "No.") #\N #\RUBOUT #\
))) 
(Defvar FORMAT:Y-OR-N-P-CHOICES nil)
(forward-value-cell 'FORMAT:Y-OR-N-P-CHOICES 'Y-OR-N-P-CHOICES)

(Defvar YES-OR-NO-P-CHOICES '((t "Yes") (nil "No")))
(Defvar FORMAT:YES-OR-NO-P-CHOICES nil)
(forward-value-cell 'FORMAT:YES-OR-NO-P-CHOICES 'YES-OR-NO-P-CHOICES)

(Defvar YES-OR-NO-QUIETLY-P-OPTIONS '(:TYPE :READLINE :CHOICES ((T "Yes") (NIL "No"))))
(Defvar FORMAT:YES-OR-NO-QUIETLY-P-OPTIONS NIL)
(forward-value-cell 'FORMAT:YES-OR-NO-QUIETLY-P-OPTIONS 'YES-OR-NO-QUIETLY-P-OPTIONS)

(Defparameter Y-OR-N-P-OPTIONS `(:FRESH-LINE NIL))
(Defvar FORMAT:Y-OR-N-P-OPTIONS NIL)
(Forward-Value-Cell 'FORMAT:Y-OR-N-P-OPTIONS 'Y-OR-N-P-OPTIONS)

(Defparameter YES-OR-NO-P-OPTIONS `(:FRESH-LINE NIL
				:BEEP T
				:TYPE :READLINE
				:CHOICES ,YES-OR-NO-P-CHOICES))

(Defvar FORMAT:YES-OR-NO-P-OPTIONS nil)
(forward-value-cell 'FORMAT:YES-OR-NO-P-OPTIONS 'YES-OR-NO-P-OPTIONS)

;; pathnames

(defvar *default-pathname-defaults* nil)
(forward-value-cell 'global:*default-pathname-defaults* '*default-pathname-defaults*)

;; arrays

(DEFCONSTANT array-total-size-limit (1- (%LOGDPB 0 %%q-boxed-sign-bit -1))  ;; equivalent to most-positive-fixnum -1
  1"The total number of elements in any array must be less than this."*)
  
(DEFCONSTANT array-dimension-limit (1- (%LOGDPB 0 %%q-boxed-sign-bit -1))   ;; equivalent to most-positive-fixnum -1

  1"Every dimension of an array must be less than this."*)

(DEFCONSTANT array-rank-limit 8.
  1"The rank of an array must be less than this."*)

(defvar art-float)				;for Release 2 compatibility
(defvar art-complex-float)
(defprop art-float t compiler::system-constant)
(defprop art-complex-float t compiler::system-constant)
(forward-value-cell 'art-float 'art-single-float)	
(forward-value-cell 'art-complex-float 'art-complex-single-float)