github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-27 04:41:54 +00:00
Code Issues Projects Releases Wiki Activity

add merge in Ron's 11/21/2020 lispcore

Browse Source
This commit is contained in:
Larry Masinter
2020-11-21 13:24:44 -08:00
parent e9a80b1144
commit ce4eae736e
794 changed files with 117194 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

163
CLTL2/CMLMISCIO Normal file
View File

@@ -0,0 +1,163 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
(FILECREATED "18-Oct-93 14:20:56" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMISCIO.;2" 6473
|previous| |date:| "25-Oct-91 22:41:18" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMISCIO.;1"
)
; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT CMLMISCIOCOMS)
(RPAQQ CMLMISCIOCOMS
(
(* |;;| "Random leftover IO functions")
(* |;;| "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]")
(FUNCTIONS LISP:Y-OR-N-P LISP:YES-OR-NO-P)
(* |;;| "JRB - stuff that handles CL:*PRINT-READABLY*")
(FUNCTIONS HANDLE-PRINT-READABLY LISP::CHECK-READABLY)
(FUNCTIONS LISP:PRINT-UNREADABLE-OBJECT LISP:WITH-STANDARD-IO-SYNTAX)
(* |;;| "Arrange to use the proper compiler")
(PROP FILETYPE CMLMISCIO)))
(* |;;| "Random leftover IO functions")
(* |;;| "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]")
(LISP:DEFUN LISP:Y-OR-N-P (&OPTIONAL FORMAT-STRING &REST ARGUMENTS)
(COND
(FORMAT-STRING (LISP:FRESH-LINE)
(LISP:APPLY (FUNCTION LISP:FORMAT)
*QUERY-IO* FORMAT-STRING ARGUMENTS)))
(LISP:FLET ((LISP::READ-CHAR-NOW NIL (RESETFORM (CONTROL T)
(LISP:READ-CHAR *QUERY-IO*))))
(LISP:DO ((LISP::RESPONSE (LISP::READ-CHAR-NOW)
(LISP::READ-CHAR-NOW)))
((OR (LISP:CHAR-EQUAL LISP::RESPONSE #\Y)
(LISP:CHAR-EQUAL LISP::RESPONSE #\N))
(LISP:FRESH-LINE)
(LISP:CHAR-EQUAL LISP::RESPONSE #\Y))
(LISP:FORMAT *QUERY-IO* "~&Please type either Y or N: "))))
(LISP:DEFUN LISP:YES-OR-NO-P (&OPTIONAL LISP::FORMAT-STRING &REST LISP::ARGUMENTS)
(LISP:WHEN LISP::FORMAT-STRING
(LISP:FRESH-LINE *QUERY-IO*)
(LISP:APPLY #'LISP:FORMAT *QUERY-IO* LISP::FORMAT-STRING LISP::ARGUMENTS))
(LISP:DO ((LISP::RESPONSE (LISP:READ-LINE *QUERY-IO*)
(LISP:READ-LINE *QUERY-IO*)))
((OR (STRING-EQUAL LISP::RESPONSE "YES")
(STRING-EQUAL LISP::RESPONSE "NO"))
(STRING-EQUAL LISP::RESPONSE "YES"))
(LISP:FORMAT *QUERY-IO* "Please type either YES or NO: ")))
(* |;;| "JRB - stuff that handles CL:*PRINT-READABLY*")
(LISP:DEFUN HANDLE-PRINT-READABLY ()
(* |;;| "Strategy: when *PRINT-READABLY* is on, all CL top-level printing functions go through a function that rebinds all the printer control variables (like WRITE or WRITE-TO-STRING). Calling HANDLE-PRINT-READABLY sets the control variables so output is printed readably; it also sets *PRINT-READABLY* to a magic value so functions like FORMAT and WRITE-STRING will know it's OK to write constant strings without munging them.")
(SETQ *PRINT-ESCAPE* T)
(SETQ *PRINT-LEVEL* NIL)
(SETQ *PRINT-LENGTH* NIL)
(SETQ *PRINT-GENSYM* T)
(SETQ *PRINT-ARRAY* T)
(SETQ *PRINT-CIRCLE* T)
(SETQ XCL:*PRINT-STRUCTURE* T)
(SETQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY))
(LISP:DEFUN LISP::CHECK-READABLY (XCL::THING &OPTIONAL LISP::WHERE)
(LISP:WHEN LISP:*PRINT-READABLY*
(LET (LISP:*PRINT-READABLY*)
(CONDITIONS:RESTART-CASE (LISP:ERROR 'LISP::PRINT-NOT-READABLE :THING XCL::THING :WHERE
LISP::WHERE)
(XCL::PRINT-IT-ANYWAY NIL :REPORT (LISP:LAMBDA (STREAM)
(LISP:PRINC "Print it anyway " STREAM))
:FILTER
(LISP:LAMBDA NIL (TYPEP XCL:*CURRENT-CONDITION*
'LISP::PRINT-NOT-READABLE)))))))
(DEFMACRO LISP:PRINT-UNREADABLE-OBJECT ((LISP::OBJECT STREAM &KEY TYPE LISP:IDENTITY)
&BODY LISP::BODY)
(LET ((LISP::O (LISP:GENSYM))
(LISP::S (LISP:GENSYM))
(LISP::SPACE? (LISP:GENSYM)))
`(LET ((,LISP::O ,LISP::OBJECT)
(,LISP::S ,STREAM)
,LISP::SPACE?)
(LISP::CHECK-READABLY ,LISP::O)
(WRITE-STRING* "#<" ,LISP::S)
,@(LISP:WHEN TYPE
`((LISP:WHEN ,TYPE
(LISP:SETQ ,LISP::SPACE? T)
(WRITE (LISP:TYPE-OF ,LISP::O)
,LISP::S))))
,@(LISP:WHEN LISP::BODY
`((LISP:WHEN ,LISP::SPACE?
(LISP:WRITE-CHAR #\Space ,LISP::S))
(PROGN ,@LISP::BODY (LISP:SETQ ,LISP::SPACE? T))))
,@(LISP:WHEN LISP:IDENTITY
`((LISP:WHEN ,LISP:IDENTITY
(LISP:WHEN ,LISP::SPACE?
(LISP:WRITE-CHAR #\Space ,LISP::S))
(WRITE-STRING* "@ " ,LISP::S)
(\\PRINTADDR ,LISP::O ,LISP::S))))
(LISP:WRITE-CHAR #\> ,LISP::S)
NIL)))
(DEFMACRO LISP:WITH-STANDARD-IO-SYNTAX (&BODY LISP::BODY)
`(LET ((*PACKAGE* (LISP:FIND-PACKAGE "COMMON-LISP-USER"))
(*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)
(LISP:*PRINT-READABLY* T)
(*READ-BASE* 10)
(*READ-DEFAULT-FLOAT-FORMAT* 'LISP:SINGLE-FLOAT)
(LISP:*READ-EVAL* T)
(*READ-SUPPRESS* NIL)
(*READTABLE* (FIND-READTABLE "LISP"))
(* |;;| "XP-specific variables")
(XP:*PRINT-LINES* NIL)
(XP:*PRINT-MISER-WIDTH* NIL)
(XP:*PRINT-PPRINT-DISPATCH* NIL)
(XP:*PRINT-RIGHT-MARGIN* NIL)
(* |;;| "XCL-specific variables")
(XCL:*PRINT-STRUCTURE* T))
,@LISP::BODY))
(* |;;| "Arrange to use the proper compiler")
(PUTPROPS CMLMISCIO FILETYPE LISP:COMPILE-FILE)
(PUTPROPS CMLMISCIO COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1993))
(DECLARE\: DONTCOPY
(FILEMAP (NIL)))
STOP