(FILECREATED "18-Feb-84 10:06:02" {PHYLUM}<LISPCORE>SOURCES>DMISC.;95 50971
changes to: (FNS FLASHWINDOW \DISMISS.WITHOUT.BLOCKING RINGBELLS)
previous date: " 7-Feb-84 16:35:08" {PHYLUM}<LISPCORE>SOURCES>DMISC.;94)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT DMISCCOMS)
(RPAQQ DMISCCOMS ((COMS (FNS TENEX))
(COMS (FNS BACKSPACEDEL)
(DECLARE: DOCOPY DONTEVAL@LOAD (P (BACKSPACEDEL \ORIGTERMTABLE)
(BACKSPACEDEL NIL))))
(COMS (* timeall functions)
(FNS TIMEALL COPYMISCSTATS COPYTIMESTATS CREATEMISCSTATS DIFFMISCSTATS
DIFFTIMESTATS PRINTMISCSTATS PRINTMISCSTATSITEM)
(DECLARE: DONTCOPY (RECORDS STATSOBJECT)))
(COMS (FNS PERIODICALLYRECLAIM)
(INITVARS (RECLAIMWAIT 4)
(\LASTRECLAIM (\DAYTIME0 (NCREATE (QUOTE FIXP)))))
(DECLARE: DONTEVAL@LOAD DOCOPY (APPENDVARS (BACKGROUNDFNS PERIODICALLYRECLAIM)
)))
(FNS APROPOS \APROPOS.MARGINSET)
(COMS (FNS \DIRTYBACKGROUND \SAVEVMBACKGROUND COPYVM)
(INITVARS (BACKGROUNDPAGEMIN 40)
(BACKGROUNDPAGECNT 0)
(BACKGROUNDPAGEFREQ 4))
(INITVARS (SAVINGCURSOR)
(SAVEVMMAX 600)
(SAVEVMWAIT 300))
(ADDVARS (BACKGROUNDFNS \DIRTYBACKGROUND)
(TTYBACKGROUNDFNS \SAVEVMBACKGROUND))
(GLOBALVARS BACKGROUNDPAGEMIN BACKGROUNDPAGEFREQ BACKGROUNDPAGECNT))
(COMS (* Setting the time)
(FNS SETTIME))
(COMS (* Bells and whistles)
(FNS RINGBELLS FLASHWINDOW \DISMISS.WITHOUT.BLOCKING PLAYTUNE)
(GLOBALRESOURCES (\PlayTimer (SETUPTIMER 0)))
(DECLARE: DONTEVAL@LOAD DOCOPY (* Overrides definition in the shared MISC)
(P (MOVD (QUOTE RINGBELLS)
(QUOTE PRINTBELLS)))))
(COMS (* These are optimizations for Interlisp-D only)
(FNS ATOMHASH#PROBES \ATOM.FIRSTHASHINDEX)
(COMS (* Overrides definition found on MISC)
(FNS GENSYM?)))
(COMS (* functions for turning the display off.)
(FNS DISPLAYDOWN SETDISPLAYHEIGHT VIDEORATE)
(INITVARS (\VIDEORATE (QUOTE NORMAL)))
(DECLARE: DONTEVAL@LOAD DOCOPY (ADDVARS (BREAKRESETFORMS (SETDISPLAYHEIGHT
T))
(RESETFORMS (SETDISPLAYHEIGHT T)))))
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (#EOLCHARS 1))
(P (OR (LISTP (EVALV (QUOTE EDITCHARACTERS)))
(RPAQ EDITCHARACTERS (QUOTE (J X Z Y N)))))
(ADDVARS (POSTGREETFORMS (CNDIR))
(LISPUSERSDIRECTORIES)))
(COMS (PROP VARTYPE BAKTRACELST)
(ALISTS (BREAKMACROS BT BTV BTVPP BT!)
(BAKTRACELST EVAL APPLY))
(DECLARE: DONTEVAL@LOAD DOCOPY (INITVARS (CLEANUPOPTIONS (QUOTE (RC))))))
(COMS (FNS DOAROUNDEXITFORMS)
(ADDVARS (AROUNDEXITFNS DOAROUNDEXITFORMS)
(BEFORELOGOUTFORMS)
(AFTERLOGOUTFORMS)))
(DECLARE: DONTEVAL@LOAD DOCOPY (INITVARS (ADVISEDFNS)))
(COMS (* from FASTARRAYS)
(FNS POINTERARRAY WORDARRAY FIXPARRAY)
(P (MAPC (QUOTE ((ELT FASTELT FASTELTN FASTELTW)
(SETA FASTSETA FASTSETAN FASTSETAW)
(GETHASH IGETHASH)
(PUTHASH IPUTHASH)))
(FUNCTION (LAMBDA (X)
(MAPC (CDR X)
(FUNCTION (LAMBDA (Y)
(MOVD? (CAR X)
Y)))))))))
(COMS (* Versions etc)
(FNS REALMEMORYSIZE LISPVERSION MICROCODEVERSION BCPLVERSION REQUIREVERSION))
(COMS (* Misc ops)
(FNS READPRINTERPORT WRITEPRINTERPORT \MISC1.UFN \MISC2.UFN))
(COMS * PRINTINGCOMS)
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA
LISTFILES)
(NLAML
TIMEALL)
(LAMA)))))
(DEFINEQ
(TENEX
[LAMBDA (STR) (* lmm "29-APR-81 10:40")
(RESETLST (PROG (REM.CM)
(SETQ REM.CM (OPENFILE (QUOTE {DSK}REM.CM;1)
(QUOTE OUTPUT)))
(RESETSAVE NIL (LIST [FUNCTION (LAMBDA (X)
(AND RESETSTATE (PROGN (CLOSEF? X)
(CLOSEF (OPENFILE X (QUOTE OUTPUT]
REM.CM))
(PRIN3 STR REM.CM)
(PRIN3 "
LISP.run
" REM.CM)
(CLOSEF REM.CM)
(LOGOUT])
)
(DEFINEQ
(BACKSPACEDEL
[LAMBDA (TTBL) (* lmm "24-JUN-80 23:16")
(* Hack for causing char-delete to backspace display. Also suppress ## when reach the left margin.
-
This should be executed after the chardelete in TTBL has been established. -
ERASECHARCODE is in INITCONSTANTS on LLPARAMS)
(DELETECONTROL (QUOTE 1STCHDEL)
(CHARACTER ERASECHARCODE)
TTBL)
(DELETECONTROL (QUOTE NTHCHDEL)
(CHARACTER ERASECHARCODE)
TTBL)
(DELETECONTROL (QUOTE POSTCHDEL)
"" TTBL)
(DELETECONTROL (QUOTE EMPTYCHDEL)
"" TTBL)
(DELETECONTROL (QUOTE NOECHO)
NIL TTBL)
(ECHOCONTROL ERASECHARCODE (QUOTE REAL])
)
(DECLARE: DOCOPY DONTEVAL@LOAD
(BACKSPACEDEL \ORIGTERMTABLE)
(BACKSPACEDEL NIL)
)
(* timeall functions)
(DEFINEQ
(TIMEALL
[NLAMBDA (TIMEFORM NUMBEROFTIMES TIMEWHAT INTERPFLG SHOWCODE)
(* bvm: "10-MAR-83 12:58")
(* collects and prints stats on TIMEFORM. TIMEWHAT indicates what to collect stats on: if T, all of the system
times are collected; if NIL, the system times plus all data allocations are kept; if a list, it should be a list
of DATATYPES (or numbers) and may include the atom TIME if system times should be included.
This function sets the variables BEFORESTATS, AFTERSTATS and DIFFERENCESTATS to the values of the stats objects
before, after and the difference between them. These can be examined via the function PRINTMISCSTATS.)
(DECLARE (GLOBALVARS BEFORESTATS AFTERSTATS DIFFERENCESTATS DFNFLG OPTIMIZATIONSOFF)
(SPECVARS LCFIL STRF LAPFLG))
(PROG [VALUE (TIMEFLG (OR (NULL TIMEWHAT)
(EQ TIMEWHAT T)
(MEMB (QUOTE TIME)
TIMEWHAT)))
(DATATYPES (COND
((NULL TIMEWHAT)
(DATATYPES))
((EQ TIMEWHAT T)
NIL)
(T (for X inside TIMEWHAT bind NAME
join (COND
((SETQ NAME (DATATYPEP X))
(CONS NAME))
((EQ X (QUOTE TIME))
NIL)
(T (printout T X " is not a datatype." T)
NIL] (* create all necessary storage before performing test
form.)
(OR (NUMBERP NUMBEROFTIMES)
(SETQ NUMBEROFTIMES 1))
[COND
([OR (NLISTP AFTERSTATS)
(NOT (EQUAL DATATYPES (fetch DATATYPES of AFTERSTATS]
(SETQ DIFFERENCESTATS (CREATEMISCSTATS DATATYPES TIMEFLG))
(SETQ BEFORESTATS (CREATEMISCSTATS DATATYPES TIMEFLG))
(SETQ AFTERSTATS (CREATEMISCSTATS DATATYPES TIMEFLG]
[COND
[(OR INTERPFLG (EQ NUMBEROFTIMES 1))
(COPYMISCSTATS BEFORESTATS DATATYPES)
(SETQ VALUE (FRPTQ NUMBEROFTIMES (EVAL TIMEFORM]
(T [RESETVARS ((DFNFLG T)
(OPTIMIZATIONSOFF T))
(PROG ((STRF T)
(LCFIL)
(LAPFLG SHOWCODE))
(COMPILE1 (QUOTE TIMEDUMMYFUNCTION)
(LIST (QUOTE LAMBDA)
NIL
(LIST (QUOTE FRPTQ)
NUMBEROFTIMES TIMEFORM]
(COPYMISCSTATS BEFORESTATS DATATYPES)
(SETQ VALUE (TIMEDUMMYFUNCTION]
(COPYMISCSTATS AFTERSTATS DATATYPES T)
(PRINTMISCSTATS (DIFFMISCSTATS BEFORESTATS AFTERSTATS DIFFERENCESTATS)
DATATYPES)
(RETURN VALUE])
(COPYMISCSTATS
[LAMBDA (STATS DATATYPES BEFOREFLG) (* bvm: "28-MAR-82 22:00")
(* smashes the fields of STATS to be the current values of stats in the system. BEFOREFLG indicates whether
elapsed time should be taken before or after the bulk of the work.)
(DECLARE (GLOBALVARS \MISCSTATS))
[COND
(BEFOREFLG (CLOCK0 (fetch ELAPSEDTIME of STATS))
(for TYPE in DATATYPES as X on (fetch DATACOUNTERS of STATS)
do (RPLACA X (BOXCOUNT TYPE]
(AND (fetch TIMEBLOCK of STATS)
(COPYTIMESTATS \MISCSTATS (fetch TIMEBLOCK of STATS)))
(COND
((NOT BEFOREFLG)
(for TYPE in DATATYPES as X on (fetch DATACOUNTERS of STATS) do (RPLACA X (BOXCOUNT TYPE)))
(CLOCK0 (fetch ELAPSEDTIME of STATS])
(COPYTIMESTATS
[LAMBDA (REFSTATS STATS) (* bvm: "28-MAR-82 21:57")
(replace SWAPWAITTIME of STATS with (fetch SWAPWAITTIME of REFSTATS))
(replace KEYBOARDWAITTIME of STATS with (fetch KEYBOARDWAITTIME of REFSTATS))
(replace GCTIME of STATS with (fetch GCTIME of REFSTATS))
(replace PAGEFAULTS of STATS with (fetah PAGEFAULTS of REFSTATS))
(replace SWAPWRITES of STATS with (fetch SWAPWRITES of REFSTATS))
(replace TOTALTIME of STATS with (fetch TOTALTIME of REFSTATS))
(replace STARTTIME of STATS with (fetch STARTTIME of REFSTATS))
(replace DISKIOTIME of STATS with (fetch DISKIOTIME of REFSTATS))
(replace NETIOTIME of STATS with (fetch NETIOTIME of REFSTATS))
(replace DISKIOOPS of STATS with (fetch DISKIOOPS of REFSTATS))
(replace NETIOOPS of STATS with (fetch NETIOOPS of REFSTATS])
(CREATEMISCSTATS
[LAMBDA (DATATYPES TIMEBLOCKFLG) (* bvm: " 6-OCT-82 15:28")
(* creates a stats object for the types datatypes.)
(create STATSOBJECT
ELAPSEDTIME ←(CLOCK 0)
TIMEBLOCK ←(AND TIMEBLOCKFLG (create MISCSTATS))
DATACOUNTERS ←(APPEND DATATYPES)
DATATYPES ← DATATYPES])
(DIFFMISCSTATS
[LAMBDA (BEFORE AFTER DIFFERENCES) (* bvm: " 6-OCT-82 15:30")
(* puts the differences between two stats objects in a
third stats object.)
[for D on (fetch DATACOUNTERS of DIFFERENCES) as B in (fetch DATACOUNTERS of BEFORE)
as A in (fetch DATACOUNTERS of AFTER) as TYPE in (fetch DATATYPES of DIFFERENCES)
bind (LARGECNT ← 0)
LARGECNTTAIL
do (COND
((EQ TYPE (QUOTE FIXP))
(SETQ LARGECNTTAIL D)))
(OR (SMALLP (COND
(LARGECNTTAIL B)
(T A)))
(add LARGECNT 2))
(* The BOXCOUNT in COPYMISCSTATS for this datatype came out large, and thus did 2 number boxes
(one to fetch main count, one to add in aux cnt), counted in the stats period)
(FRPLACA D (IDIFFERENCE A B))
finally (COND
((AND (IGREATERP LARGECNT 0)
LARGECNTTAIL) (* Adjust FIXP count to take into account all BOXCOUNT's
that used up largep's)
(FRPLACA LARGECNTTAIL (IDIFFERENCE (CAR LARGECNTTAIL)
LARGECNT]
(replace ELAPSEDTIME of DIFFERENCES with (IDIFFERENCE (fetch ELAPSEDTIME of AFTER)
(fetch ELAPSEDTIME of BEFORE)))
(AND (fetch TIMEBLOCK of BEFORE)
(fetch TIMEBLOCK of AFTER)
(fetch TIMEBLOCK of DIFFERENCES)
(DIFFTIMESTATS (fetch TIMEBLOCK of BEFORE)
(fetch TIMEBLOCK of AFTER)
(fetch TIMEBLOCK of DIFFERENCES)))
DIFFERENCES])
(DIFFTIMESTATS
[LAMBDA (BEFOREBLOCK AFTERBLOCK DIFFERENCESBLOCK) (* bvm: "28-MAR-82 21:58")
(* copies the difference between two stats blocks into a
third stats block.)
(replace SWAPWAITTIME of DIFFERENCESBLOCK with (IDIFFERENCE (fetch SWAPWAITTIME of AFTERBLOCK)
(fetch SWAPWAITTIME of BEFOREBLOCK)))
(replace KEYBOARDWAITTIME of DIFFERENCESBLOCK with (IDIFFERENCE (fetch KEYBOARDWAITTIME
of AFTERBLOCK)
(fetch KEYBOARDWAITTIME
of BEFOREBLOCK)))
(replace GCTIME of DIFFERENCESBLOCK with (IDIFFERENCE (fetch GCTIME of AFTERBLOCK)
(fetch GCTIME of BEFOREBLOCK)))
(replace PAGEFAULTS of DIFFERENCESBLOCK with (IDIFFERENCE (fetch PAGEFAULTS of AFTERBLOCK)
(fetch PAGEFAULTS of BEFOREBLOCK)))
(replace SWAPWRITES of DIFFERENCESBLOCK with (IDIFFERENCE (fetch SWAPWRITES of AFTERBLOCK)
(fetch SWAPWRITES of BEFOREBLOCK)))
(replace TOTALTIME of DIFFERENCESBLOCK with (IDIFFERENCE (fetch TOTALTIME of AFTERBLOCK)
(fetch TOTALTIME of BEFOREBLOCK)))
(replace STARTTIME of DIFFERENCESBLOCK with (IDIFFERENCE (fetch STARTTIME of AFTERBLOCK)
(fetch STARTTIME of BEFOREBLOCK)))
(replace DISKIOTIME of DIFFERENCESBLOCK with (IDIFFERENCE (fetch DISKIOTIME of AFTERBLOCK)
(fetch DISKIOTIME of BEFOREBLOCK)))
(replace NETIOTIME of DIFFERENCESBLOCK with (IDIFFERENCE (fetch NETIOTIME of AFTERBLOCK)
(fetch NETIOTIME of BEFOREBLOCK)))
(replace DISKIOOPS of DIFFERENCESBLOCK with (IDIFFERENCE (fetch DISKIOOPS of AFTERBLOCK)
(fetch DISKIOOPS of BEFOREBLOCK)))
(replace NETIOOPS of DIFFERENCESBLOCK with (IDIFFERENCE (fetch NETIOOPS of AFTERBLOCK)
(fetch NETIOOPS of BEFOREBLOCK)))
DIFFERENCESBLOCK])
(PRINTMISCSTATS
[LAMBDA (STATS DATATYPES) (* bvm: " 6-JAN-83 18:13")
(* prints the fields of MISCSTATS)
[PROG ((CPUTIME (fetch ELAPSEDTIME of STATS)))
(PRINTMISCSTATSITEM "Elapsed Time" CPUTIME T)
(COND
((fetch TIMEBLOCK of STATS) (* printout time stats)
(PROG ((STATSBLOCK (fetch TIMEBLOCK of STATS))
MSECS)
[SETQ CPUTIME (IDIFFERENCE CPUTIME (SETQ MSECS (fetch SWAPWAITTIME of STATSBLOCK]
(PRINTMISCSTATSITEM "SWAP time" MSECS T)
[SETQ CPUTIME (IDIFFERENCE CPUTIME (SETQ MSECS (fetch KEYBOARDWAITTIME
of STATSBLOCK]
(PRINTMISCSTATSITEM "KEYWAIT time" MSECS T)
[SETQ CPUTIME (IDIFFERENCE CPUTIME (SETQ MSECS (fetch GCTIME of STATSBLOCK]
(PRINTMISCSTATSITEM "GC time" MSECS T)
[SETQ CPUTIME (IDIFFERENCE CPUTIME (SETQ MSECS (fetch DISKIOTIME of STATSBLOCK]
(PRINTMISCSTATSITEM "Disk i/o time" MSECS T)
(PRINTMISCSTATSITEM "CPU Time" CPUTIME T)
(PRINTMISCSTATSITEM (QUOTE PAGEFAULTS)
(fetch PAGEFAULTS of STATSBLOCK))
(PRINTMISCSTATSITEM (QUOTE SWAPWRITES)
(fetch SWAPWRITES of STATSBLOCK))
(PRINTMISCSTATSITEM (QUOTE DISKOPS)
(fetch DISKOPS of STATSBLOCK))
(PRINTMISCSTATSITEM (QUOTE NETIOTIME)
(fetch NETIOTIME of STATSBLOCK)
T)
(PRINTMISCSTATSITEM (QUOTE NETIOOPS)
(fetch NETIOOPS of STATSBLOCK]
(* construct a list of the elements that will fit on one
line.)
(bind PRINTABLES RESULT COL←0
(LINELENGTH ←(LINELENGTH)) for DT in DATATYPES as DIF in (fetch DATACOUNTERS of STATS)
unless (EQ DIF 0)
do [COND
((IGREATERP (SETQ COL (IPLUS COL (NCHARS DT)))
LINELENGTH) (* line break)
(SETQ PRINTABLES (NCONC1 PRINTABLES (DREVERSE RESULT)))
(SETQ RESULT)
(SETQ COL (NCHARS DT]
(SETQ RESULT (CONS (CONS (add COL 1)
(CONS DT DIF))
RESULT))
finally [COND
(RESULT (SETQ PRINTABLES (NCONC1 PRINTABLES (DREVERSE RESULT]
(for LINE in PRINTABLES
do (for PR in LINE
do (LISPXPRIN1 (CADR PR)
T) (* Print datatype names)
(LISPXTAB (CAR PR)
NIL T))
(LISPXTERPRI T)
(for PR in LINE
do (LISPXPRIN2 (CDDR PR)
T) (* Print amount used)
(LISPXTAB (CAR PR)
NIL T))
(LISPXTERPRI T])
(PRINTMISCSTATSITEM
[LAMBDA (STR NUM TIMEFLG) (* bvm: "26-MAR-82 16:25")
(COND
((NOT (EQP NUM 0))
(LISPXPRIN1 STR T)
(LISPXPRIN1 " = ")
(COND
(TIMEFLG (LISPXTAB 16 0 T)
(PRINTNUM (QUOTE (FLOAT 9 NIL NIL NIL 3))
(SETQ NUM (FQUOTIENT NUM 1000.0))
T) (* 3 significant digits)
(LISPXPRIN2 NUM T T T) (* Record on history without printing)
(LISPXPRIN1 " seconds" T))
(T (LISPXPRIN2 NUM T)))
(LISPXTERPRI T])
)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(RECORD STATSOBJECT (ELAPSEDTIME TIMEBLOCK DATACOUNTERS . DATATYPES))
]
)
(DEFINEQ
(PERIODICALLYRECLAIM
[LAMBDA NIL (* bvm: "21-JUL-83 16:49")
(DECLARE (GLOBALVARS \RECLAIM.COUNTDOWN \LASTUSERACTION RECLAIMWAIT \LASTRECLAIM))
(PROG (LU)
(if (AND \RECLAIM.COUNTDOWN (\SECONDSCLOCKGREATERP \LASTUSERACTION RECLAIMWAIT)
(\SECONDSCLOCKGREATERP \LASTRECLAIM RECLAIMWAIT))
then (RECLAIM)
(\DAYTIME0 \LASTRECLAIM])
)
(RPAQ? RECLAIMWAIT 4)
(RPAQ? \LASTRECLAIM (\DAYTIME0 (NCREATE (QUOTE FIXP))))
(DECLARE: DONTEVAL@LOAD DOCOPY
(APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM)
)
(DEFINEQ
(APROPOS
(LAMBDA (STRING ALLFLG QUIETFLG) (* JonL " 7-Feb-84 16:34")
(PROG ((FILTERFN (AND ALLFLG (NEQ ALLFLG T)
(FNTYP ALLFLG)
ALLFLG))
(STKPOS (STKNTH -1 (QUOTE APROPOS)))
(DISPLAYSTREAM (DISPLAYSTREAMP (\OUTSTREAMARG T)))
(BLOCKCOUNT 1)
RESULT)
(DECLARE (SPECVARS RESULT STKPOS FILTERFN DISPLAYSTREAM))
(RESETFORM (PRINTLEVEL 3 5)
(MAPATOMS
(FUNCTION (LAMBDA (ATOM)
(PROG (VAL LOOKEDUP PROPL MARGSET)
(DECLARE (USEDFREE RESULT STKPOS FILTERFN))
(if (ZEROP (IMOD (add BLOCKCOUNT 1)
32))
then (SETQ BLOCKCOUNT 1)
(BLOCK))
(if (if FILTERFN
then (AND (STRPOS STRING ATOM)
(APPLY* FILTERFN ATOM))
else (AND (OR ALLFLG (DEFINEDP ATOM)
(GETPROPLIST ATOM)
(NEQ (SETQ VAL (EVALV ATOM STKPOS))
(PROG1 (QUOTE NOBIND)
(SETQ LOOKEDUP T))))
(STRPOS STRING ATOM)
(OR ALLFLG (AND (NOT (GENSYM? ATOM))
(NEQ (CHCON1 ATOM)
(CHARCODE \))
(NOT (\SUBFNDEF ATOM))))))
then (if QUIETFLG
then (push RESULT ATOM)
else (PRIN2 ATOM T)
(SPACES 1 T)
(SETQ PROPL (GETPROPLIST ATOM))
(if (OR (NEQ (if LOOKEDUP
then VAL
else (SETQ VAL (EVALV ATOM STKPOS)))
(QUOTE NOBIND))
PROPL
(DEFINEDP ATOM))
then (if (DEFINEDP ATOM)
then (TAB 16 NIL T)
(PRIN1 "- " T)
(OR (NULL DISPLAYSTREAM)
(SETQ MARGSET
(DSPXPOSITION NIL
DISPLAYSTREAM)))
(PRIN1 "Function arglist: " T)
(if DISPLAYSTREAM
then
(RESETFORM
(\APROPOS.MARGINSET MARGSET
DISPLAYSTREAM)
(PRIN2 (ARGLIST ATOM)))
else (PRIN2 (ARGLIST ATOM))))
(if (NEQ (if LOOKEDUP
then VAL
else (SETQ VAL (EVALV ATOM
STKPOS)))
(QUOTE NOBIND))
then (TAB 16 NIL T)
(PRIN1 "- " T)
(OR (NULL DISPLAYSTREAM)
MARGSET
(SETQ MARGSET
(DSPXPOSITION NIL
DISPLAYSTREAM)))
(PRIN1 "Variable value: " T)
(if DISPLAYSTREAM
then (RESETFORM (
\APROPOS.MARGINSET MARGSET DISPLAYSTREAM)
(PRIN2 VAL))
else (PRIN2 VAL)))
(if (SETQ VAL (GETPROPLIST ATOM))
then (TAB 16 NIL T)
(PRIN1 "- " T)
(OR (NULL DISPLAYSTREAM)
MARGSET
(SETQ MARGSET
(DSPXPOSITION NIL
DISPLAYSTREAM)))
(PRIN1 "Property list: " T)
(if DISPLAYSTREAM
then (RESETFORM (
\APROPOS.MARGINSET MARGSET DISPLAYSTREAM)
(PRIN2 VAL))
else (PRIN2 VAL))))
(TERPRI T))))))))
(RETURN RESULT))))
(\APROPOS.MARGINSET
[LAMBDA (X DISPLAYSTREAM)
(if (AND (LISTP X)
(NULL DISPLAYSTREAM))
then (SETQ DISPLAYSTREAM (CADR X))
(SETQ X (CAR X)))
(LIST (DSPLEFTMARGIN X DISPLAYSTREAM)
DISPLAYSTREAM])
)
(DEFINEQ
(\DIRTYBACKGROUND
[LAMBDA NIL (* lmm "14-AUG-83 16:08")
(DECLARE (GLOBALVARS SAVEVMMAX \LASTUSERACTION SAVEVMWAIT SAVINGCURSOR \DIRTYPAGEHINT))
(COND
((AND BACKGROUNDPAGEFREQ (ILEQ (add BACKGROUNDPAGECNT -1)
0))
(\WRITEDIRTYPAGE BACKGROUNDPAGEMIN)
(SETQ BACKGROUNDPAGECNT BACKGROUNDPAGEFREQ])
(\SAVEVMBACKGROUND
[LAMBDA NIL (* bvm: " 7-Dec-83 15:22")
(COND
((AND (ILESSP \DIRTYPAGEHINT SAVEVMMAX)
(NEQ (fetch (IFPAGE Key) of \InterfacePage)
\IFPValidKey)
(FIXP SAVEVMWAIT)
(\SECONDSCLOCKGREATERP \LASTUSERACTION SAVEVMWAIT))
(COND
((ILESSP (SETQ \DIRTYPAGEHINT (\COUNTREALPAGES (QUOTE DIRTY)))
SAVEVMMAX) (* Recalculate the hint before deciding it's okay)
(RESETLST (AND SAVINGCURSOR (GETD (QUOTE CURSOR))
(RESETSAVE (CURSOR SAVINGCURSOR)))
(SAVEVM])
(COPYVM
[LAMBDA (FILE) (* bvm: "12-Jan-84 12:07")
(DECLARE (GLOBALVARS \VMEM.INHIBIT.WRITE))
(RESETVARS ((\VMEM.INHIBIT.WRITE T))
(RETURN (COND
((EQ (fetch (IFPAGE Key) of \InterfacePage)
\IFPValidKey)
(\COPYSYS FILE NIL T))
(T "Can't--virtual memory has been written to"])
)
(RPAQ? BACKGROUNDPAGEMIN 40)
(RPAQ? BACKGROUNDPAGECNT 0)
(RPAQ? BACKGROUNDPAGEFREQ 4)
(RPAQ? SAVINGCURSOR )
(RPAQ? SAVEVMMAX 600)
(RPAQ? SAVEVMWAIT 300)
(ADDTOVAR BACKGROUNDFNS \DIRTYBACKGROUND)
(ADDTOVAR TTYBACKGROUNDFNS \SAVEVMBACKGROUND)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS BACKGROUNDPAGEMIN BACKGROUNDPAGEFREQ BACKGROUNDPAGECNT)
)
(* Setting the time)
(DEFINEQ
(SETTIME
[LAMBDA (DT) (* bvm: "31-Dec-00 16:06")
(PROG [(IDT (COND
[DT (LISP.TO.ALTO.DATE (OR (IDATE DT)
(ERROR "Invalid date" DT]
(T (NETDAYTIME0]
RETRY
[COND
((NOT IDT)
(printout T "Enter date and time as string in double quotes: ")
(COND
([SETQ IDT (IDATE (OR (SETQ DT (READ T T))
(RETURN "time not set"]
(SETQ IDT (LISP.TO.ALTO.DATE IDT)))
(T (printout T "Sorry, couldn't parse that" T)
(GO RETRY]
(\SETDAYTIME0 (COND
((SMALLP IDT)
(create FIXP
HINUM ← 0
LONUM ← IDT))
(T IDT)))
(RETURN (DATE])
)
(* Bells and whistles)
(DEFINEQ
(RINGBELLS
(LAMBDA (N) (* JonL "18-Feb-84 10:02")
(OR (FIXP N)
(SETQ N 1))
(SELECTQ (MACHINETYPE)
(DANDELION (PROG ((L1 (QUOTE ((1000 . 1000)
(800 . 1000)
(600 . 1000)
(500 . 1000)
(400 . 1000)
(NIL . 500)
(440 . 1000)
(484 . 1000)
(540 . 1000)
(600 . 1000))))
(L2 (QUOTE ((2000 . 1000)
(1600 . 1000)
(1200 . 1000)
(1000 . 1000)
(800 . 1000)
(NIL . 500)
(880 . 1000)
(968 . 1000)
(1080 . 1000)
(1188 . 1000)))))
(to N
do (PLAYTUNE L1)
(FLASHWINDOW NIL NIL 100)
(PLAYTUNE L2))))
(FLASHWINDOW NIL N))))
(FLASHWINDOW
(LAMBDA (WIN? N FLASHINTERVAL) (* JonL "18-Feb-84 10:02")
(* This is an "attention getting" action.)
(OR (FIXP N)
(SETQ N 1))
(OR (FIXP FLASHINTERVAL)
(SETQ FLASHINTERVAL 200))
(if (WINDOWP WIN?)
then (SETQ WIN? (GETSTREAM WIN?)))
(GLOBALRESOURCE (\PlayTimer)
(for I to N bind (WHOLEP ←(NOT (DISPLAYSTREAMP WIN?)))
COLORP
first (if WHOLEP
then (SETQ COLORP (NULL (VIDEOCOLOR))))
do (UNINTERRUPTABLY (* Open-coded "during" loops so that no one else can
sneak in and steal cycles)
(if WHOLEP
then (* Flash the whole screen)
(VIDEOCOLOR (PROG1 (VIDEOCOLOR COLORP)
(\DISMISS.WITHOUT.BLOCKING FLASHINTERVAL
\PlayTimer)))
else (* Although VIDEOCOLOR is nearly instantaneous, INVERTW
may require a time approaching the interval time and
thus this path could be much longer)
(INVERTW WIN?)
(\DISMISS.WITHOUT.BLOCKING FLASHINTERVAL \PlayTimer)
(INVERTW WIN?)))
(if (NEQ I N)
then (BLOCK 250))))))
(\DISMISS.WITHOUT.BLOCKING
(LAMBDA (DURATION TIMER? timerUnits) (* JonL "18-Feb-84 09:48")
((LAMBDA (\DurationLimit)
(DECLARE (LOCALVARS \DurationLimit))
(until (TIMEREXPIRED? \DurationLimit timerUnits) do NIL))
(SETUPTIMER DURATION TIMER? timerUnits))))
(PLAYTUNE
(LAMBDA (Frequency/Duration.pairlist) (* JonL "22-SEP-83 15:25")
(* Frequency/Duration.pairlist is a list of Frequency/Duration pairs. The durations are in TICKS which means that
a "tune" must be re-scaled between the DLion and the other machines.)
(RESETLST (RESETSAVE NIL (QUOTE (BEEPOFF)))
(GLOBALRESOURCE (\PlayTimer)
(for X in Frequency/Duration.pairlist
do (if (CAR X)
then (BEEPON (CAR X))
else (BEEPOFF))
(forDuration (CDR X) timerUnits (QUOTE TICKS) usingTimer
\PlayTimer
do (* Just "busy-wait" to pass the time)
NIL))))
T))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(PUTDEF (QUOTE \PlayTimer)
(QUOTE GLOBALRESOURCES)
(QUOTE (SETUPTIMER 0)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \PlayTimer)
)
(RPAQQ \PlayTimer NIL)
(DECLARE: DONTEVAL@LOAD DOCOPY
(* Overrides definition in the shared MISC)
(MOVD (QUOTE RINGBELLS)
(QUOTE PRINTBELLS))
)
(* These are optimizations for Interlisp-D only)
(DEFINEQ
(ATOMHASH#PROBES
(LAMBDA (STRING) (* JonL "12-Dec-83 06:21")
(PROG (BASE OFFST LEN HINDEX)
(if (LITATOM STRING)
then (SETQ BASE (fetch (LITATOM PNAMEBASE) of STRING))
(SETQ OFFST 1)
(SETQ LEN (fetch (LITATOM PNAMELENGTH) of STRING))
else (SETQ BASE (ffetch (STRINGP BASE) of (SETQ STRING (MKSTRING STRING))))
(SETQ OFFST (ffetch (STRINGP OFFST) of STRING))
(SETQ LEN (ffetch (STRINGP LENGTH) of STRING))
(OR (ILEQ LEN \PNAMELIMIT)
(RETURN)))
(if (EQ LEN 1)
then (RETURN (if (OR (IGREATERP (\GETBASEBYTE BASE OFFST)
(CHARCODE 9))
(ILESSP (\GETBASEBYTE BASE OFFST)
(CHARCODE 0)))
then 0)))
(SETQ HINDEX (OR (\ATOM.FIRSTHASHINDEX BASE OFFST LEN)
(RETURN)))
(RETURN (for PROBES from 1 bind HTENT ATOMINDEX until (ZEROP (SETQ HTENT (\GETBASE
\AtomHashTable
HINDEX)))
do (SETQ ATOMINDEX (\ADDBASE \ATOMSPACE (SUB1 HTENT)))
(if (AND (EQ LEN (fetch (LITATOM PNAMELENGTH) of ATOMINDEX))
(NOT (bind (NBASE ←(fetch (LITATOM PNAMEBASE) of ATOMINDEX))
find I to LEN as J from OFFST
suchthat (NEQ (\GETBASEBYTE NBASE I)
(\GETBASEBYTE BASE J)))))
then (* So these two atom have the same pname characters)
(RETURN PROBES))
(SETQ HINDEX (LOGAND (IPLUS HINDEX \HashInc)
\AtomHTmask)) (* \HashInc is relatively prime to \AtomHTmask so we
will cycle thru all slots)
)))))
(\ATOM.FIRSTHASHINDEX
(LAMBDA (BASE OFFST LEN) (* JonL "12-Dec-83 06:25")
(if (ZEROP LEN)
then 0
else (for I from 0
bind (HINDEX ← 0)
(NUM? ← T)
(NDOTS ← 0)
CHAR TEM
while (ILESSP I LEN)
do (* Mash down the string into a 15-bit number, to use as
the initial probe index)
(SETQ CHAR (\GETBASEBYTE BASE (IPLUS OFFST I)))
(if (OR (IGREATERP CHAR (CHARCODE 9))
(ILESSP CHAR (CHARCODE 0)))
then (SETQ NUM?)
elseif (AND NUM? (EQ CHAR (CHARCODE %.)))
then (* A number is allowed up to one decimal point)
(if (ILESSP 1 (add NDOTS 1))
then (SETQ NUM?)))
(SETQ TEM (IPLUS HINDEX (LLSH (LOADBYTE HINDEX 0 12)
2)))
(SETQ HINDEX (LOGAND (IPLUS (LOGAND TEM \AtomHTmask)
(LLSH (LOADBYTE TEM 0 7)
8)
CHAR)
\AtomHTmask))
finally (RETURN (AND (NULL NUM?)
HINDEX))))))
)
(* Overrides definition found on MISC)
(DEFINEQ
(GENSYM?
(LAMBDA (X ON\OFF) (* JonL " 9-Dec-83 05:48")
(if (OR (NOT (LITATOM X))
(NULL X)
(EQ X T))
then (if (NULL ON\OFF)
then NIL
elseif (LITATOM X)
then (\ILLEGAL.ARG X))
else (PROG1 (fetch (LITATOM PROPCELL GENSYMP) of X)
(if ON\OFF
then (replace (LITATOM PROPCELL GENSYMP) of X with (SELECTQ ON\OFF
((OFF)
NIL)
((ON T)
T)
(\ILLEGAL.ARG
ON\OFF))))))))
)
(* functions for turning the display off.)
(DEFINEQ
(DISPLAYDOWN
[LAMBDA (FORM NSCANLINES) (* rrb "27-MAR-82 12:23")
(* evaluates form with the number of scan lines set
down.)
(RESETFORM (SETDISPLAYHEIGHT (OR (SMALLP NSCANLINES)
0))
(EVAL FORM])
(SETDISPLAYHEIGHT
[LAMBDA (NSCANLINES)
(DECLARE (GLOBALVARS \DisplayStarted \EM.DISPLAYHEAD)) (* bvm: " 5-JAN-83 18:48")
(* sets the number of scan lines to be displayed.)
(* returns previous setting.)
(* the number of lines in the dcb is 1/2 of the total.
High bit is on to indicate long pointers.)
(OR \DisplayStarted (HELP "Display must be initialized."))
(AND \EM.DISPLAYHEAD (PROG [(MAGICADDR (EMPOINTER (IPLUS (\GETBASE \EM.DISPLAYHEAD 0)
3]
(RETURN (PROG1 (ITIMES [LOGAND (\GETBASE MAGICADDR 0)
(CONSTANT (SUB1 (EXPT 2 (SUB1
BITSPERWORD]
2) (* number of dcb lines may need to be even.)
(COND
(NSCANLINES (COND
[(SMALLP NSCANLINES)
(COND
((IGREATERP 0 NSCANLINES)
(\ILLEGAL.ARG NSCANLINES))
((IGREATERP NSCANLINES SCREENHEIGHT)
(SETQ NSCANLINES SCREENHEIGHT]
((EQ NSCANLINES T)
(SETQ NSCANLINES SCREENHEIGHT))
(T (\ILLEGAL.ARG NSCANLINES)))
(\PUTBASE
MAGICADDR 0
(LOGOR (ITIMES (LRSH NSCANLINES 2)
2)
(CONSTANT (EXPT 2 (SUB1
BITSPERWORD])
(VIDEORATE
[LAMBDA (TYPE) (* bvm: " 7-NOV-83 17:28")
(DECLARE (GLOBALVARS \VIDEORATE))
(PROG1 \VIDEORATE (* Return old setting)
(AND TYPE (SETQ \VIDEORATE (SELECTC \MACHINETYPE
(\DOLPHIN (SELECTQ TYPE
((NORMAL 77)
(\DSPRATE 9 0 0)
(QUOTE NORMAL))
((TAPE 60)
(\DSPRATE 139 0 0)
(QUOTE TAPE))
(\ILLEGAL.ARG TYPE)))
(\DORADO (SELECTQ TYPE
((NORMAL 77)
(\DSPRATE 18 14 430)
(QUOTE NORMAL))
((TAPE 60)
(\DSPRATE 18 14 560)
(QUOTE TAPE))
((PHILLIPS TAPEP)
(\DSPRATE 58 25 520)
(QUOTE PHILLIPS))
(\ILLEGAL.ARG TYPE)))
(\DANDELION (SELECTQ TYPE
((NORMAL 77)
(\DEVICE.OUTPUT 14 7)
(QUOTE NORMAL))
((TAPE 60)
(\DEVICE.OUTPUT 142 7)
(QUOTE TAPE))
(\ILLEGAL.ARG TYPE)))
(QUOTE NORMAL])
)
(RPAQ? \VIDEORATE (QUOTE NORMAL))
(DECLARE: DONTEVAL@LOAD DOCOPY
(ADDTOVAR BREAKRESETFORMS (SETDISPLAYHEIGHT T))
(ADDTOVAR RESETFORMS (SETDISPLAYHEIGHT T))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ #EOLCHARS 1)
(OR (LISTP (EVALV (QUOTE EDITCHARACTERS)))
(RPAQ EDITCHARACTERS (QUOTE (J X Z Y N))))
(ADDTOVAR POSTGREETFORMS (CNDIR))
(ADDTOVAR LISPUSERSDIRECTORIES )
)
(PUTPROPS BAKTRACELST VARTYPE ALIST)
(ADDTOVAR BREAKMACROS (BT (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
0 T))
(BTV (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
1 T))
(BTVPP (PROG ((SYSPRETTYFLG T))
(BAKTRACE LASTPOS NIL (CONS (QUOTE DUMMYFRAMEP)
(BREAKREAD (QUOTE LINE)))
1 T)))
(BT! (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
0 T)))
(ADDTOVAR BAKTRACELST (EVAL (**BREAK** LISPX ERRORSET BREAK1A BREAK1)
(**TOP** LISPX ERRORSET EVALQT T)
(**EDITOR** ((MAPCAR APPLY)
(ERRORSET LISPX))
ERRORSET ERRORSET ERRORSET EDITL1 EDITL0 ERRORSET
((ERRORSET ERRORSET ERRORSET EDITL1 EDITL0 ERRORSET)
-)
EDITL ERRORSET ERRORSET EDITE ((EDITF)
(EDITV)
(EDITP)
-))
(**USEREXEC** ERRORSET LISPX ERRORSET ERRORSET USEREXEC))
(APPLY (**BREAK** LISPX ERRORSET BREAK1A BREAK1)
(**TOP** LISPX ERRORSET EVALQT T)
(**EDITOR** LISPX ERRORSET ERRORSET ERRORSET EDITL1 EDITL0 ERRORSET
((ERRORSET ERRORSET ERRORSET EDITL1 EDITL0 ERRORSET)
-)
EDITL ERRORSET ERRORSET EDITE ((EDITF)
(EDITV)
(EDITP)
-))
(**USEREXEC** LISPX ERRORSET ERRORSET USEREXEC)))
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ? CLEANUPOPTIONS (QUOTE (RC)))
)
(DEFINEQ
(DOAROUNDEXITFORMS
[LAMBDA (EVENT) (* bvm: "16-Dec-83 15:39")
(* For backward compatibility, handle the xxxFORMS that
used to be in advise around LOGOUT, SYSOUT, MAKESYS)
(for $$FORM in (SELECTQ EVENT
(BEFORELOGOUT BEFORELOGOUTFORMS)
(AFTERLOGOUT AFTERLOGOUTFORMS)
(BEFORESYSOUT BEFORESYSOUTFORMS)
(AFTERSYSOUT AFTERSYSOUTFORMS)
(BEFOREMAKESYS BEFOREMAKESYSFORMS)
NIL)
do (ERSETQ (\EVAL $$FORM])
)
(ADDTOVAR AROUNDEXITFNS DOAROUNDEXITFORMS)
(ADDTOVAR BEFORELOGOUTFORMS )
(ADDTOVAR AFTERLOGOUTFORMS )
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ? ADVISEDFNS )
)
(* from FASTARRAYS)
(DEFINEQ
(POINTERARRAY
[LAMBDA (N INIT) (* lmm " 4-DEC-80 16:58")
(ARRAY N (QUOTE POINTER)
INIT 0])
(WORDARRAY
[LAMBDA (N) (* lmm " 4-DEC-80 16:58")
(ARRAY N (QUOTE SMALLPOSP)
0 0])
(FIXPARRAY
[LAMBDA (N) (* lmm " 4-DEC-80 16:58")
(ARRAY N (QUOTE FIXP)
0 0])
)
(MAPC (QUOTE ((ELT FASTELT FASTELTN FASTELTW)
(SETA FASTSETA FASTSETAN FASTSETAW)
(GETHASH IGETHASH)
(PUTHASH IPUTHASH)))
(FUNCTION (LAMBDA (X)
(MAPC (CDR X)
(FUNCTION (LAMBDA (Y)
(MOVD? (CAR X)
Y)))))))
(* Versions etc)
(DEFINEQ
(REALMEMORYSIZE
[LAMBDA NIL (* bvm: "19-JAN-83 17:06")
(fetch NRealPages of \InterfacePage])
(LISPVERSION
[LAMBDA NIL (* bvm: "19-JAN-83 17:07")
(fetch LVersion of \InterfacePage])
(MICROCODEVERSION
[LAMBDA NIL (* bvm: "19-JAN-83 17:07")
(fetch RVersion of \InterfacePage])
(BCPLVERSION
[LAMBDA NIL (* bvm: "19-JAN-83 17:07")
(fetch BVersion of \InterfacePage])
(REQUIREVERSION
[LAMBDA (LISP MICROCODE BCPL) (* bvm: "19-JAN-83 17:15")
(PROG (TYPE NEEDED)
(RETURN (COND
([SETQ TYPE (OR (AND LISP (LESSP (fetch LVersion of \InterfacePage)
(SETQ NEEDED LISP))
(QUOTE LISP))
(AND MICROCODE (LESSP (fetch RVersion of \InterfacePage)
(SETQ NEEDED MICROCODE))
(QUOTE MICROCODE))
(AND BCPL (LESSP (fetch BVersion of \InterfacePage)
(SETQ NEEDED BCPL))
(QUOTE BCPL]
(ERROR (CONCAT "This " TYPE
" version is too old. The minimum version required is ")
NEEDED)
NIL)
(T T])
)
(* Misc ops)
(DEFINEQ
(READPRINTERPORT
[LAMBDA NIL (* bvm: "18-JAN-83 18:06")
((OPCODES READPRINTERPORT])
(WRITEPRINTERPORT
[LAMBDA (DATUM) (* bvm: "18-JAN-83 18:06")
((OPCODES WRITEPRINTERPORT)
DATUM])
(\MISC1.UFN
[LAMBDA (ARG ALPHA) (* bvm: "18-JAN-83 18:07")
(RAID "Unimplemented MISC1 op" ALPHA])
(\MISC2.UFN
[LAMBDA (ARG1 ARG2 ALPHA) (* bvm: "18-JAN-83 18:07")
(RAID "Unimplemented MISC2 op" ALPHA])
)
(RPAQQ PRINTINGCOMS ((FNS EMPRESS CONVERT.FILE.TO.TYPE.FOR.PRINTER HARDCOPYW PRINTER.BITMAPFILE
PRINTER.BITMAPSCALE PRINTER.RESET.DELETE PRINTER.SCRATCH.FILE PRINTERTYPE
LISTFILES1 SEND.FILE.TO.PRINTER CAN.PRINT.DIRECTLY PRINTERPROP
PRINTFILEPROP PRINTERSTATUS PRINTFILETYPE)
(FNS LISTFILES)
(P (* for backward compatibility)
(MOVD? (QUOTE NILL)
(QUOTE PRINTERMODE)))
(INITVARS (DEFAULTPRINTERTYPE (QUOTE PRESS)))))
(DEFINEQ
(EMPRESS
[LAMBDA (FILE #COPIES HOST HEADING #SIDES PRINTOPTIONS) (* lmm " 3-OCT-83 20:21")
(SEND.FILE.TO.PRINTER FILE HOST (NCONC (COND
(HEADING (LIST (QUOTE HEADING)
HEADING)))
(COND
(#COPIES (LIST (QUOTE #COPIES)
#COPIES)))
(COND
(#SIDES (LIST (QUOTE #SIDES)
#SIDES)))
PRINTOPTIONS])
(CONVERT.FILE.TO.TYPE.FOR.PRINTER
[LAMBDA (FILE FILETYPE PRINTERTYPE HEADING) (* rmk: "11-OCT-83 13:03")
(SETQ FILETYPE (OR FILETYPE (QUOTE TEXT)))
(PRINTER.RESET.DELETE (APPLY* (OR (LISTGET (PRINTERPROP PRINTERTYPE (QUOTE CONVERSION))
FILETYPE)
(for CANPRINT in (PRINTERPROP PRINTERTYPE (QUOTE CANPRINT))
bind CONVERTER when (SETQ CONVERTER
(LISTGET (PRINTFILEPROP CANPRINT
(QUOTE
CONVERSION))
FILETYPE))
do (RETURN CONVERTER))
(ERROR (CONCAT "Can't convert a " FILETYPE " for a "
PRINTERTYPE " printer")
FILE))
FILE
(PRINTER.SCRATCH.FILE FILE PRINTERTYPE)
NIL HEADING])
(HARDCOPYW
[LAMBDA (WINDOW/BITMAP/REGION FILE HOST SCALEFACTOR ROTATION)
(* lmm " 4-OCT-83 02:02")
(* makes a hard copy of a window)
(* WINDOW/BITMAP/REGION can be a WINDOW, a REGION, a
BITMAP, or NIL = select region)
(* If FILE supplied, output goes there.
If HOST supplied, IT is printed.
If neither FILE nor HOST supplied, default is to print)
(PROG ((BITMAP (SCREENBITMAP))
REGION
(PRINTHOST HOST))
[SETQ REGION
(COND
((WINDOWP WINDOW/BITMAP/REGION)
(COND
((OPENWP WINDOW/BITMAP/REGION)
(TOTOPW WINDOW/BITMAP/REGION)
(WINDOWPROP WINDOW/BITMAP/REGION (QUOTE REGION)))
(T (SETQ BITMAP (WINDOWPROP WINDOW/BITMAP/REGION (QUOTE IMAGECOVERED)))
NIL)))
((BITMAPP WINDOW/BITMAP/REGION)
(SETQ BITMAP WINDOW/BITMAP/REGION)
NIL)
((type? REGION WINDOW/BITMAP/REGION)
WINDOW/BITMAP/REGION)
(T (PROGN (\SETCURSORPOSITION 0 SCREENHEIGHT)
(GETREGION NIL NIL
(create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ← SCREENWIDTH
HEIGHT ← SCREENHEIGHT]
[COND
(PRINTHOST (SETQ PRINTERTYPE (PRINTERTYPE PRINTHOST)))
(T (for X inside DEFAULTPRINTINGHOST when (PRINTERPROP (SETQ PRINTERTYPE (PRINTERTYPE
X))
(QUOTE BITMAPSCALE))
do (RETURN (SETQ PRINTHOST X)) finally (SETQ PRINTERTYPE (PRINTERTYPE
(SETQ PRINTHOST (COND
((LISTP DEFAULTPRINTINGHOST)
(CAR DEFAULTPRINTINGHOST))
(T DEFAULTPRINTINGHOST]
[COND
((NOT SCALEFACTOR)
[SETQ SCALEFACTOR (COND
(REGION (PRINTER.BITMAPSCALE (fetch WIDTH of REGION)
(fetch HEIGHT of REGION)
PRINTERTYPE PRINTHOST))
(T (PRINTER.BITMAPSCALE (fetch BITMAPWIDTH of BITMAP)
(fetch BITMAPHEIGHT of BITMAP)
PRINTERTYPE PRINTHOST]
(COND
((LISTP SCALEFACTOR)
(SETQ ROTATION (CDR SCALEFACTOR))
(SETQ SCALEFACTOR (CAR SCALEFACTOR]
(SETQ FULLFILE (PRINTER.BITMAPFILE (OR FILE (PRINTER.SCRATCH.FILE))
PRINTERTYPE BITMAP SCALEFACTOR REGION ROTATION
"Window Image"))
[COND
((OR HOST (NULL FILE))
(ADD.PROCESS [BQUOTE (PROGN (, (PRINTERPROP PRINTERTYPE (QUOTE SEND))
(QUOTE , (COND ((LISTP PRINTHOST)
(CADR PRINTHOST))
(T PRINTHOST)))
(QUOTE , FULLFILE)
(QUOTE (DOCUMENT.NAME "Window Image")))
,
(AND (NULL FILE)
(BQUOTE (DELFILE (QUOTE , FULLFILE]
(QUOTE NAME)
(QUOTE HARDCOPYW]
(RETURN (COND
((NULL FILE)
NIL)
(T FULLFILE])
(PRINTER.BITMAPFILE
[LAMBDA (FILE PRINTERTYPE BITMAP SCALEFACTOR REGION ROTATION TITLE)
(* lmm " 3-OCT-83 21:40")
(* convert a bitmap into a file)
(DECLARE (SPECVARS . T))
(EVAL (PRINTERPROP PRINTERTYPE (QUOTE BITMAPFILE])
(PRINTER.BITMAPSCALE
[LAMBDA (WIDTH HEIGHT PRINTERTYPE HOST) (* lmm " 3-OCT-83 21:32")
(* could ask the host what size paper it has)
(PROG NIL
(RETURN (APPLY* (OR (PRINTERPROP PRINTERTYPE (QUOTE BITMAPSCALE))
(RETURN 1))
WIDTH HEIGHT HOST])
(PRINTER.RESET.DELETE
[LAMBDA (X) (* rmk: "22-SEP-83 17:34")
[RESETSAVE NIL (LIST (FUNCTION [LAMBDA (X)
(CLOSEF? X)
(DELFILE X])
(SETQ X (CADR X]
X])
(PRINTER.SCRATCH.FILE
[LAMBDA (FULLFILE) (* rmk: "22-SEP-83 17:46")
(COND
[(AND FULLFILE (FIXP (CAR (LISTP EMPRESS.SCRATCH)))
(IGREATERP (GETFILEINFO FULLFILE (QUOTE SIZE))
(CAR EMPRESS.SCRATCH)))
(CAR (LISTP (CDR EMPRESS.SCRATCH]
(T (QUOTE {CORE}EMPRESS.SCRATCH])
(PRINTERTYPE
[LAMBDA (HOST) (* lmm " 5-OCT-83 16:42")
(SELECTQ HOST
[(NIL LPT)
(SETQ HOST (COND
((LISTP DEFAULTPRINTINGHOST)
(CAR DEFAULTPRINTINGHOST))
(T DEFAULTPRINTINGHOST]
NIL)
(COND
((LISTP HOST)
(CAR HOST))
((NULL HOST)
DEFAULTPRINTERTYPE)
((GETPROP HOST (QUOTE PRINTERTYPE)))
((STRPOS ":" HOST)
(QUOTE INTERPRESS))
(T DEFAULTPRINTERTYPE])
(LISTFILES1
[LAMBDA (FILE) (* lmm " 4-OCT-83 02:56")
(SEND.FILE.TO.PRINTER FILE])
(SEND.FILE.TO.PRINTER
[LAMBDA (FILE HOST PRINTOPTIONS) (* rmk: " 7-NOV-83 15:51")
(* Returns file name if successful, NIL if not. The RESETLST makes sure the scratch file, if any, is deleted.
EMPRESS.SCRATCH sets a limit on the size of the file that will be converted to a CORE file so as not to use up too
much virtual memory)
(RESETLST (PROG (FULLFILE FILETYPE PRINTERTYPE PFILE)
[RESETSAVE NIL (LIST (COND
[(LISTGET PRINTOPTIONS (QUOTE DELETE))
(FUNCTION (LAMBDA (FL)
(CLOSEF? FL)
(DELFILE FL]
(T (FUNCTION CLOSEF?)))
(SETQ FULLFILE (OPENFILE FILE (QUOTE INPUT)
(QUOTE OLD)
8]
(* Do we need to convert the FILE ?)
(SETQ FILETYPE (PRINTFILETYPE (SETQ PFILE FULLFILE)))
[COND
[HOST (SETQ PRINTERTYPE (PRINTERTYPE HOST))
(COND
((CAN.PRINT.DIRECTLY PRINTERTYPE FILETYPE)
(* IS OK, NO CONVERSION)
)
(T (SETQ PFILE (CONVERT.FILE.TO.TYPE.FOR.PRINTER PFILE FILETYPE
PRINTERTYPE
(LISTGET PRINTOPTIONS
(QUOTE
HEADING]
([AND FILETYPE (for X inside (OR DEFAULTPRINTINGHOST (QUOTE (NIL)))
when (CAN.PRINT.DIRECTLY (SETQ PRINTERTYPE (PRINTERTYPE
X))
FILETYPE)
do (RETURN (SETQ HOST X]
(* no conversion necessary)
)
(T (SETQ PFILE (CONVERT.FILE.TO.TYPE.FOR.PRINTER PFILE FILETYPE
[SETQ PRINTERTYPE
(PRINTERTYPE
(SETQ HOST
(COND
((LISTP
DEFAULTPRINTINGHOST)
(CAR
DEFAULTPRINTINGHOST))
(T DEFAULTPRINTINGHOST]
(LISTGET PRINTOPTIONS
(QUOTE HEADING]
(COND
([NLISTP (SETQ PFILE (APPLY* (OR (PRINTERPROP PRINTERTYPE (QUOTE SEND))
(ERROR (CONCAT "Don't know how to send to a "
PRINTERTYPE)
HOST))
(COND
((LISTP HOST)
(CADR HOST))
(T HOST))
PFILE
(APPEND (OR PRINTOPTIONS (QUOTE (#COPIES 1)))
(LIST (QUOTE DOCUMENT.NAME)
FULLFILE]
(RETURN FULLFILE))
(T (LISPXPRIN1 (CDR PFILE)
T)
(LISPXTERPRI T)
(RETURN NIL])
(CAN.PRINT.DIRECTLY
[LAMBDA (PRINTERTYPE FILETYPE) (* lmm " 7-OCT-83 12:05")
(FMEMB FILETYPE (PRINTERPROP PRINTERTYPE (QUOTE CANPRINT])
(PRINTERPROP
[LAMBDA (PRINTERTYPE PROP) (* lmm " 5-OCT-83 16:11")
(for X in PRINTERTYPES when (EQMEMB PRINTERTYPE (CAR X))
do (RETURN (CADR (ASSOC PROP (CDR X])
(PRINTFILEPROP
[LAMBDA (PRINTFILETYPE PROP) (* rmk: "11-OCT-83 13:00")
(for X in PRINTFILETYPES when (EQMEMB PRINTFILETYPE (CAR X))
do (RETURN (CADR (ASSOC PROP (CDR X])
(PRINTERSTATUS
[LAMBDA (PRINTER) (* lmm " 5-OCT-83 15:19")
(PROG [(STATUSFN (PRINTERPROP (PRINTERTYPE PRINTER)
(QUOTE STATUS]
(RETURN (AND STATUSFN (APPLY* STATUSFN PRINTER])
(PRINTFILETYPE
[LAMBDA (FILE) (* lmm " 5-OCT-83 16:15")
(* could be extended to know about TEDIT etc. documents)
(OR (bind (EXT ←(FILENAMEFIELD FILE (QUOTE EXTENSION))) for TYPE in PRINTFILETYPES
when [FMEMB EXT (CADR (ASSOC (QUOTE EXTENSION)
(CDR TYPE]
do (RETURN (CAR TYPE)))
(AND (RANDACCESSP FILE)
(for TYPE in PRINTFILETYPES when (APPLY* (CADR (ASSOC (QUOTE TEST)
(CDR TYPE)))
FILE)
do (RETURN (CAR TYPE])
)
(DEFINEQ
(LISTFILES
[NLAMBDA FILES (* rmk: "13-JUN-82 23:53")
(DECLARE (GLOBALVARS NOTLISTEDFILES FILELST))
(for FILE FULLNAME in (OR FILES NOTLISTEDFILES)
join (COND
[[SETQ FULLNAME (FINDFILE (COND
[(AND (MEMB FILE FILELST)
(CDAR (LISTP (GETPROP FILE (QUOTE FILEDATES]
(T
(* User specified version number and/or directory, so list that file regardless of filedates property , or FILE is
not on FILELST, in which case ignore filedates.)
FILE]
(COND
((LISTFILES1 FULLNAME)
(SETQ NOTLISTEDFILES (REMOVE (NAMEFIELD FULLNAME T)
NOTLISTEDFILES))
(CONS FULLNAME]
(T (printout T FILE " not found." T])
)
(* for backward compatibility)
(MOVD? (QUOTE NILL)
(QUOTE PRINTERMODE))
(RPAQ? DEFAULTPRINTERTYPE (QUOTE PRESS))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA LISTFILES)
(ADDTOVAR NLAML TIMEALL)
(ADDTOVAR LAMA )
)
(PUTPROPS DMISC COPYRIGHT ("Xerox Corporation" 1982 1983 1984))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3512 3983 (TENEX 3522 . 3981)) (3984 4721 (BACKSPACEDEL 3994 . 4719)) (4835 16986 (
TIMEALL 4845 . 7371) (COPYMISCSTATS 7373 . 8240) (COPYTIMESTATS 8242 . 9338) (CREATEMISCSTATS 9340 .
9750) (DIFFMISCSTATS 9752 . 11429) (DIFFTIMESTATS 11431 . 13622) (PRINTMISCSTATS 13624 . 16430) (
PRINTMISCSTATSITEM 16432 . 16984)) (17110 17550 (PERIODICALLYRECLAIM 17120 . 17548)) (17726 21125 (
APROPOS 17736 . 20890) (\APROPOS.MARGINSET 20892 . 21123)) (21126 22515 (\DIRTYBACKGROUND 21136 .
21518) (\SAVEVMBACKGROUND 21520 . 22133) (COPYVM 22135 . 22513)) (22940 23651 (SETTIME 22950 . 23649))
(23683 26912 (RINGBELLS 23693 . 24497) (FLASHWINDOW 24499 . 25846) (\DISMISS.WITHOUT.BLOCKING 25848
. 26158) (PLAYTUNE 26160 . 26910)) (27319 30181 (ATOMHASH#PROBES 27329 . 29055) (\ATOM.FIRSTHASHINDEX
29057 . 30179)) (30229 30831 (GENSYM? 30239 . 30829)) (30883 33800 (DISPLAYDOWN 30893 . 31236) (
SETDISPLAYHEIGHT 31238 . 32690) (VIDEORATE 32692 . 33798)) (35549 36156 (DOAROUNDEXITFORMS 35559 .
36154)) (36361 36814 (POINTERARRAY 36371 . 36521) (WORDARRAY 36523 . 36669) (FIXPARRAY 36671 . 36812))
(37102 38444 (REALMEMORYSIZE 37112 . 37273) (LISPVERSION 37275 . 37431) (MICROCODEVERSION 37433 .
37594) (BCPLVERSION 37596 . 37752) (REQUIREVERSION 37754 . 38442)) (38466 39086 (READPRINTERPORT 38476
. 38620) (WRITEPRINTERPORT 38622 . 38780) (\MISC1.UFN 38782 . 38932) (\MISC2.UFN 38934 . 39084)) (
39537 49778 (EMPRESS 39547 . 39939) (CONVERT.FILE.TO.TYPE.FOR.PRINTER 39941 . 40727) (HARDCOPYW 40729
. 43736) (PRINTER.BITMAPFILE 43738 . 44112) (PRINTER.BITMAPSCALE 44114 . 44480) (PRINTER.RESET.DELETE
44482 . 44716) (PRINTER.SCRATCH.FILE 44718 . 45063) (PRINTERTYPE 45065 . 45542) (LISTFILES1 45544 .
45687) (SEND.FILE.TO.PRINTER 45689 . 48241) (CAN.PRINT.DIRECTLY 48243 . 48428) (PRINTERPROP 48430 .
48663) (PRINTFILEPROP 48665 . 48905) (PRINTERSTATUS 48907 . 49160) (PRINTFILETYPE 49162 . 49776)) (
49779 50559 (LISTFILES 49789 . 50557)))))
STOP