;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 121.32
;;; Reason:
;;;  Add some macros to the SYSTEM package:
;;;   MESSAGECASE, REQUIRE-CHARACTER,
;;;   DEFINE-FUNCTIONAL-STREAM, DEFINE-SELECT-STREAM, CALL-STREAM-DEFAULT-HANDLER,
;;;   CHECK-SYSTEM-PARAMETER, DEFINE-PARAMETER-CHECKER,
;;;   CONSING-IN-AREA.
;;;  These are used to hide some LMI Zetalisp implementation details.
;;; Written 12-Feb-87 18:45:37 by RpK (Robert P. Krajewski) at site LMI Cambridge
;;; while running on Cthulhu from band 3
;;; with Experimental System 121.31, Experimental Lambda-Diag 15.0, Experimental ZMail 70.2, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, Experimental Site Data Editor 5.0, Experimental K Bridge Support 1.0, microcode 1742, SDU Boot Tape 3.12, SDU ROM 102, the old ones.

(mapc #'(lambda (x) (intern x "SYSTEM"))
      '("MESSAGECASE" "REQUIRE-CHARACTER" "CHECK-SYSTEM-PARAMETER" "DEFINE-PARAMETER-CHECKER"
	"CONSING-IN-AREA"
	"DEFINE-FUNCTIONAL-STREAM" "DEFINE-SELECT-STREAM" "CALL-STREAM-DEFAULT-HANDLER"))

; From modified file DJ: L.SYS2; LMMAC.LISP#455 at 12-Feb-87 18:52:54
#10R SYSTEM-INTERNALS#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "

(defmacro messagecase (place &rest clauses)
  "Like CASE, but the keys are assumed to be message names."
  ;; No transformations for now
  (list* 'case place clauses))

))

; From modified file DJ: L.SYS2; STRING.LISP#161 at 12-Feb-87 18:58:34
#8R SYSTEM-INTERNALS#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; STRING  "

(defmacro require-character (variable)
  "Checks the type of VARIABLE to be either a character or an integer.
If the value is initially an integer, it is coerced into a character with
INT-CHAR."
  `(progn
     (when (typep ,variable 'zl:fixnum)
       (setq ,variable (int-char ,variable)))
     (check-type ,variable character)))

))

; From modified file DJ: L.DEBUGGER; ERRMAC.LISP#25 at 12-Feb-87 18:58:54
#10R EH#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "EH")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: DEBUGGER; ERRMAC  "


(defmacro check-system-parameter (parameter type-specifier reset-value)
  "Checks the variable PARAMETER to have the type specified.
If it doesn't, the user is offered to set the value to RESET-VALUE.
The value of the expression is always the (legal) value of PARAMETER."
  `(let ((.val. nil))
     (loop
       (setq .val. ,parameter)
       (if (typep .val. ',type-specifier)
	   (return .val.)
	 (zl:signal-proceed-case (() 'eh:bad-system-parameter
				  :place ',parameter
				  :value .val.
				  :type-specifier ',type-specifier
				  :reset-value (setq ,parameter ,reset-value))
	   (:no-action))))))

(defmacro define-parameter-checker (function parameter type-specifier reset-value)
  "Defines a function which checks the variable PARAMETER to have the type specified.
If it doesn't, the user is offered to set the value to RESET-VALUE.
The functions always returns the (legal) value of PARAMETER."
  `(defun ,function ()
     (declare (dbg:error-reporter))
     (check-system-parameter ,parameter ,type-specifier ,reset-value)))

))

; From modified file DJ: L.SYS2; LMMAC.LISP#455 at 12-Feb-87 19:12:43
#10R SYSTEM-INTERNALS#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "

(defmacro consing-in-area ((area) &body body)
  "Causes the default consing area to be AREA within the dynamic extent of BODY.
If AREA evaluates to NIL, then the usual area of memory is used."
  `(let ((zl:default-cons-area (or ,area zl:working-storage-area)))
     ,@body))

))

; From modified file DJ: L.SYS2; LMMAC.LISP#455 at 12-Feb-87 19:13:20
#10R SYSTEM-INTERNALS#: #!:ZL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS2; LMMAC  "

;;; Used to flag uses of functions as streams.
(defmacro define-functional-stream (name lambda-list &body body)
  "Defines a stream named NAME as a function.
The BODY does the work of stream, which usually involves dispatching on the
first argument.  If a stream encounters an operation it does not handle itself,
and doesn't have any other stream to which to send the operation, it can call
the function CALL-STREAM-DEFAULT-HANDLER with arguments of the operation,
the first argument, and a list of the arguments after that.

It is preferable to use DEFINE-SELECT-STREAM, since the dispatching on the
operation name is explicit, and the default handler will get called as
needed.  If you still decide to use this, you should try to use the macro
GENERICP:MESSAGECASE."
  (multiple-value-bind (body decls doc) (extract-declarations body nil t)
    `(progn
       (setf (get ',name 'si:io-stream-p) t)
       (defun ,name ,lambda-list
	 (declare ,@decls)
	 ,@(and doc (list doc))
	 (macrolet ((call-stream-default-handler (operation arg1 &rest args)
		      `(zl:stream-default-handler ',',name ,operation ,arg1 ,@args)))
	   ,@body)))))

(defun call-stream-default-handler (operation arg1 &rest args)
  "Call the stream default handler.
Valid only inside DEFINE-FUNCTIONAL-STREAM."
  (declare (eh:error-reporter) (ignore operation arg1 args))
  (error "~S called outside valid context" 'call-stream-default-handler))

(defmacro define-select-stream (name &body clauses)
  "Defines a stream named NAME as a function.
Each CLAUSE, whose first element is an operation name or a list thereof, is invoked
when that matching stream operation is invoked.  The second element of the clause
is the lambda list used in the rest of the clause.

This is the preferred way to define ``one of a kind'' function streams."
  (let ((default-handler
	  (intern (zl:string-append (symbol-name name) "-DEFAULT-HANDLER"))))
    `(progn
       (defun ,default-handler (op &optional arg1 &rest rest)
	 (zl:stream-default-handler ',name op arg1 rest))
       (setf (get ',name 'si:io-stream-p) t)
       (zl:defselect (,name ,default-handler) ,@clauses))))

))