;;; -*- Mode:Common-Lisp; Package:System; Base:10; Patch-file:T -*-

;;; Reason: Add some new functions to the COMMON-LISP package that were recently adopted 
;;; for inclusion in ANSI Common Lisp.


;;;                           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, M/S 2151             
;;;   AUSTIN, TEXAS 78769                 
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Written 07/12/89 23:06:52 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With SYSTEM 6.11, VIRTUAL-MEMORY 6.1, EH 6.3, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0,
;;;  BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1, NETWORK-NAMESPACE 6.0,
;;;  DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0,
;;;  COMPILER 6.9, TV 6.12, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, MEMORY-AUX 6.0, NVRAM 6.1,
;;;  SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ZWEI 6.3,
;;;  DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, DATALINK-DISPLAYS 6.0,
;;;  FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.1,
;;;  IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.1, TELNET 6.0, VT100 6.0,
;;;  NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, Inconsistent TI-CLOS 6.17, CLEH 6.4,
;;;  IP 3.47, Experimental BUG 11.10, Experimental CLX 6.2, CLUE 6.9, X11M 6.1, Experimental DOCUMENTER 619.0,
;;;   microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8

#!C
; From file READER-MACROS.LISP#> KERNEL; MR-X:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; READER-MACROS.#"


(defun sharp-p (stream ignore ignore)
  ;; For ANSI Common Lisp, define the reader syntax #P"..." to be equivalent 
  ;; to #.(PARSE-NAMESTRING "...").
  ;;  7/11/89 DNG - Original.
  (parse-namestring (read-preserving-whitespace stream t nil t)))
))

#!C
; From file READTABLE-FUNCTIONS.LISP#> KERNEL; MR-X:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; READTABLE-FUNCTIONS.#"


(defun sharp-init (areadtable )
  (let ((*readtable* areadtable))
    (make-dispatch-macro-character #\# t)
    (set-dispatch-macro-character #\# #\\ 'sharp-backslash)
    (set-dispatch-macro-character #\# #\' 'sharp-quote)
    (set-dispatch-macro-character #\# #\( 'sharp-left-paren)
    (set-dispatch-macro-character #\# #\* 'sharp-star)
    (set-dispatch-macro-character #\# #\: 'sharp-colon)
    (set-dispatch-macro-character #\# #\. 'sharp-dot)
    (set-dispatch-macro-character #\# #\, 'sharp-comma)
    (set-dispatch-macro-character #\# #\R 'sharp-R)
    (set-dispatch-macro-character #\# #\r 'sharp-R)
    (set-dispatch-macro-character #\# #\B 'sharp-B)
    (set-dispatch-macro-character #\# #\b 'sharp-B)
    (set-dispatch-macro-character #\# #\O 'sharp-O)
    (set-dispatch-macro-character #\# #\o 'sharp-O)
    (set-dispatch-macro-character #\# #\X 'sharp-X)  
    (set-dispatch-macro-character #\# #\x 'sharp-X)
    (set-dispatch-macro-character #\# #\A 'sharp-A)    
    (set-dispatch-macro-character #\# #\a 'sharp-A)    
    (set-dispatch-macro-character #\# #\S 'sharp-S)    
    (set-dispatch-macro-character #\# #\s 'sharp-S)
    (set-dispatch-macro-character #\# #\P 'sharp-P) ; added 7/12/89 for ANSI CL -- DNG
    (set-dispatch-macro-character #\# #\= 'sharp-equal)    
    (set-dispatch-macro-character #\# #\# 'sharp-sharp)    
    (set-dispatch-macro-character #\# #\+ 'sharp-plus)    
    (set-dispatch-macro-character #\# #\- 'sharp-minus)    
    (set-dispatch-macro-character #\# #\C 'sharp-C)
    (set-dispatch-macro-character #\# #\c 'sharp-C)
    (set-dispatch-macro-character #\# #\| 'sharp-vertical-bar)
    (set-dispatch-macro-character #\# #\tab 'sharp-illegal)
    (set-dispatch-macro-character #\# #\  'sharp-illegal)
    (set-dispatch-macro-character #\# #\) 'sharp-illegal)
    (set-dispatch-macro-character #\# #\< 'sharp-illegal)
    (set-dispatch-macro-character #\# #\form 'sharp-illegal)
    (set-dispatch-macro-character #\# #\return 'sharp-illegal)
    (set-dispatch-macro-character #\# #\` 'sharp-backquote)
    (set-dispatch-macro-character #\# #\ 'xr-#-macro )
    (set-dispatch-macro-character #\# #\! 'xr-#!-macro )))
))

(set-dispatch-macro-character #\# #\P 'sharp-P COMMON-LISP-READTABLE) ; add to the existing read table

#!C
; From file ANSI.LISP#> KERNEL; MR-X:
#10R SYSTEM#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "SYSTEM"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* *COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: KERNEL; ANSI.#"



;; This file defines some new features adopted at the June 1989 meeting of X3J13.

;; These are collected in one file because they were a last-minute addition to 
;; release 6.0.  For release 7, these functions should be distributed to the 
;; files for the features they pertain to.

(export '( cl:WITH-STANDARD-IO-SYNTAX CL:*READ-EVAL* CL:*PRINT-READABLY*
	  cl:PRINT-UNREADABLE-OBJECT
	  cl:MAP-INTO
	  FS:LOGICAL-PATHNAME cl:TRANSLATE-LOGICAL-PATHNAME
	  cl:LOGICAL-PATHNAME-TRANSLATIONS cl:LOAD-LOGICAL-PATHNAME-TRANSLATIONS
	  cl:COMPILE-FILE-PATHNAME
	  cl:WILD-PATHNAME-P cl:PATHNAME-MATCH-P cl:TRANSLATE-PATHNAME
	  cl:INTERACTIVE-STREAM-P
	  cl:DECLAIM
	  cl:DECLARATION-INFORMATION cl:PARSE-MACRO cl:ENCLOSE
	  cl:FILE-STRING-LENGTH
	  cl:DEFINE-COMPILER-MACRO cl:COMPILER-MACRO-FUNCTION
	  ) 'cl)

;;; ----------------------
;;; from proposal DATA-IO
;;; ----------------------

(defvar CL:*PRINT-READABLY*)
(forward-value-cell 'CL:*PRINT-READABLY* 'PRINT-READABLY)
(setf (documentation 'CL:*PRINT-READABLY* 'variable)
      (documentation 'PRINT-READABLY 'variable))

(defvar CL:*READ-EVAL*) ; not yet checked by the reader

(defmacro cl:WITH-STANDARD-IO-SYNTAX (&body body)
  "Within the dynamic extent of the body, all reader and printer control
variables are bound to values that produce standard read/print
behavior.  Returns the values of the last body form."
  ;;  7/12/89 DNG - Original version.
  `(let (;; Standard variables:
	 (*PACKAGE*		*COMMON-LISP-USER-PACKAGE*)
	 (*PRINT-ARRAY*		T)
	 (*PRINT-BASE*		10.)
	 (*PRINT-CASE*		:UPCASE)
	 (*PRINT-CIRCLE*	NIL)
	 (*PRINT-ESCAPE*	T)
	 (*PRINT-GENSYM*	T)
	 (*PRINT-LENGTH*	NIL)
	 (*PRINT-LEVEL*		NIL)
	 (*PRINT-PRETTY*	NIL)
	 (*PRINT-RADIX*		NIL)
	 (CL:*PRINT-READABLY*	T)
	 (*READ-BASE*		10.)
	 (*READ-DEFAULT-FLOAT-FORMAT*	'SINGLE-FLOAT)
       ;;(CL:*READ-EVAL*	T)	; not yet supported
	 (*READ-SUPPRESS*	NIL)
	 (*READTABLE*		COMMON-LISP-READTABLE)
	 ;; Explorer additions:
	 (*PRINT-STRUCTURE*	t)
	 (*READER-SYMBOL-SUBSTITUTIONS*	*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)
	 )
     . ,body))

(defmacro cl:PRINT-UNREADABLE-OBJECT ((object stream &key type identity) &body body)
  "Output a printed representation of OBJECT on STREAM, beginning with \"#<\"
and ending with \">\".  Everything output to STREAM by the BODY forms is
enclosed in the angle brackets.  If :TYPE is true, the body output is preceded
by a brief description of the object's type and a space character.  If :IDENTITY
is true, the body output is followed by a space character and a representation
of the object's identity, typically a storage address.

The OBJECT, STREAM, :TYPE, and :IDENTITY arguments are all evaluated normally.
:TYPE and :IDENTITY default to false.  It is valid to omit the BODY forms."
  ;;  7/11/89 DNG - Original version.
  (let ((options '()))
    (unless identity (push ':no-pointer options))
    (when type (push ':typep options))
    (once-only (object stream)
      `(progn (printing-random-object (,object ,stream . ,options)
		. ,body)
	      nil))))

;;; ----------------------
;;; proposal MAP-INTO
;;; ----------------------

(defun cl:MAP-INTO (result-sequence function &rest sequences)
  "Destructively modifies the RESULT-SEQUENCE to contain the results of applying
FUNCTION to each element in the argument SEQUENCES in turn.  Returns
RESULT-SEQUENCE.  The iteration terminates when the shortest sequence is
exhausted.  If RESULT-SEQUENCE is a vector with a fill-pointer, the fill-pointer
is ignored when deciding how many iterations to perform, and afterwards the
fill-pointer is set to the number of times function was applied."
  ;;  7/11/89 DNG - Original version.
  (LET ((number-of-args (LENGTH sequences))
	(result-length (min (loop for seq in sequences minimize (length seq))
			    (if (vectorp result-sequence)
				(array-total-size result-sequence)
			      (length result-sequence)))))
    (%ASSURE-PDL-ROOM (+ number-of-args 4))	; make sure %PUSH's don't lose
    (IF (LISTP result-sequence)
	;; if <result-sequence> is a list, then CDR-down <result-sequence> 
	;; replacing the i-th element with the result of applying <function> to the 
	;; i-th element of each sequence
	(DO ((res result-sequence (CDR res))
	     (index 0 (1+ index)))		; use <index> to traverse any sequences which are arrays
	    ((>= index result-length))
	  (SETF (CAR res)
		(DO ((seqlist sequences (CDR seqlist)))   ;; push the i-th element of each sequence onto the stack
		    ((NULL seqlist) (%CALL function number-of-args))   ;; when done, call the function.
		  (%PUSH (IF (ARRAYP (CAR seqlist))
			     (AREF (CAR seqlist) index)
			   (POP (CAR seqlist)))))))
      ;; else <result-sequence> is an array of some sort.
      (progn (DOTIMES (index result-length)   
	       (SETF (AREF result-sequence index)
		     (DO ((seqlist sequences (CDR seqlist)))
			 ((NULL seqlist) (%CALL function number-of-args))
		       (%PUSH (IF (ARRAYP (CAR seqlist))
				  (AREF (CAR seqlist) index)
				(POP (CAR seqlist)))))))
	     (when (array-has-fill-pointer-p result-sequence)
	       (setf (fill-pointer result-sequence) result-length))))
    result-sequence))




;;; ----------------------
;;; proposal PATHNAME-LOGICAL
;;; ----------------------

(defun cl:LOGICAL-PATHNAME (pathname)
  "Converts the argument to a logical pathname and returns it.
The argument can be a logical pathname, a logical pathname namestring containing
a host component, or a stream for which the PATHNAME function returns a logical
pathname.  For any other argument, a TYPE-ERROR is signalled."
  ;;  7/11/89 DNG - Original.
  (let ((pathname (pathname pathname)))
    (unless (typep pathname 'cl:logical-pathname)
      (cl:error 'cl:type-error :datum pathname :expected-type 'cl:logical-pathname
		;; The following arguments are a work-around for SPR 10080.
		:FORMAT-STRING "~S is not a logical pathname."
		:FORMAT-ARGS (LIST pathname)))
    pathname))

(deff cl:TRANSLATE-LOGICAL-PATHNAME #'FS:TRANSLATED-PATHNAME)

;; Not yet supported: LOGICAL-PATHNAME-TRANSLATIONS

(defun cl:LOAD-LOGICAL-PATHNAME-TRANSLATIONS (host)
  "If a logical pathname host named HOST (a string) is already defined, return NIL.
Otherwise, search for a logical pathname host definition in an implementation
defined manner; on the Explorer, the file \"SYS:SITE;<host>.TRANSLATIONS\" is
loaded.  If no definition is found, signal an error.  If a definition is found,
install it and return T."
  ;;  7/11/89 DNG - Original.
  (cond ((parse-host host t t t) nil)
	(t (FS:MAKE-LOGICAL-PATHNAME-HOST host) t)))

(defun cl:COMPILE-FILE-PATHNAME (pathname &key output-file
				 &extension LOAD SET-DEFAULT-PATHNAME
				 VERBOSE TARGET DECLARE PACKAGE SUPPRESS-DEBUG-INFO)
  "Returns the pathname that COMPILE-FILE would write into, if given the
same arguments.  If the PATHNAME argument is a logical pathname and the
:OUTPUT-FILE argument is unspecified, the result is a logical pathname."
  ;;  7/11/89 DNG - Original.
  (declare (ignore LOAD SET-DEFAULT-PATHNAME VERBOSE DECLARE PACKAGE 
		   SUPPRESS-DEBUG-INFO))
  (let ((infile (FS:MERGE-PATHNAME-DEFAULTS pathname FS:LOAD-PATHNAME-DEFAULTS NIL)))
    (compiler::MERGE-PATHNAMES-WITH-NEW-TYPE
      infile (or (probe-file infile)
		 #'(lambda (ignore) ; used only for :TRUENAME operation
		     '#,(make-pathname :host "SYS" :version :newest)))
      output-file
      (target-binary-file-type (compiler:validate-target target)))))



;;; ----------------------
;;; proposal PATHNAME-WILD
;;; ----------------------

(defun cl:WILD-PATHNAME-P (pathname &optional field-key)
  "Tests a pathname for the presence of wild card components.
If no FIELD-KEY is provided, or the FIELD-KEY is NIL, the result is T if
PATHNAME has any wildcard components, NIL if PATHNAME has none.  If a non-null
FIELD-KEY is provided, it must be one of :HOST, :DEVICE, :DIRECTORY, :NAME,
:TYPE, or :VERSION.  In this case, the result is T if the indicated component of
PATHNAME is a wildcard, else NIL."
  ;;  7/11/89 DNG - Original.
  (send (pathname pathname)
	(ecase field-key
	  (nil :wild-p)
	  (:host (return-from cl:WILD-PATHNAME-P nil)) ; wild host not supported here
	  (:device :device-wild-p)
	  (:directory :directory-wild-p)
	  (:name :name-wild-p)
	  (:type :type-wild-p)
	  (:version :version-wild-p))))

(defun cl:PATHNAME-MATCH-P (pathname wildcard)
  ;;  7/12/89 DNG - Original.
  (send (if (stringp wildcard)
	    (parse-namestring wildcard nil '#,(pathname "sys:*;*.*#*"))
	  (pathname wildcard))
	:pathname-match
	(pathname pathname) ))



(defun cl:TRANSLATE-PATHNAME (source from-wildcard to-wildcard &key)
  "Translates the pathname SOURCE, which matches FROM-WILDCARD, into a
corresponding pathname result, which matches TO-WILDCARD, and returns result."
  ;;  7/12/89 DNG - Original.
  (send (pathname to-wildcard) :target-translate-wild-pathname
	(pathname from-wildcard) (pathname source)))



;;; ----------------------
;;; Proposal STREAM-CAPABILITIES
;;; ----------------------

(clos:defgeneric cl:INTERACTIVE-STREAM-P (stream)
  (:documentation "Returns T if the STREAM is interactive, otherwise NIL."))
(defmethod cl:INTERACTIVE-STREAM-P ((stream tv:stream-mixin)) t)
(defmethod cl:INTERACTIVE-STREAM-P ((stream stream)) nil)
(defmethod cl:INTERACTIVE-STREAM-P ((stream symbol))
  (cl:INTERACTIVE-STREAM-P (follow-syn-stream stream)))
(defmethod cl:INTERACTIVE-STREAM-P ((stream t))
  (cl:check-type stream (satisfies streamp) "STREAM")
  nil)

;; This needs to go in the CLUE streams file:
;;(defmethod cl:INTERACTIVE-STREAM-P ((stream clue:interactive-stream)) t)

;;; ----------------------
;;; Proposal PROCLAIM-ETC-IN-COMPILE-FILE:NEW-MACRO
;;; ----------------------

(defmacro cl:DECLAIM (&rest decl-specs)
  "This macro PROCLAIMs the given DECL-SPECS, which are not evaluated.
If a call to this macro appears at top-level in a file being processed by the 
file compiler, the proclamations are also made at compile-time."
  ;;  7/12/89 DNG - Original.
  `(eval-when (eval compile load)
     . ,(loop for x in decl-specs
	      collect `(proclaim (quote ,x)))))


;;; ----------------------
;;; Proposal SYNTACTIC-ENVIRONMENT-ACCESS
;;; ----------------------

(defun cl:DECLARATION-INFORMATION (decl-name &optional environment)
  "This function returns information about declarations named by the
symbol DECL-NAME that are in force in the environment ENVIRONMENT.
The currently supported values for DECL-NAME are OPTIMIZE and DECLARATION."
  ;;  7/12/89 DNG - Original.
  (ecase decl-name
    (OPTIMIZE (let-if (and compiler:qc-file-in-progress
			   (null environment))
		      ((compiler:optimize-switch (symeval-globally 'compiler:optimize-switch)))
		(cdr (compiler:optimize-status))))
    (DECLARATION compiler:declarations-ignored)
    ))

(defun cl:PARSE-MACRO (name lambda-list body &optional environment)
  "This function is used to process a macro definition in the same way as DEFMACRO
and MACROLET.  It returns a lambda-expression that accepts two arguments (a 
form and an environment).  The NAME, LAMBDA-LIST,and BODY arguments correspond 
to the parts of a DEFMACRO or MACROLET definition."
  ;;  7/12/89 DNG - Original.
  (declare (ignore environment)) ; should this be used somehow?
  (with-stack-list* (x name lambda-list body)
    (make-expander-function x)))

(defun cl:ENCLOSE (lambda-expression &optional environment)
  "This function returns an object of type FUNCTION that is equivalent to what
would be obtained by evaluating `(FUNCTION ,LAMBDA-EXPRESSION) in syntactic 
environment ENVIRONMENT."
  ;;  7/12/89 DNG - Original.
  (compiler:function-for-target lambda-expression environment))

;;; ----------------------
;;; Characters proposal 2.5.7
;;; ----------------------

(cl:defgeneric cl:FILE-STRING-LENGTH (file-stream object)
  (:documentation "Returns a non-negative integer which represents the difference between what
\(FILE-POSITION file-stream) would be after writing the OBJECT and its current 
value, or NIL if that cannot be determined.  OBJECT must be a string or 
character."))
(defmethod cl:file-string-length ((stream basic-buffered-output-stream) (object character)) 1)
(defmethod cl:file-string-length ((stream basic-buffered-output-stream) (object string)) (length object))
(defmethod cl:file-string-length ((stream ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN)
				  (object character))
  (if (eql object #\newline) 2 1))
(defmethod cl:file-string-length ((stream ASCII-TRANSLATING-OUTPUT-STREAM-MIXIN)
				  (object string))
  (+ (length object) (count #\newline object)))


;;; ----------------------
;;; Proposal DEFINE-COMPILER-MACRO
;;; ----------------------

(defmacro cl:DEFINE-COMPILER-MACRO (name lambda-list &body body)
  "Like DEFMACRO except that the expansion is done as a compiler optimization."
  ;;  7/12/89 DNG - Original.
  (let ((whole 'form))
    (when (eq (first lambda-list) '&whole)
      (setq whole (second lambda-list))
      (setq lambda-list (cddr lambda-list)))
    `(eval-when (eval compile load)
       (compiler:defoptimizer ,name ,(intern (concatenate 'string (SYMBOL-NAME NAME) "~OPTIMIZER")
					     (symbol-package name))
			      nil (,whole &optional (sys::*macroenvironment*
						      compiler:*local-environment*))
	 (declare (unspecial sys::*macroenvironment*))
	 sys::*macroenvironment*
	 (destructuring-bind ,lambda-list (cdr ,whole)
	   . ,body)))))



(defun cl:COMPILER-MACRO-FUNCTION (name &optional environment)
  (declare (ignore environment))
  (let ((symbol (find-symbol (concatenate 'string (SYMBOL-NAME NAME) "~OPTIMIZER")
			     (symbol-package name))))
    (and symbol (fdefinition-safe symbol))))

(defun (setf cl:COMPILER-MACRO-FUNCTION) (value name &optional environment)
  (declare (ignore environment))
  (let ((symbol (intern (concatenate 'string (SYMBOL-NAME NAME) "~OPTIMIZER")
			(symbol-package name))))
    (cond ((null value)
	   (fmakunbound symbol)
	   (let ((opt (get name 'compiler:OPTIMIZERS)))
	     (setf (get name 'compiler:OPTIMIZERS)
		   (if (listp opt)
		       (delete symbol (the list opt) :test #'eq)
		     (if (eq opt symbol)
			 nil
		       opt)))))
	  (t (when (fdefine symbol value t)
	       (compiler:PUSH-NEW-PROPERTY name symbol 'compiler:OPTIMIZERS)))))
  value)
))