mirror of
https://github.com/PDP-10/its.git
synced 2026-03-20 16:38:16 +00:00
Updated to fix issue with printing and loading/dumping.
This commit is contained in:
Eric Swenson
@@ -132,8 +132,6 @@ UUO:/ ) (PRINC (COND ((NUMBERP PURE) (* PURE 2048.)) (0.)))
|
||||
(MAKUNBOUND 'INITIAL-SIZE)
|
||||
(SETQ PURE NIL ^W NIL)
|
||||
(LOGO)
|
||||
(defun dprinc (x) (princ x))
|
||||
(defun dterpri () (terpri))
|
||||
(SETQ BASE 10.
|
||||
IBASE 10.
|
||||
*NOPOINT T
|
||||
@@ -148,6 +146,7 @@ UUO:/ ) (PRINC (COND ((NUMBERP PURE) (* PURE 2048.)) (0.)))
|
||||
(PUTPROP 'LLOGO (LIST DUMP (READ)) 'VERSION))
|
||||
(UCLOSE)
|
||||
(PURIFY 0. 0. 'BPORG)
|
||||
(close (prog1 infile (inpush -1)))
|
||||
(SUSPEND (ATOMIZE ':SYMLOD EOL ':PDUMP/ LLOGO/;TS/ DUMP EOL ':KILL/ )))
|
||||
(DUMP (IOG NIL (PRINC 'VERSION/ NUMBER?/ )
|
||||
(PUTPROP 'LLOGO (LIST DUMP (READ)) 'VERSION))
|
||||
|
||||
336
src/llogo/print.2
Normal file
336
src/llogo/print.2
Normal file
@@ -0,0 +1,336 @@
|
||||
;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; LLOGO PRINTING FUNCTIONS. ;;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;
|
||||
|
||||
(DECLARE (OR (STATUS FEATURE DEFINE)
|
||||
(COND ((STATUS FEATURE ITS)
|
||||
;;MULTICS?
|
||||
(FASLOAD DEFINE FASL DSK LLOGO)))))
|
||||
|
||||
(SAVE-VERSION-NUMBER PRINT)
|
||||
|
||||
(DECLARE (GENPREFIX PRINT))
|
||||
|
||||
[(OR MULTICS DEC10) (DEFINE DPRINC (SYN PRINC))
|
||||
(DEFINE DTERPRI (SYN TERPRI))]
|
||||
|
||||
;[ITS (DEFUN DPRINC (X) (SUBRCALL NIL DPRINC X))
|
||||
; (DEFUN DTERPRI NIL (SUBRCALL NIL DTERPRI))
|
||||
; ;;WATCH IT, THESE ARE LSUBRS IN NEWIO!
|
||||
; (SETQ DPRINC (GET 'PRINC 'SUBR) DTERPRI (GET 'TERPRI 'SUBR))]
|
||||
|
||||
[ITS (defun dprinc (x) (princ x))
|
||||
(defun dterpri () (terpri))
|
||||
(SETQ DPRINC (GET 'DPRINC 'SUBR) DTERPRI (GET 'DTERPRI 'SUBR))]
|
||||
|
||||
(DEFUN DPRINT (X) (DTERPRI) (DPRIN1 X) (DPRINC '/ ))
|
||||
|
||||
(DEFUN DPRIN1 (X)
|
||||
(COND ((NUMBERP X) (DPRINC X))
|
||||
((ATOM X)
|
||||
(COND ((= (FLATC X) (FLATSIZE X)) (DPRINC X))
|
||||
((MAPC 'DPRINC (LIST '$ X '$)))))
|
||||
((DPRINC '/()
|
||||
(DO ((REST-LIST X (CDR REST-LIST)))
|
||||
((COND ((NULL REST-LIST) (DPRINC '/)))
|
||||
((ATOM REST-LIST)
|
||||
(DPRINC '" . ") (DPRIN1 REST-LIST) (DPRINC '/)))))
|
||||
(DPRIN1 (CAR REST-LIST))
|
||||
(AND (CDR REST-LIST) (DPRINC '/ ))))))
|
||||
|
||||
(DEFUN DPRINTL ARGS
|
||||
(DO ARG-INDEX 1. (1+ ARG-INDEX) (> ARG-INDEX ARGS)
|
||||
(DPRINC (ARG ARG-INDEX)) (DPRINC '/ ))
|
||||
(DTERPRI))
|
||||
|
||||
(DEFUN DPRINCSP (X) (DPRINC X) (DPRINC '/ ))
|
||||
|
||||
(DEFINE PRINT (PARSE (PARSE-SUBSTITUTE 'LOGO-PRINT)))
|
||||
|
||||
(DEFINE LOGO-PRINT (UNPARSE (UNPARSE-SUBSTITUTE 'PRINT)) (ABB P PR) (PARSE 1. L) ARGS
|
||||
(DO I 1. (1+ I) (> I ARGS) (TYPE (ARG I)) (DTERPRI))
|
||||
NO-VALUE)
|
||||
|
||||
(DEFINE FPRINT (ABB FP) (PARSE 1. L) ARGS
|
||||
(DO I 1. (1+ I) (> I ARGS) (DPRIN1 (ARG I)))
|
||||
?)
|
||||
|
||||
(DEFINE TYPE (PARSE 1. L) ARGS (DO ((I 1. (1+ I)))
|
||||
((> I ARGS) NO-VALUE)
|
||||
(COND ((ATOM (ARG I)) (DPRINC (ARG I)))
|
||||
((DO ((TYPE-ARG (ARG I) (CDR TYPE-ARG)))
|
||||
((ATOM (CDR TYPE-ARG))
|
||||
(DPRINC (CAR TYPE-ARG))
|
||||
(AND (CDR TYPE-ARG)
|
||||
(DPRINC '/ /./ )
|
||||
(DPRINC (CDR TYPE-ARG))))
|
||||
(DPRINCSP (CAR TYPE-ARG)))))))
|
||||
|
||||
(DEFINE BLANK NIL (DPRINC '/ ) NO-VALUE)
|
||||
|
||||
(DEFINE CARRIAGERETURN (ABB CR) NIL (DPRINC EOL) NO-VALUE)
|
||||
|
||||
(DEFINE LINEFEED NIL NIL (DPRINC (ASCII 10.)) NO-VALUE)
|
||||
|
||||
[MULTICS (DEFINE PRETTY (NEWLINEL)
|
||||
;;UPDATES CHRCT AND LINEL. IDENTICAL TO "NEWLINEL" IN GRIND.
|
||||
(CHRCT NIL (+ (CHRCT NIL) (- NEWLINEL (LINEL NIL))))
|
||||
(LINEL NIL NEWLINEL))]
|
||||
|
||||
[(OR ITS DEC10) (DEFINE PRETTY (NEWLINEL) (SETQ CHRCT (+ CHRCT (- NEWLINEL LINEL)))
|
||||
(SETQ LINEL NEWLINEL))]
|
||||
|
||||
;;THE DPRIN FNS PRINT ON DISPLAY AS WELL AS AT TTY IF :SHOW = T. IF TRUE, THE
|
||||
;;DPRINT FNS OUTPUT TO 6.
|
||||
|
||||
(SETQ :SHOW NIL)
|
||||
|
||||
;;LISTING
|
||||
|
||||
(DEFINE PRINTOUT (ABB PO) FEXPR (X)
|
||||
(COND ((NULL X) (LIST-PROCEDURE FN))
|
||||
((MEMQ (CAR X) '(ABBREVIATIONS ABBS)) (PRINTOUTABBREVIATIONS))
|
||||
((MEMQ (CAR X) '(NAMES :NAMES)) (PRINTOUTNAMES))
|
||||
((EQ (CAR X) 'PROCEDURES) (PRINTOUTPROCEDURES))
|
||||
((EQ (CAR X) 'ALL)
|
||||
(PRINTOUTPROCEDURES)
|
||||
(DTERPRI)
|
||||
(PRINTOUTNAMES))
|
||||
((MEMQ (CAR X) '(CONTENTS :CONTENTS TITLES)) (PRINTOUTCONTENTS))
|
||||
((EQ (CAR X) 'TITLE) (APPLY 'PRINTOUTTITLE (CDR X)))
|
||||
((EQ (CAR X) 'LINE) (PRINTOUTLINE (CADR X)))
|
||||
((MEMQ (CAR X) '(PRIMITIVES :PRIMITIVES)) (PRINTOUTPRIMITIVES))
|
||||
((EQ (CAR X) 'FILE) (APPLY 'PRINTOUTFILES (CDR X)))
|
||||
[(OR ITS MULTICS) ((MEMQ (CAR X) '(INDEX FILES))
|
||||
(APPLY 'PRINTOUTINDEX (CDR X)))]
|
||||
[ITS ((MEMQ (CAR X) '(SNAPS :SNAPS)) (PRINTOUTSNAPS))]
|
||||
((MAPC 'LIST-PROCEDURE X)))
|
||||
?)
|
||||
|
||||
(DEFINE CONTENTS NIL (DELEET :CONTENTS :BURIED))
|
||||
|
||||
[CLOGO (DEFINE LIST (PARSE (PARSE-CLOGO-HOMONYM PRINTOUT L)))]
|
||||
|
||||
(DEFINE PRINTOUTCONTENTS (ABB LC LISTCONTENTS POC POTS) NIL
|
||||
(MAPC '(LAMBDA (USER-PROCEDURE)
|
||||
(OR (MEMQ USER-PROCEDURE :BURIED)
|
||||
(LOGOPRINT (CAR (EDITINIT1 USER-PROCEDURE)))))
|
||||
:CONTENTS)
|
||||
NO-VALUE)
|
||||
|
||||
(DEFINE PRINTOUTSNAPS (ABB LISTSNAPS) NIL (AND :SNAPS (TYPE :SNAPS EOL)) NO-VALUE)
|
||||
|
||||
(DEFINE PRINTOUTPROCEDURES (ABB LISTPROCEDURES LPR POPR) NIL
|
||||
(MAPC '(LAMBDA (USER-PROCEDURE) (OR (MEMQ USER-PROCEDURE :BURIED)
|
||||
(LIST-PROCEDURE USER-PROCEDURE)
|
||||
(DTERPRI)))
|
||||
:CONTENTS)
|
||||
?)
|
||||
|
||||
(DEFINE PRINTOUTTITLE (ABB LISTTITLE POT) FEXPR (OPTFUNCTION)
|
||||
(DEFAULT-FUNCTION 'PRINTOUTTITLE (AND OPTFUNCTION (CAR OPTFUNCTION)))
|
||||
(LOGOPRINT TITLE)
|
||||
NO-VALUE)
|
||||
|
||||
(DEFINE PRINTOUTALL (ABB POA LISTALL) NIL (PRINTOUTPROCEDURES) (PRINTOUTNAMES) ?)
|
||||
|
||||
(DEFINE PRINTOUTFILE (ABB POF LISTFILE) FEXPR (FILENAME)
|
||||
;;TAKES A FILE NAME AS INPUT AND PRINTS THE FILE.
|
||||
(APPLY 'UREAD (FILESPEC FILENAME))
|
||||
(SETQ ^Q T)
|
||||
(DO ((CHARNUM (TYI -1.) (TYI -1.)))
|
||||
((OR (NULL ^Q) (MINUSP CHARNUM)) (SETQ ^Q NIL) (TERPRI))
|
||||
(OR (= CHARNUM 12.) (= CHARNUM 10.) (TYO CHARNUM)))
|
||||
NO-VALUE)
|
||||
|
||||
[(OR ITS MULTICS) (DEFINE PRINTOUTINDEX (ABB POI LISTINDEX LISTFILES) FEXPR (WHOSE)
|
||||
;;PRINTS OUT LISTING OF FILES.
|
||||
[ITS (APPLY 'PRINTOUTFILE
|
||||
(APPEND '(".FILE."
|
||||
"(DIR)")
|
||||
WHOSE))]
|
||||
[MULTICS (CLINE (GET_PNAME (APPLY 'ATOMIZE
|
||||
(CONS 'LIST/
|
||||
(AND WHOSE
|
||||
(CONS '/ -P/
|
||||
WHOSE))))))]
|
||||
[DEC10 (VALRET (APPLY 'ATOMIZE
|
||||
(APPEND '("DIR ")
|
||||
(AND WHOSE (CONS '/[ WHOSE))
|
||||
(AND WHOSE '(/]))
|
||||
'(/
|
||||
))))] NO-VALUE)]
|
||||
|
||||
(DEFINE PRINTOUTLINE (ABB LISTLINE LL POL) (NUMBER)
|
||||
(DEFAULT-FUNCTION 'PRINTOUTLINE NIL)
|
||||
(COND ((GETLINE PROG (SETQ NUMBER (NUMBER? 'PRINTOUTLINE NUMBER)))
|
||||
(TYPE '";PRINTING LINE "
|
||||
NUMBER
|
||||
'" OF "
|
||||
FN
|
||||
EOL)
|
||||
(LOGOPRINT (CONS NUMBER THIS-LINE))
|
||||
NO-VALUE)
|
||||
((SETQ NUMBER
|
||||
(ERRBREAK 'PRINTOUTLINE
|
||||
(LIST '"NO LINE NUMBERED "
|
||||
NUMBER
|
||||
'" IN "
|
||||
FN)))
|
||||
(PRINTOUTLINE NUMBER))))
|
||||
|
||||
;;;FOR EACH NAME ON :NAMES, PRINTOUTNAMES WRITES OUT
|
||||
;;; MAKE "<NAME>" "<THING>"
|
||||
;;;WHICH CAN BE REREAD TO RESTORE VALUES OF VARIABLES.
|
||||
|
||||
(DEFINE PRINTOUTNAMES (ABB LISTNAMES LN PON) NIL
|
||||
(COND
|
||||
(:CAREFUL
|
||||
(COND (:NAMES (DTERPRI)
|
||||
(MAPC
|
||||
'(LAMBDA (NAME)
|
||||
(AND (BOUNDP NAME)
|
||||
(DPRINC '"MAKE '")
|
||||
(DO ((CHARNUM 3. (1+ CHARNUM))
|
||||
(CHAR (GETCHAR NAME 2.) (GETCHAR NAME CHARNUM)))
|
||||
((NULL CHAR) T)
|
||||
(DPRINC CHAR))
|
||||
;;SPECIAL CASE CHECK FOR :EMPTYW IS REQUIRED, SINCE
|
||||
;;ITS PRINTED REPRESENTATION IS NOT REREADABLE.
|
||||
(COND ((EQ (SETQ NAME (SYMEVAL NAME)) :EMPTYW)
|
||||
(TYPE '" :EMPTYW" EOL))
|
||||
((DPRINC '" '") (DPRIN1 NAME) (DTERPRI)))))
|
||||
:NAMES))
|
||||
((IOG NIL (TYPE '";NO NAMES DEFINED" EOL)))))
|
||||
((IOG
|
||||
NIL
|
||||
(TYPE
|
||||
'";YOU ARE NOT IN CAREFUL MODE. NO NAMES ARE SAVED."
|
||||
EOL))))
|
||||
NO-VALUE)
|
||||
|
||||
;;LISTING ABBREVIATIONS AND PRIMITIVES IS ACCOMPLISHED BY EXAMINING THE OBLIST.
|
||||
;;THIS TAKES NO SPACE BUT RESULTS IN AN UNORDERED AND THEREFORE UNINFORMATIVE
|
||||
;;PRINTOUT. AN IMPROVEMENT WOULD BE TO HAVE THESE INQUIRES BE ANSWERED BY ACCESSING
|
||||
;;A DSK FILE OF COMMENTARY. THE FILE COULD BE CREATED AT COMPILE TIME.
|
||||
|
||||
(DEFINE PRINTOUTABBREVIATIONS (ABB LISTABBREVIATIONS) NIL
|
||||
(TYPE '";ABBREVIATIONS:" EOL)
|
||||
;;FILTER FOR ABBREVIATIONS.
|
||||
(OBFILTER (EXPR-FUNCTION ABBREVIATIONP)
|
||||
(EXPR-FUNCTION (LAMBDA (AB)
|
||||
(TYPE AB
|
||||
'" ABBREVIATION FOR "
|
||||
(ABBREVIATIONP AB)
|
||||
EOL)))))
|
||||
|
||||
(DEFINE PRINTOUTPRIMITIVES (ABB LISTPRIMITIVES) NIL
|
||||
(TYPE 'PRIMITIVES: EOL)
|
||||
(OBFILTER (EXPR-FUNCTION (LAMBDA (X) (AND (PRIMITIVEP X)
|
||||
(NOT (ABBREVIATIONP X)))))
|
||||
(EXPR-FUNCTION DPRINT)))
|
||||
|
||||
(DEFUN OBFILTER (*FILTER* *MESSAGE*)
|
||||
;;PRINTS (MESSAGE ATOM) FOR EACH ATOM ON
|
||||
(DO ((J 0. (1+ J)))
|
||||
((= J (CADR (ARRAYDIMS 'OBARRAY))))
|
||||
(MAPC '(LAMBDA (ATOM)
|
||||
(AND (EXPR-CALL *FILTER* ATOM) (EXPR-CALL *MESSAGE* ATOM)))
|
||||
(ARRAYCALL NIL OBARRAY J)))
|
||||
?)
|
||||
|
||||
(DEFUN LIST-PROCEDURE (FNNAME)
|
||||
;;PRINTS LISPIFIED USER FN AS LOGO.
|
||||
(DEFAULT-FUNCTION 'LIST-PROCEDURE FNNAME)
|
||||
(DTERPRI)
|
||||
(LOGOPRINC TITLE)
|
||||
(DO ((PROC (CDDDR PROG) (CDR PROC)) (THIS-FORM (CADDR PROG) (CAR PROC)))
|
||||
((NULL PROC) (TYPE EOL 'END EOL))
|
||||
(COND ((NUMBERP THIS-FORM)
|
||||
;;TAG PRINTED
|
||||
(DTERPRI)
|
||||
(DPRINC THIS-FORM))
|
||||
((DPRINC '/ )
|
||||
(UNPARSE-FORM (EXPR-FUNCTION DPRINC) THIS-FORM)))))
|
||||
|
||||
;;*PAGE
|
||||
|
||||
|
||||
(DEFUN LOGOPRINT (X) (LOGOPRINC X) (DTERPRI))
|
||||
|
||||
(DEFUN LOGOPRINSP (X) (LOGOPRINC X) (DPRINC '/ ))
|
||||
|
||||
;;; THE FOLLOWING CODE INSERTS CARRAIGE RETURNS IN LONG COMMENTS
|
||||
;;; LIKE THE PRETTY-PRINTER DOES. THIS CODE IS NOW UNUSUABLE DUE
|
||||
;;; TO MODIFICATIONS IN THE PRINTER, BUT SIMILAR STUFF SHOULD BE
|
||||
;;; WRITTEN AT SOME POINT.
|
||||
;;;
|
||||
;;;
|
||||
;;; (DEFUN PRINT-COMMENT (FN ARGS)
|
||||
;;; (DINDENT-TO (DIFFERENCE LINEL 20.))
|
||||
;;; (DPRINC '!)
|
||||
;;; (DSEGTEXT (CAR ARGS))
|
||||
;;; (DPRINC '!))
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
;;; (DEFUN DINDENT-TO (X)
|
||||
;;;SIMILAR
|
||||
;;TO INDENT-TO BUT DOES NOT USE TABS
|
||||
;;; (AND (LESSP CHRCT X) (DTERPRI))
|
||||
;;;WHICH
|
||||
;;DISPLAY DOES NOT UNDERSTAND.
|
||||
;;; (PROG NIL
|
||||
;;; LOOP (COND ((= CHRCT X)) ((DPRINC '/ ) (GO LOOP)))))
|
||||
;;;
|
||||
;;; (DEFUN DSEGTEXT (L)
|
||||
;;; (PROG (N)
|
||||
;;; (AND (ATOM L) (RETURN (TYPE L))) ;GRINDS THE
|
||||
;;SEGMENT L AS TEXT INTO REMAINING
|
||||
;;; (SETQ N CHRCT) ;SPACE ON
|
||||
;;LINE. SERVES TO INSERT CR'S IN
|
||||
;;; A (TYPE (CAR L)) ;EXCESSIVELY
|
||||
;;LONG COMMENTS.
|
||||
;;; (POP L)
|
||||
;;; (OR L (RETURN NIL))
|
||||
;;; (COND ((LESSP (FLATSIZE (CAR L)) (DIFFERENCE CHRCT 2.))
|
||||
;;; (DPRINC '/ ))
|
||||
;;; ((DINDENT-TO N)))
|
||||
;;; (GO A)))
|
||||
;;;
|
||||
|
||||
(DEFINE LINEPRINT FEXPR (X)
|
||||
[ITS (UWRITE TPL)]
|
||||
[MULTICS (UWRITE)]
|
||||
(IOG
|
||||
RW
|
||||
(PROG (CRUNIT :SHOW LINEL)
|
||||
[(OR ITS DEC10) (SETQ LINEL 120.)]
|
||||
[MULTICS (SETQ LINEL (LINEL NIL))
|
||||
(LINEL NIL 120.)]
|
||||
;;SAVE CURRENT DEVICE, DIRNAME.
|
||||
(SETQ CRUNIT (CRUNIT))
|
||||
(TYPE '";************* "
|
||||
(STATUS UNAME)
|
||||
'/
|
||||
(OR X :EMPTYW)
|
||||
'" *************"
|
||||
EOL)
|
||||
(DPRINTL '/; (DAYTIME))
|
||||
(DPRINTL '/; (DATE))
|
||||
(DTERPRI)
|
||||
(PRINTOUTALL)
|
||||
[ITS (UFILE)]
|
||||
[MULTICS (LET ((DIRECTORY (GET_PNAME (CAR (NAMES (CAR OUTFILES))))))
|
||||
(UFILE LINE_PRINT LOGO)
|
||||
(CLINE (CATENATE "DPRINT -DELETE "
|
||||
DIRECTORY
|
||||
">LINE_PRINT.LOGO ")))
|
||||
(LINEL NIL LINEL)]
|
||||
;;RESTORE ORIGINAL DEVICE.
|
||||
(APPLY 'CRUNIT CRUNIT)))
|
||||
NO-VALUE)
|
||||
|
||||
Reference in New Issue
Block a user