(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 8-Apr-2023 13:56:13" {DSK}larry>il>medley>sources>DMISC.;2 45464 :EDIT-BY "lmm" :CHANGES-TO (FNS RINGBELLS) :PREVIOUS-DATE " 6-Jan-2022 19:08:15" {DSK}larry>il>medley>sources>DMISC.;1) (* ; " Copyright (c) 1982-1990 by Venue & Xerox Corporation. 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 (FNS PERIODICALLYRECLAIM) (DECLARE%: DONTEVAL@LOAD DOCOPY [INITVARS (RECLAIMWAIT 4) (\LASTRECLAIM (\DAYTIME0 (NCREATE 'FIXP] (APPENDVARS (BACKGROUNDFNS PERIODICALLYRECLAIM) (\SYSTEMTIMERVARS (\LASTRECLAIM SECONDS] (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 (FNS RINGBELLS FLASHWINDOW PLAYTUNE) (DECLARE%: EVAL@COMPILE DONTCOPY (RESOURCES \PlayTimer)) (INITRESOURCES \PlayTimer) (DECLARE%: DONTEVAL@LOAD DOCOPY (* ;  "Overrides definition in the shared MISC") (P (MOVD 'RINGBELLS 'PRINTBELLS] [COMS (* ; "Changing display") (FNS DISPLAYDOWN SETDISPLAYHEIGHT VIDEORATE) (INITVARS (\VIDEORATE 'NORMAL)) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDVARS (BREAKRESETFORMS (SETDISPLAYHEIGHT T)) (RESETFORMS (SETDISPLAYHEIGHT T] (DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (%#EOLCHARS 1)) [P (OR (LISTP (EVALV 'EDITCHARACTERS)) (RPAQ EDITCHARACTERS '(J X Z Y N))] (ADDVARS (POSTGREETFORMS (CNDIR)) (LISPUSERSDIRECTORIES))) [INITVARS (CLEANUPOPTIONS '(RC] (COMS (FNS DOAROUNDEXITFORMS) (ADDVARS (AROUNDEXITFNS DOAROUNDEXITFORMS) (BEFORELOGOUTFORMS) (AFTERLOGOUTFORMS))) (DECLARE%: DONTEVAL@LOAD DOCOPY (INITVARS (ADVISEDFNS))) (COMS (* ; "Versions") (FNS REALMEMORYSIZE LISPVERSION MICROCODEVERSION BCPLVERSION REQUIREVERSION)) (COMS (* ; "Interlisp's apropos") (FNS APROPOS APROPRINT)) (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 \BLKFDIFF.UFN \BLKFPLUS.UFN \BLKFTIMES.UFN \BLKSEP.UFN \BLKPERM.UFN \BLKEXPONENT.UFN \BLKFLOATP2COMP.UFN \BLKSMALLP2FLOAT.UFN \BLKMAG.UFN \FLOATTOBYTE.UFN \BLKFMAX.UFN \BLKFMIN.UFN \BLKFABSMAX.UFN \BLKFABSMIN.UFN) (* ; "functions for the 4045") (FNS \P-MISC2.UFN \LINES-EQUAL-P \GET-NEXT-RUN) (FNS IBLT1 IBLT2)) (VARS RINGBELLS.L1 RINGBELLS.L2) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (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 '1STCHDEL (CHARACTER ERASECHARCODE) TTBL) (DELETECONTROL 'NTHCHDEL (CHARACTER ERASECHARCODE) TTBL) (DELETECONTROL 'POSTCHDEL "" TTBL) (DELETECONTROL 'EMPTYCHDEL "" TTBL) (DELETECONTROL 'NOECHO NIL TTBL) (ECHOCONTROL ERASECHARCODE 'REAL]) ) (DECLARE%: DOCOPY DONTEVAL@LOAD (BACKSPACEDEL \ORIGTERMTABLE) (BACKSPACEDEL NIL) ) (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 'FIXP))) (APPENDTOVAR BACKGROUNDFNS PERIODICALLYRECLAIM) (APPENDTOVAR \SYSTEMTIMERVARS (\LASTRECLAIM SECONDS)) ) (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 'DIRTY)) SAVEVMMAX) (\FLUSHVMOK? 'SAVEVM T)) (* ; "Recalculate the hint before deciding it's okay") (RESETLST (AND SAVINGCURSOR (GETD '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]) ) (DEFINEQ (RINGBELLS [LAMBDA (N) (* ; "Edited 8-Apr-2023 13:30 by lmm") (* ; "Edited 10-May-88 23:01 by MASINTER") (DECLARE (GLOBALVARS RINGBELLS.L1 RINGBELLS.L2)) (OR (FIXP N) (SETQ N 1)) (to N do (PLAYTUNE RINGBELLS.L1) (FLASHWINDOW NIL NIL 100) (PLAYTUNE RINGBELLS.L2]) (FLASHWINDOW [LAMBDA (WIN? N FLASHINTERVAL SHADE) (* ; "Edited 6-Jan-2022 19:08 by rmk") (* 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 (WIN? (* ;;  "RMK: GETSTREAM even if not a window. Catches T, other streams. But NIL still means whole screen") (SETQ WIN? (GETSTREAM WIN? '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) (* ; "Edited 10-May-88 22:52 by MASINTER") (* ;;; "TUNEPAIRS is a list of (frequency . duration), where duration is (unfortunately) expressed in Dandelion Ticks (1/ \DLION.RCLKMILLISECOND) milliseconds") (SELECTC \MACHINETYPE ((LIST \DAYBREAK \MAIKO \DANDELION) (CL:UNWIND-PROTECT [for X in TUNEPAIRS do (COND ((CAR X) (BEEPON (CAR X))) (T (BEEPOFF))) (LET [(\DurationLimit (SETUPTIMER (if (EQ \RCLKMILLISECOND \DLION.RCLKMILLISECOND) then (CDR X) else (IQUOTIENT (ITIMES (CDR X) \RCLKMILLISECOND) \DLION.RCLKMILLISECOND) ) NIL 'TICKS] (until (TIMEREXPIRED? \DurationLimit 'TICKS) do (BLOCK] (BEEPOFF)) T) NIL]) ) (DECLARE%: EVAL@COMPILE DONTCOPY (DECLARE%: EVAL@COMPILE [PUTDEF '\PlayTimer 'RESOURCES '(NEW (SETUPTIMER 0] ) ) (/SETTOPVAL '\\PlayTimer.GLOBALRESOURCE NIL) (DECLARE%: DONTEVAL@LOAD DOCOPY (MOVD 'RINGBELLS '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) 'NORMAL) ((TAPE 60) (\DSPRATE 139 0 0) 'TAPE) (\ILLEGAL.ARG TYPE))) (\DORADO (SELECTQ TYPE ((NORMAL 77) (\DSPRATE 18 14 430) 'NORMAL) ((TAPE 60) (\DSPRATE 18 14 560) 'TAPE) ((PHILLIPS TAPEP) (\DSPRATE 58 25 520) 'PHILLIPS) (\ILLEGAL.ARG TYPE))) (\DANDELION (SELECTQ TYPE ((NORMAL 77) (\DEVICE.OUTPUT 14 7) 'NORMAL) ((TAPE 60) (\DEVICE.OUTPUT 142 7) 'TAPE) (\ILLEGAL.ARG TYPE))) 'NORMAL]) ) (RPAQ? \VIDEORATE 'NORMAL) (DECLARE%: DONTEVAL@LOAD DOCOPY (ADDTOVAR BREAKRESETFORMS (SETDISPLAYHEIGHT T)) (ADDTOVAR RESETFORMS (SETDISPLAYHEIGHT T)) ) (DECLARE%: DONTEVAL@LOAD DOCOPY (RPAQQ %#EOLCHARS 1) [OR (LISTP (EVALV 'EDITCHARACTERS)) (RPAQ EDITCHARACTERS '(J X Z Y N))] (ADDTOVAR POSTGREETFORMS (CNDIR)) (ADDTOVAR LISPUSERSDIRECTORIES ) ) (RPAQ? CLEANUPOPTIONS '(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 ) ) (* ; "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)) 'LISP) (AND MICROCODE (LESSP (fetch RVersion of \InterfacePage) (SETQ NEEDED MICROCODE)) 'MICROCODE) (AND BCPL (LESSP (fetch BVersion of \InterfacePage) (SETQ NEEDED BCPL)) 'BCPL] (ERROR (CONCAT "This " TYPE " version is too old. The minimum version required is ") NEEDED) NIL) (T T]) ) (* ; "Interlisp's apropos") (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) '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) '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) 'NOBIND)) (FRESHLINE OUTPUT))) (PRINTOUT OUTPUT |.P2| ATOM %,) (COND ((GETD ATOM) (APROPRINT "function:" (ARGLIST ATOM) OUTPUT))) (COND ((NEQ (SETQ VAL (GETTOPVAL ATOM)) '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]) ) (* ; "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) (* ; "Edited 14-Jul-87 13:34 by Snow") (SELECTQ ALPHA (0 (\GET-NEXT-RUN ARG1 ARG2)) (RAID "Illegal op to \MISC2.UFN -- " ALPHA]) (\MISC3.UFN [LAMBDA (ARG1 ARG2 ARG3 ALPHA) (* ; "Edited 14-Jul-87 10:33 by Snow") (SELECTQ ALPHA (0 (\BLKEXPONENT.UFN ARG1 ARG2 ARG3)) (1 (\BLKMAG.UFN ARG1 ARG2 ARG3)) (2 (\BLKSMALLP2FLOAT.UFN ARG1 ARG2 ARG3)) (3 (\BLKFLOATP2COMP.UFN 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)) (9 (%%SLOW-ARRAY-READ ARG1 ARG2 ARG3)) (10 (\LINES-EQUAL-P ARG1 ARG2 ARG3)) (RAID "Illegal op to \MISC3.UFN --" ALPHA]) (\MISC4.UFN [LAMBDA (ARG1 ARG2 ARG3 ARG4 ALPHA) (* ; "Edited 9-Apr-87 15:18 by jop") (SELECTQ ALPHA (0 (\BLKFTIMES.UFN ARG1 ARG2 ARG3 ARG4)) (1 (\BLKPERM.UFN ARG1 ARG2 ARG3 ARG4)) (2 (\BLKFPLUS.UFN ARG1 ARG2 ARG3 ARG4)) (3 (\BLKFDIFF.UFN ARG1 ARG2 ARG3 ARG4)) (4 (\BLKSEP.UFN ARG1 ARG2 ARG3 ARG4)) (6 (\BITMAPBIT ARG1 ARG2 ARG3 ARG4)) (7 (%%SLOW-ARRAY-WRITE 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) (* ; "Edited 5-Oct-89 18:59 by jds") (SELECTQ ALPHA (0 (\FBITMAPBIT.UFN ARG1 ARG2 ARG3 ARG4 ARG5 ARG6)) (RAID "Illegal op to \MISC6.UFN -- " ALPHA]) (\MISC7.UFN [LAMBDA (ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7 ALPHA) (* ; "Edited 6-Oct-89 09:44 by jds") (SELECTQ ALPHA (0 (\PSEUDOCOLOR.UFN ARG1 ARG2 ARG3 ARG4 ARG5 ARG6 ARG7)) (1 (* ;; "Fast turn a bitmap bit on, off, or invert it.") (* ;; "(\FASTBITMAPBIT BASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH)") (\FBITMAPBIT.UFN ARG1 ARG2 ARG3 ARG4 ARG5 ARG6)) (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 (\BLKFDIFF.UFN [LAMBDA (SOURCE1 SOURCE2 DEST COUNT) (* hdj "20-Sep-84 12:35") (for INDEX from 0 to (LLSH (SUB1 COUNT) 1) by 2 do (\PUTBASEFLOATP DEST INDEX (FDIFFERENCE (\GETBASEFLOATP SOURCE1 INDEX) (\GETBASEFLOATP SOURCE2 INDEX]) (\BLKFPLUS.UFN [LAMBDA (SOURCE1 SOURCE2 DEST COUNT) (* ; "Edited 8-Jan-87 16:27 by jop") (for INDEX from 0 to (LLSH (SUB1 COUNT) 1) by 2 do (\PUTBASEFLOATP DEST INDEX (FPLUS (\GETBASEFLOATP SOURCE1 INDEX) (\GETBASEFLOATP SOURCE2 INDEX]) (\BLKFTIMES.UFN [LAMBDA (SOURCE1 SOURCE2 DEST COUNT) (* ; "Edited 8-Jan-87 16:25 by jop") (for INDEX from 0 to (LLSH (SUB1 COUNT) 1) by 2 do (\PUTBASEFLOATP DEST INDEX (FTIMES (\GETBASEFLOATP SOURCE1 INDEX) (\GETBASEFLOATP SOURCE2 INDEX]) (\BLKSEP.UFN [LAMBDA (SOURCE1 SOURCE2 DEST CNT) (* ; "Edited 8-Jan-87 16:27 by jop") (for ALPHAINDEX from 0 to (LLSH (SUB1 CNT) 1) by 8 bind BETAINDEX GAMMAINDEX DELTAINDEX do (SETQ BETAINDEX (IDIFFERENCE CNT 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]) (\BLKPERM.UFN [LAMBDA (ORIG PERMUTATIONS DEST CNT) (* ; "Edited 8-Jan-87 16:26 by jop") (* ;; "destination (x) _ orig (perm (x))") (* ;; "args are arrays of smallps (words)") (* ;; "must fold initial into offset for compatibility with microcode") (for X from 0 to (SUB1 CNT) do (\PUTBASE DEST X (\GETBASE ORIG (\GETBASE PERMUTATIONS X]) (\BLKEXPONENT.UFN [LAMBDA (SOURCE DEST CNT) (* ; "Edited 8-Jan-87 15:45 by jop") (* ;;; "extract the exponent of each element of source, stick it in destination") (for X from 0 to (SUB1 CNT) do (\PUTBASE DEST X (fetch (FLOATP EXPONENT) of (\GETBASEFLOATP SOURCE (LLSH X 1]) (\BLKFLOATP2COMP.UFN [LAMBDA (SOURCE DEST CNT) (* ; "Edited 8-Jan-87 16:03 by jop") (* ;; "moves the contents of a Real array into a Complex array; sets imaginary part to 0") (for I from 0 to (SUB1 CNT) do (LET [($$BASE (\ADDBASE DEST (LLSH I 2] (\PUTBASEFLOATP $$BASE 0 (\GETBASEFLOATP SOURCE (LLSH I 1))) (\PUTBASEFLOATP $$BASE 2 0.0]) (\BLKSMALLP2FLOAT.UFN [LAMBDA (SOURCE DEST CNT) (* ; "Edited 8-Jan-87 15:50 by jop") (* ;; "convert an array of SMALLPs to FLOATPs") (for I from 0 to (SUB1 CNT) do (\PUTBASEFLOATP DEST (LLSH I 1) (FLOAT (\GETBASE SOURCE I]) (\BLKMAG.UFN [LAMBDA (COMPLEX-ARRAY MAGNITUDE-ARRAY CNT) (* ; "Edited 8-Jan-87 15:48 by jop") (bind COMPLEX-CNT REAL IMAG declare (TYPE FLOAT REAL IMAG) for MAGNITUDE from 0 to (SUB1 CNT) do (SETQ COMPLEX-CNT (LLSH MAGNITUDE 2)) (SETQ REAL (\GETBASEFLOATP COMPLEX-ARRAY COMPLEX-CNT)) (SETQ IMAG (\GETBASEFLOATP COMPLEX-ARRAY (IPLUS COMPLEX-CNT 2))) (\PUTBASEFLOATP MAGNITUDE-ARRAY (LLSH MAGNITUDE 1) (FPLUS (FTIMES REAL REAL) (FTIMES IMAG IMAG]) (\FLOATTOBYTE.UFN [LAMBDA (SBASE DBASE CNT) (* ; "Edited 8-Jan-87 16:17 by jop") (for I from 0 to (SUB1 (LRSH CNT 1)) do (\PUTBASE DBASE I (LOGOR (LLSH [FIX (FMIN 255.0 (FMAX 0.0 (\GETBASEFLOATP SBASE (LLSH I 2] 8) (FIX (FMIN 255.0 (FMAX 0.0 (\GETBASEFLOATP SBASE (IPLUS 2 (LLSH I 2]) (\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]) ) (* ; "functions for the 4045") (DEFINEQ (\P-MISC2.UFN [LAMBDA (ARG1 ARG2 ALPHA) (* ; "Edited 24-Jul-87 10:46 by Snow") (SELECTQ ALPHA (0 (\GET-NEXT-RUN ARG1 ARG2)) (RAID "Illegal op to \P-MISC2.UFN --" ALPHA]) (\LINES-EQUAL-P [LAMBDA (LAST-LINE CURRENT-LINE WORDS-PER-RASTER) (* ; "Edited 14-Jul-87 10:35 by Snow") (* ;; "Check if two raster lines have the same bytes") (CL:DOTIMES (I WORDS-PER-RASTER T) (CL:IF (NOT (EQ (\GETBASE LAST-LINE I) (\GETBASE CURRENT-LINE I))) (RETURN NIL]) (\GET-NEXT-RUN [LAMBDA (START MAX) (* ; "Edited 21-Jul-87 17:35 by Snow") (* ;; "Assume max > 0") (CL:IF (EQ MAX 0) (CL:ERROR "Max must be > 0: ~s" MAX)) (LET ((RUN-LENGTH 1) (OFFSET 0)) (CL:LOOP (* ;; "Find the next run ") [CL:DO ((INDEX (CL:1+ OFFSET) (CL:1+ INDEX)) (MATCHER (\GETBASE START OFFSET))) ((EQ INDEX MAX) (CL:WHEN (EQ RUN-LENGTH 1) (SETQ RUN-LENGTH 0) (SETQ OFFSET MAX))) (CL:IF (EQ MATCHER (\GETBASE START INDEX)) (CL:INCF RUN-LENGTH) (CL:IF (> RUN-LENGTH 1) (RETURN NIL) (RETURN (SETQ OFFSET INDEX] (CL:IF (OR (EQ OFFSET MAX) (> RUN-LENGTH 1)) (RETURN NIL))) (+ (CL:ASH OFFSET 8) RUN-LENGTH]) ) (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 ) (ADDTOVAR LAMA ) ) (PUTPROPS DMISC COPYRIGHT ("Venue & Xerox Corporation" T 1982 1983 1984 1985 1986 1987 1988 1989 1990) ) (DECLARE%: DONTCOPY (FILEMAP (NIL (4732 5435 (BACKSPACEDEL 4742 . 5433)) (5530 5963 (PERIODICALLYRECLAIM 5540 . 5961)) ( 6193 7884 (\DIRTYBACKGROUND 6203 . 6625) (\SAVEVMBACKGROUND 6627 . 7411) (COPYVM 7413 . 7882)) (8305 9504 (SETTIME 8315 . 9502)) (9505 13503 (RINGBELLS 9515 . 9975) (FLASHWINDOW 9977 . 11905) (PLAYTUNE 11907 . 13501)) (13765 19297 (DISPLAYDOWN 13775 . 14163) (SETDISPLAYHEIGHT 14165 . 16965) (VIDEORATE 16967 . 19295)) (19721 20442 (DOAROUNDEXITFORMS 19731 . 20440)) (20645 22360 (REALMEMORYSIZE 20655 . 20813) (LISPVERSION 20815 . 20968) (MICROCODEVERSION 20970 . 21128) (BCPLVERSION 21130 . 21283) ( REQUIREVERSION 21285 . 22358)) (22397 26975 (APROPOS 22407 . 26423) (APROPRINT 26425 . 26973)) (27001 30909 (READPRINTERPORT 27011 . 27152) (WRITEPRINTERPORT 27154 . 27309) (\READPRINTERPORT.UFN 27311 . 27500) (\WRITEPRINTERPORT.UFN 27502 . 27700) (\MISC1.UFN 27702 . 27855) (\MISC2.UFN 27857 . 28095) ( \MISC3.UFN 28097 . 28830) (\MISC4.UFN 28832 . 29382) (\MISC5.UFN 29384 . 29537) (\MISC6.UFN 29539 . 29789) (\MISC7.UFN 29791 . 30276) (\MISC8.UFN 30278 . 30579) (\MISC10.UFN 30581 . 30907)) (30963 38412 (\BLKFDIFF.UFN 30973 . 31538) (\BLKFPLUS.UFN 31540 . 32112) (\BLKFTIMES.UFN 32114 . 32689) ( \BLKSEP.UFN 32691 . 33822) (\BLKPERM.UFN 33824 . 34293) (\BLKEXPONENT.UFN 34295 . 34705) ( \BLKFLOATP2COMP.UFN 34707 . 35291) (\BLKSMALLP2FLOAT.UFN 35293 . 35652) (\BLKMAG.UFN 35654 . 36305) ( \FLOATTOBYTE.UFN 36307 . 36886) (\BLKFMAX.UFN 36888 . 37280) (\BLKFMIN.UFN 37282 . 37671) ( \BLKFABSMAX.UFN 37673 . 38042) (\BLKFABSMIN.UFN 38044 . 38410)) (38452 40270 (\P-MISC2.UFN 38462 . 38703) (\LINES-EQUAL-P 38705 . 39089) (\GET-NEXT-RUN 39091 . 40268)) (40271 44450 (IBLT1 40281 . 42283 ) (IBLT2 42285 . 44448))))) STOP