(FILECREATED "19-Jun-86 15:25:05" {ERIS}<LISPCORE>SOURCES>DMISC.;43 63698
changes to: (FNS TIMEALL)
previous date: "25-Apr-86 15:37:46" {ERIS}<LISPCORE>SOURCES>DMISC.;42)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved. The following
program was created in 1982 but has not been published within the meaning of the copyright law, is
furnished under license, and may not be used, copied and/or disclosed except in accordance with the
terms of said license.)
(PRETTYCOMPRINT DMISCCOMS)
(RPAQQ DMISCCOMS [[COMS (FNS BACKSPACEDEL)
(DECLARE: DOCOPY DONTEVAL@LOAD (P (BACKSPACEDEL \ORIGTERMTABLE)
(BACKSPACEDEL NIL]
(COMS (* TIMEALL)
(FNS TIMEALL COPYMISCSTATS COPYTIMESTATS CREATEMISCSTATS DIFFMISCSTATS
DIFFTIMESTATS PRINTMISCSTATS PRINTMISCSTATSITEM)
(DECLARE: DONTCOPY (RECORDS STATSOBJECT)))
[COMS (FNS PERIODICALLYRECLAIM)
(DECLARE: DONTEVAL@LOAD DOCOPY [INITVARS (RECLAIMWAIT 4)
(\LASTRECLAIM
(\DAYTIME0 (NCREATE (QUOTE FIXP]
(APPENDVARS (BACKGROUNDFNS PERIODICALLYRECLAIM)
(\SYSTEMTIMERVARS (\LASTRECLAIM SECONDS]
(FNS APROPOS APROPRINT)
(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 PLAYTUNE)
(DECLARE: EVAL@COMPILE DONTCOPY (RESOURCES \PlayTimer))
(INITRESOURCES \PlayTimer)
(DECLARE: DONTEVAL@LOAD DOCOPY (* Overrides definition in the shared MISC)
(P (MOVD (QUOTE RINGBELLS)
(QUOTE PRINTBELLS]
[COMS (* Changing display)
(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)
(FNS REALMEMORYSIZE LISPVERSION MICROCODEVERSION BCPLVERSION REQUIREVERSION))
(COMS (* Misc ops)
(FNS READPRINTERPORT WRITEPRINTERPORT \READPRINTERPORT.UFN
\WRITEPRINTERPORT.UFN \MISC1.UFN \MISC2.UFN \MISC3.UFN \MISC4.UFN
\MISC5.UFN \MISC6.UFN \MISC7.UFN \MISC8.UFN \MISC10.UFN)
(* sub-functions of floating-point ufns)
(FNS BLKFLOATP2COMP BLKSMALLP2FLOAT BLKMAG BLKEXPONENT)
(FNS BLKSEP BLKFDIFF BLKFPLUS BLKPERM BLKFTIMES \FLOATTOBYTE.UFN \BLKFMAX.UFN
\BLKFMIN.UFN \BLKFABSMAX.UFN \BLKFABSMIN.UFN)
(FNS IBLT1 IBLT2))
(VARS RINGBELLS.L1 RINGBELLS.L2)
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML TIMEALL)
(LAMA])
(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)
(DEFINEQ
(TIMEALL
[NLAMBDA (TIMEFORM NUMBEROFTIMES TIMEWHAT INTERPFLG SHOWCODE)
(* lmm "19-Jun-86 14:09")
(* 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 (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 [CL:COMPILE (QUOTE TIMEDUMMYFUNCTION)
(BQUOTE (LAMBDA NIL
(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) (* lmm " 6-Jan-85 14:52")
(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 (fetch 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 DISKOPS of STATS with (fetch DISKOPS 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) (* lmm " 6-Jan-85 15:10")
(* 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 DISKOPS of DIFFERENCESBLOCK with (IDIFFERENCE (fetch DISKOPS of AFTERBLOCK)
(fetch DISKOPS 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: " 4-Nov-85 17:21")
(DECLARE (GLOBALVARS \RECLAIM.COUNTDOWN \LASTUSERACTION RECLAIMWAIT \LASTRECLAIM))
(if (AND \RECLAIM.COUNTDOWN (\SECONDSCLOCKGREATERP \LASTUSERACTION RECLAIMWAIT)
(\SECONDSCLOCKGREATERP \LASTRECLAIM RECLAIMWAIT))
then (RECLAIM)
(\DAYTIME0 \LASTRECLAIM])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ? RECLAIMWAIT 4)
(RPAQ? \LASTRECLAIM (\DAYTIME0 (NCREATE (QUOTE FIXP))))
(APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM)
(APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS))
)
(DEFINEQ
(APROPOS
[LAMBDA (STRING ALLFLG QUIETFLG OUTPUT CASEXACT) (* bvm: "19-Mar-86 16:09")
(PROG ((FILTERFN (AND ALLFLG (NEQ ALLFLG T)
(FNTYP ALLFLG)
ALLFLG))
[DISPLAYSTREAM (AND (NOT QUIETFLG)
(DISPLAYSTREAMP (SETQ OUTPUT (GETSTREAM (OR OUTPUT T)
(QUOTE OUTPUT]
(BLOCKCOUNT 32)
(CASEARRAY (AND (NOT CASEXACT)
UPPERCASEARRAY))
RESULT)
(DECLARE (SPECVARS RESULT FILTERFN DISPLAYSTREAM))
[RESETFORM (PRINTLEVEL 3 5)
(MAPATOMS (FUNCTION (LAMBDA (ATOM)
(PROG (VAL)
(DECLARE (USEDFREE RESULT BLOCKCOUNT FILTERFN))
(COND
((EQ 0 (SETQ BLOCKCOUNT (SUB1 BLOCKCOUNT)))
(SETQ BLOCKCOUNT 32)
(BLOCK)))
(COND
([COND
(FILTERFN (AND (STRPOS STRING ATOM NIL NIL NIL
NIL CASEARRAY)
(APPLY* FILTERFN ATOM)))
(T (AND (OR ALLFLG (GETD ATOM)
(GETPROPLIST ATOM)
(NEQ (GETTOPVAL ATOM)
(QUOTE NOBIND)))
(STRPOS STRING ATOM NIL NIL NIL NIL
CASEARRAY)
(OR ALLFLG (AND (NOT (GENSYM? ATOM))
(NEQ (CHCON1 ATOM)
(CHARCODE \))
(NOT (\SUBFNDEF ATOM]
(COND
(QUIETFLG (push RESULT ATOM))
(T (COND
((OR (GETD ATOM)
(GETPROPLIST ATOM)
(NEQ (GETTOPVAL ATOM)
(QUOTE NOBIND)))
(FRESHLINE OUTPUT)))
(PRINTOUT OUTPUT .P2 ATOM ,)
(COND
((GETD ATOM)
(APROPRINT "function:" (ARGLIST ATOM)
OUTPUT)))
(COND
((NEQ (SETQ VAL (GETTOPVAL ATOM))
(QUOTE NOBIND))
(APROPRINT "value: " VAL OUTPUT)))
(COND
((SETQ VAL (GETPROPLIST ATOM))
(APROPRINT "proplist:" VAL OUTPUT]
(RETURN RESULT])
(APROPRINT
[LAMBDA (STRING VALUE FILE) (* bvm: "16-Jul-85 12:04")
(printout FILE .TAB0 20 "-" STRING ,)
(COND
((IMAGESTREAMP FILE)
(RESETLST (RESETSAVE NIL (LIST (FUNCTION DSPLEFTMARGIN)
(DSPLEFTMARGIN (DSPXPOSITION NIL FILE)
FILE)
FILE))
(POSITION FILE 0)
(PRIN2 VALUE FILE T)))
(T (PRIN2 VALUE FILE)))
(FRESHLINE FILE])
)
(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: "14-Feb-85 23:27")
(COND
((AND (ILESSP \DIRTYPAGEHINT SAVEVMMAX)
(NEQ (fetch (IFPAGE Key) of \InterfacePage)
\IFPValidKey)
(FIXP SAVEVMWAIT)
(\SECONDSCLOCKGREATERP \LASTUSERACTION SAVEVMWAIT))
(COND
((AND (ILESSP (SETQ \DIRTYPAGEHINT (\COUNTREALPAGES (QUOTE DIRTY)))
SAVEVMMAX)
(\FLUSHVMOK? (QUOTE SAVEVM)
T)) (* 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
(GLOBALVARS BACKGROUNDPAGEMIN BACKGROUNDPAGEFREQ BACKGROUNDPAGECNT)
)
(* Setting the time)
(DEFINEQ
(SETTIME
[LAMBDA (DT) (* bvm: "26-Jul-84 15:32")
(if (OR (AND (NULL DT)
(\NET.SETTIME))
(PROG [(IDT (AND DT (LISP.TO.ALTO.DATE (OR (IDATE DT)
(ERROR "Invalid date" DT]
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 T)))
then (DATE (DATEFORMAT TIME.ZONE])
)
(* Bells and whistles)
(DEFINEQ
(RINGBELLS
[LAMBDA (N) (* mpl "20-Jul-85 23:58")
(DECLARE (GLOBALVARS RINGBELLS.L1 RINGBELLS.L2))
(OR (FIXP N)
(SETQ N 1))
(COND
((OR (EQ \MACHINETYPE \DAYBREAK)
(EQ \MACHINETYPE \DANDELION))
(to N do (PLAYTUNE RINGBELLS.L1)
(FLASHWINDOW NIL NIL 100)
(PLAYTUNE RINGBELLS.L2)))
(T (FLASHWINDOW NIL N])
(FLASHWINDOW
[LAMBDA (WIN? N FLASHINTERVAL SHADE) (* bvm: "16-Jul-85 12:20")
(* This is an "attention getting"
action.)
(* rrb -
added shade argument so contrast of
flash could be explored.)
(OR (FIXP N)
(SETQ N 1))
(OR (FIXP FLASHINTERVAL)
(SETQ FLASHINTERVAL 200))
[COND
((WINDOWP WIN?)
(SETQ WIN? (GETSTREAM WIN? (QUOTE OUTPUT]
(for I to N bind (WHOLEP ←(NOT (DISPLAYSTREAMP WIN?)))
COLORP first [COND
(WHOLEP (SETQ COLORP (NULL (VIDEOCOLOR]
do (UNINTERRUPTABLY
(* Open-coded "during" loops so that
no one else can sneak in and steal
cycles)
(COND
[WHOLEP (* Flash the whole screen)
(VIDEOCOLOR (PROG1 (VIDEOCOLOR COLORP)
(DISMISS FLASHINTERVAL NIL T]
(T (* Although VIDEOCOLOR is nearly
instantaneous, INVERTW may require a
time approaching the interval time and
thus this path could be much longer)
(INVERTW WIN? SHADE)
(DISMISS FLASHINTERVAL NIL T)
(INVERTW WIN? SHADE))))
(COND
((NEQ I N)
(BLOCK 250])
(PLAYTUNE
[LAMBDA (TUNEPAIRS) (* bvm: "25-Apr-86 14:29")
(* TUNEPAIRS 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.)
(SELECTQ (MACHINETYPE)
((DANDELION DOVE)
[RESETLST (RESETSAVE NIL (QUOTE (BEEPOFF)))
(GLOBALRESOURCE (\PlayTimer)
(for X in TUNEPAIRS do (COND
((CAR X)
(BEEPON (CAR X)))
(T (BEEPOFF)))
(forDuration (CDR X) timerUnits (QUOTE TICKS)
usingTimer \PlayTimer do
(* Just "busy-wait" to pass the time)
NIL]
T)
NIL])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(DECLARE: EVAL@COMPILE
[PUTDEF (QUOTE \PlayTimer)
(QUOTE RESOURCES)
(QUOTE (NEW (SETUPTIMER 0]
)
)
(/SETTOPVAL (QUOTE \\PlayTimer.GLOBALRESOURCE))
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD (QUOTE RINGBELLS)
(QUOTE PRINTBELLS))
)
(* Changing display)
(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)) (* MPL "28-Jul-85 01:32")
(* 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.)
(COND
((OR (EQ \MACHINETYPE \DOLPHIN)
(EQ \MACHINETYPE \DORADO))
(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 (BREAKREAD (QUOTE LINE))
1 T)))
(BT! (BAKTRACE LASTPOS NIL (BREAKREAD (QUOTE LINE))
0 T)))
(ADDTOVAR BAKTRACELST (EVAL (**BREAK** LISPX ERRORSET BREAK1A ERRORSET 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 ERRORSET 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) (* JonL "13-Sep-84 13:42")
(* 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)
(AFTERMAKESYS AFTERMAKESYSFORMS)
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)
(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])
(\READPRINTERPORT.UFN
[LAMBDA NIL (* hdj "16-Sep-84 21:37")
(if (EQ \MACHINETYPE \DANDELION)
then (\DEVICE.INPUT 7])
(\WRITEPRINTERPORT.UFN
[LAMBDA (DATUM) (* hdj "16-Sep-84 21:45")
(if (EQ \MACHINETYPE \DANDELION)
then (\DEVICE.OUTPUT DATUM 14])
(\MISC1.UFN
[LAMBDA (ARG ALPHA) (* kbr: "12-Jul-85 17:14")
(RAID "Illegal op to \MISC1.UFN -- " ALPHA])
(\MISC2.UFN
[LAMBDA (ARG1 ARG2 ALPHA) (* kbr: "12-Jul-85 17:13")
(RAID "Illegal op to \MISC2.UFN -- " ALPHA])
(\MISC3.UFN
[LAMBDA (ARG1 ARG2 ARG3 ALPHA) (* hdj "26-Feb-85 11:50")
(SELECTQ ALPHA
(0 (BLKEXPONENT ARG1 ARG2 ARG3))
(1 (BLKMAG ARG1 ARG2 ARG3))
(2 (BLKSMALLP2FLOAT ARG1 ARG2 ARG3))
(3 (BLKFLOATP2COMP ARG1 ARG2 ARG3))
(4 (\BLKFMAX.UFN ARG1 ARG2 ARG3))
(5 (\BLKFMIN.UFN ARG1 ARG2 ARG3))
(6 (\BLKFABSMAX.UFN ARG1 ARG2 ARG3))
(7 (\BLKFABSMIN.UFN ARG1 ARG2 ARG3))
(8 (\FLOATTOBYTE.UFN ARG1 ARG2 ARG3))
(RAID "Illegal op to \MISC3.UFN --" ALPHA])
(\MISC4.UFN
[LAMBDA (ARG1 ARG2 ARG3 ARG4 ALPHA) (* hdj "19-Mar-85 11:02")
(SELECTQ ALPHA
(0 (BLKFTIMES ARG1 ARG2 ARG3 ARG4))
(1 (BLKPERM ARG1 ARG2 ARG3 ARG4))
(2 (BLKFPLUS ARG1 ARG2 ARG3 ARG4))
(3 (BLKFDIFF ARG1 ARG2 ARG3 ARG4))
(4 (BLKSEP ARG1 ARG2 ARG3 ARG4))
(5 (\TRIPLEMATCH ARG1 ARG2 ARG3 ARG4))
(6 (\BITMAPBIT ARG1 ARG2 ARG3 ARG4))
(RAID "Illegal op to \MISC4.UFN -- " ALPHA])
(\MISC5.UFN
[LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ALPHA) (* kbr: "12-Jul-85 17:05")
(RAID "Illegal op to \MISC5.UFN -- " ALPHA])
(\MISC6.UFN
[LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ALPHA) (* kbr: "12-Jul-85 17:04")
(RAID "Illegal op to \MISC6.UFN -- " ALPHA])
(\MISC7.UFN
[LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ALPHA) (* kbr: "12-Jul-85 17:03")
(SELECTQ ALPHA
(0 (\PSEUDOCOLOR.UFN ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7))
(RAID "Illegal op to \MISC7.UFN -- " ALPHA])
(\MISC8.UFN
[LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ALPHA) (* hdj "26-Feb-85 11:56")
(SELECTQ ALPHA
(0 (IBLT1 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8))
(1 (IBLT2 ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8))
(RAID "Illegal op to \MISC8.UFN --" ALPHA])
(\MISC10.UFN
[LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9 ARG10 ALPHA)
(* kbr: "12-Jul-85 17:16")
(SELECTQ ALPHA
(0 (\PIXELBLT.UFN ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ARG8 ARG9 ARG10))
(HELP "Illegal op to \MISC10.UFN -- " ALPHA])
)
(* sub-functions of floating-point ufns)
(DEFINEQ
(BLKFLOATP2COMP
[LAMBDA (source destination kount) (* hdj "21-Jun-84 19:03")
(* * moves the contents of a Real array into a Complex array;
sets imaginary part to 0)
(* \CHECKARRAYINDEX destination
(SUB1 kount))
(for sourceElt from 0 to (SUB1 kount) do (SETCOMPLEX (\ADDBASE destination (LLSH sourceElt 2))
(\GETBASEFLOATP source (LLSH sourceElt 1))
0.0])
(BLKSMALLP2FLOAT
[LAMBDA (source destination kkount) (* edited: "22-Jun-84 04:21")
(* * convert an array of SMALLPs to FLOATPs)
(* \CHECKARRAYINDEX destination
(SUB1 kount))
(for NN from 0 to (SUB1 kkount) do (\PUTBASEFLOATP destination (LLSH NN 1)
(FLOAT (\GETBASE source NN])
(BLKMAG
[LAMBDA (complexArray magnitudeArray kount) (* hdj "21-Jun-84 18:53")
(* \CHECKARRAYINDEX magnitudeArray
(SUB1 kount))
(for magnitude from 0 to (SUB1 kount) bind complexcount real imag
do (SETQ complexcount (LLSH magnitude 2))
(SETQ real (\GETBASEFLOATP complexArray complexcount))
(SETQ imag (\GETBASEFLOATP complexArray (IPLUS complexcount 2)))
(\PUTBASEFLOATP magnitudeArray (LLSH magnitude 1)
(FPLUS (FTIMES real real)
(FTIMES imag imag])
(BLKEXPONENT
[LAMBDA (source destination kount) (* edited: "24-Jun-84 23:44")
(* * extract the exponent of each element of source, stick it in destination)
(* \CHECKARRAYINDEX destination
(SUB1 kount))
(for X from 0 to (SUB1 kount) do (\PUTBASE destination X (fetch (FLOATP EXPONENT)
of (\GETBASEFLOATP source
(LLSH X 1])
)
(DEFINEQ
(BLKSEP
[LAMBDA (SOURCE1 SOURCE2 DEST KOUNT) (* hdj "12-Nov-84 16:02")
(* *)
(for ALPHAINDEX from 0 to (DOUBLE (SUB1 KOUNT)) by 8 bind BETAINDEX GAMMAINDEX DELTAINDEX
do (SETQ BETAINDEX (IDIFFERENCE KOUNT ALPHAINDEX))
(SETQ GAMMAINDEX (IPLUS ALPHAINDEX 2))
(SETQ DELTAINDEX (IPLUS BETAINDEX 2))
(\PUTBASEFLOATP DEST ALPHAINDEX (FPLUS (\GETBASEFLOATP SOURCE1 ALPHAINDEX)
(\GETBASEFLOATP SOURCE2 BETAINDEX)))
(\PUTBASEFLOATP DEST (IPLUS ALPHAINDEX 2)
(FDIFFERENCE (\GETBASEFLOATP SOURCE1 GAMMAINDEX)
(\GETBASEFLOATP SOURCE2 DELTAINDEX)))
(\PUTBASEFLOATP DEST (IPLUS ALPHAINDEX 4)
(FPLUS (\GETBASEFLOATP SOURCE1 GAMMAINDEX)
(\GETBASEFLOATP SOURCE2 DELTAINDEX)))
(\PUTBASEFLOATP DEST (IPLUS ALPHAINDEX 6)
(FDIFFERENCE (\GETBASEFLOATP SOURCE1 ALPHAINDEX)
(\GETBASEFLOATP SOURCE2 BETAINDEX])
(BLKFDIFF
[LAMBDA (SOURCE1 SOURCE2 DEST KOUNT) (* hdj "20-Sep-84 12:35")
(for INDEX from 0 to (DOUBLE (SUB1 KOUNT)) by 2 do (\PUTBASEFLOATP DEST INDEX
(FDIFFERENCE (\GETBASEFLOATP SOURCE1
INDEX)
(\GETBASEFLOATP SOURCE2 INDEX])
(BLKFPLUS
[LAMBDA (SOURCE1 SOURCE2 DEST KOUNT) (* hdj "20-Sep-84 12:36")
(for INDEX from 0 to (DOUBLE (SUB1 KOUNT)) by 2 do (\PUTBASEFLOATP DEST INDEX
(FPLUS (\GETBASEFLOATP SOURCE1 INDEX)
(\GETBASEFLOATP SOURCE2 INDEX])
(BLKPERM
[LAMBDA (orig permutations destination kount) (* hdj "21-Jun-84 19:26")
(* * destination (x) ← orig (perm (x)))
(* * args are arrays of smallps (words))
(* * must fold initial into offset for compatibility with microcode)
(* \CHECKARRAYINDEX destination
(SUB1 kount))
(for X from 0 to (SUB1 kount) do (\PUTBASE destination X (\GETBASE orig (\GETBASE permutations X])
(BLKFTIMES
[LAMBDA (SOURCE1 SOURCE2 DEST KOUNT) (* hdj "21-Jun-84 19:11")
(* \CHECKARRAYINDEX DEST
(SUB1 KOUNT))
(for INDEX from 0 to (LLSH (SUB1 KOUNT)
1) by 2 do (\PUTBASEFLOATP DEST INDEX (FTIMES (\GETBASEFLOATP SOURCE1
INDEX)
(\GETBASEFLOATP SOURCE2
INDEX])
(\FLOATTOBYTE.UFN
[LAMBDA (SBASE DBASE CNT)
(for I from 0 to (SUB1 (DIV2 CNT))
do (\PUTBASE DBASE I (LOGOR (LLSH [FIX (FMIN 255.0 (FMAX 0.0 (\GETBASEFLOATP SBASE
(MUL4 I]
8)
(FIX (FMIN 255.0 (FMAX 0.0 (\GETBASEFLOATP SBASE
(IPLUS 2 (MUL4 I])
(\BLKFMAX.UFN
[LAMBDA (BASE ZERO CNT)
(LET ((IDX 0)
(MX (\GETBASEFLOATP BASE 0)))
[for I from 0 to (SUB1 CNT) do (if [NOT (GREATERP MX (\GETBASEFLOATP BASE (IPLUS I I]
then (SETQ IDX I)
(SETQ MX (\GETBASEFLOATP BASE (IPLUS IDX IDX]
IDX])
(\BLKFMIN.UFN
[LAMBDA (BASE ZERO CNT)
(LET ((IDX 0)
(MN (\GETBASEFLOATP BASE 0)))
[for I from 0 to (SUB1 CNT) do (if [NOT (LESSP MN (\GETBASEFLOATP BASE (IPLUS I I]
then (SETQ IDX I)
(SETQ MN (\GETBASEFLOATP BASE (IPLUS IDX IDX]
IDX])
(\BLKFABSMAX.UFN
[LAMBDA (BASE ZERO CNT)
(LET ((IDX 0)
(MX (\GETBASEFLOATP BASE 0)))
[for I from 0 to (SUB1 CNT)
do (if [NOT (GREATERP MX (FABS (\GETBASEFLOATP BASE (IPLUS I I]
then (SETQ IDX I)
(SETQ MX (FABS (\GETBASEFLOATP BASE (IPLUS IDX IDX]
IDX])
(\BLKFABSMIN.UFN
[LAMBDA (BASE ZERO CNT)
(LET ((IDX 0)
(MN (\GETBASEFLOATP BASE 0)))
[for I from 0 to (SUB1 CNT)
do (if [NOT (LESSP MN (FABS (\GETBASEFLOATP BASE (IPLUS I I]
then (SETQ IDX I)
(SETQ MN (FABS (\GETBASEFLOATP BASE (IPLUS IDX IDX]
IDX])
)
(DEFINEQ
(IBLT1
[LAMBDA (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth Kount)
(* hdj " 2-Jul-84 17:52")
(* * ValueArray -
an array of 128 elements, 8 bits each)
(* * TextureArray -
an array of 256 elements, each a texture)
(* * XCoord -
bit offset from left of destination bitmap)
(* * BitmapAddr -
destination)
(* * BitmapWidth -
width of dest bitmap in words)
(* * ValHeight -
height of bar)
(* * ValWidth -
width of bar)
(* * Kount -
how many elements of ValueArray to graph)
(PROG (TEXTURE (BITMAPOFFSET BitmapAddr))
(for val from (SUB1 Kount) to 0 by -1 do (SETQ TEXTURE (\GETBASE TextureArray
(\GETBASE ValueArray val)))
(for X from 1 to ValHeight
do (\PUTBASEBITS BITMAPOFFSET XCoord ValWidth
TEXTURE)
(SETQ BITMAPOFFSET (\ADDBASE BITMAPOFFSET
BitmapWidth])
(IBLT2
[LAMBDA (ValueArray TextureArray XCoord BitmapAddr BitmapWidth ValHeight ValWidth Kount)
(* hdj "20-Sep-84 12:20")
(* * Steps by 2, as opposed to IBLT1, which steps by 1)
(* * ValueArray -
an array of 128 elements, 8 bits each)
(* * TextureArray -
an array of 256 elements, each a texture)
(* * XCoord -
bit offset from left of destination bitmap)
(* * BitmapAddr -
destination)
(* * BitmapWidth -
width of dest bitmap in words)
(* * ValHeight -
height of bar)
(* * ValWidth -
width of bar)
(* * Kount -
how many elements of ValueArray to graph)
(PROG (TEXTURE (BITMAPOFFSET BitmapAddr))
(for val from (SUB1 Kount) to 0 by -2 do (SETQ TEXTURE (\GETBASE TextureArray
(\GETBASE ValueArray val)))
(for X from 1 to ValHeight
do (\PUTBASEBITS BITMAPOFFSET XCoord ValWidth
TEXTURE)
(SETQ BITMAPOFFSET (\ADDBASE BITMAPOFFSET
BitmapWidth])
)
(RPAQQ RINGBELLS.L1 ((1000 . 1000)
(800 . 1000)
(600 . 1000)
(500 . 1000)
(400 . 1000)
(NIL . 500)
(440 . 1000)
(484 . 1000)
(540 . 1000)
(600 . 1000)))
(RPAQQ RINGBELLS.L2 ((2000 . 1000)
(1600 . 1000)
(1200 . 1000)
(1000 . 1000)
(800 . 1000)
(NIL . 500)
(880 . 1000)
(968 . 1000)
(1080 . 1000)
(1188 . 1000)))
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML TIMEALL)
(ADDTOVAR LAMA )
)
(PUTPROPS DMISC COPYRIGHT ("Xerox Corporation" T 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (5970 6811 (BACKSPACEDEL 5980 . 6809)) (6915 22648 (TIMEALL 6925 . 9988) (COPYMISCSTATS
9990 . 10936) (COPYTIMESTATS 10938 . 12033) (CREATEMISCSTATS 12035 . 12539) (DIFFMISCSTATS 12541 .
15163) (DIFFTIMESTATS 15165 . 17992) (PRINTMISCSTATS 17994 . 21965) (PRINTMISCSTATSITEM 21967 . 22646)
) (22772 23212 (PERIODICALLYRECLAIM 22782 . 23210)) (23448 28063 (APROPOS 23458 . 27505) (APROPRINT
27507 . 28061)) (28064 29862 (\DIRTYBACKGROUND 28074 . 28504) (\SAVEVMBACKGROUND 28506 . 29382) (
COPYVM 29384 . 29860)) (30278 31484 (SETTIME 30288 . 31482)) (31516 35271 (RINGBELLS 31526 . 32003) (
FLASHWINDOW 32005 . 34100) (PLAYTUNE 34102 . 35269)) (35580 41489 (DISPLAYDOWN 35590 . 36017) (
SETDISPLAYHEIGHT 36019 . 39095) (VIDEORATE 39097 . 41487)) (44132 45032 (DOAROUNDEXITFORMS 44142 .
45030)) (45237 45723 (POINTERARRAY 45247 . 45408) (WORDARRAY 45410 . 45567) (FIXPARRAY 45569 . 45721))
(46142 47912 (REALMEMORYSIZE 46152 . 46317) (LISPVERSION 46319 . 46479) (MICROCODEVERSION 46481 .
46646) (BCPLVERSION 46648 . 46808) (REQUIREVERSION 46810 . 47910)) (47934 51324 (READPRINTERPORT 47944
. 48092) (WRITEPRINTERPORT 48094 . 48256) (\READPRINTERPORT.UFN 48258 . 48455) (\WRITEPRINTERPORT.UFN
48457 . 48663) (\MISC1.UFN 48665 . 48825) (\MISC2.UFN 48827 . 48987) (\MISC3.UFN 48989 . 49592) (
\MISC4.UFN 49594 . 50101) (\MISC5.UFN 50103 . 50263) (\MISC6.UFN 50265 . 50425) (\MISC7.UFN 50427 .
50676) (\MISC8.UFN 50678 . 50987) (\MISC10.UFN 50989 . 51322)) (51374 54003 (BLKFLOATP2COMP 51384 .
52069) (BLKSMALLP2FLOAT 52071 . 52606) (BLKMAG 52608 . 53319) (BLKEXPONENT 53321 . 54001)) (54004
59407 (BLKSEP 54014 . 55128) (BLKFDIFF 55130 . 55630) (BLKFPLUS 55632 . 56043) (BLKPERM 56045 . 56672)
(BLKFTIMES 56674 . 57401) (\FLOATTOBYTE.UFN 57403 . 57897) (\BLKFMAX.UFN 57899 . 58287) (\BLKFMIN.UFN
58289 . 58674) (\BLKFABSMAX.UFN 58676 . 59041) (\BLKFABSMIN.UFN 59043 . 59405)) (59408 62709 (IBLT1
59418 . 61021) (IBLT2 61023 . 62707)))))
STOP