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

obsolete many lispusers (#702)

Browse Source 
* obsolete many lispusers

* NSDISPLAYSIZES isn't obsolete
This commit is contained in:
Larry Masinter
2022-02-25 14:40:37 -08:00
committed by GitHub
parent 200b73c39d
commit 601bc94fb7
50 changed files with 0 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

281
lispusers/HGRAPH
View File

@@ -1,281 +0,0 @@
(FILECREATED "24-Apr-87 19:08:21" {ERIS}<LISPUSERS>KOTO>HGRAPH.;2 12562
changes to: (FNS HARDCOPYWHOLEGRAPH)
previous date: "27-Jan-87 14:35:21" {PHYLUM}<LISPUSERS>KOTO>HGRAPH.;1)
(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT HGRAPHCOMS)
(RPAQQ HGRAPHCOMS ((FNS CEILING HARDCOPYDISPLAYGRAPH HARDCOPYWHOLEGRAPH)
(P (MOVD (QUOTE HARDCOPYGRAPH)
(QUOTE OLDHARDCOPYGRAPH))
(MOVD (QUOTE HARDCOPYWHOLEGRAPH)
(QUOTE HARDCOPYGRAPH)))
(* This is in order to fix the problem with borders on Interpress printers. I\t
seems that you cannot bitblt anything thinner than 36 pixel onto an
Interpress stream, why? Anyway, this fixes the problem by setting the border
width to 36)))
(DEFINEQ
(CEILING
[LAMBDA (NUMBER)
(COND
((EQP (FIX NUMBER)
NUMBER)
NUMBER)
(T (ADD1 (FIX NUMBER])
(HARDCOPYDISPLAYGRAPH
[LAMBDA (GRAPH STREAM CLIP/REG TRANS) (* bbb "27-Jan-87 11:52")
(* Displays GRAPH with coordinates system translated to TRANS on STREAM. POS=NIL is interpreted as 0\,0.
Draws links first then labels so that lattices don't have lines through the labels.)
(* This function is to be used together with 
HARDCOPYWHOLEGRAPH\, it assumes that the scaling of 
the graph is done already, for efficiency.)
(PROG (SCALE (LINEWIDTH 1))
[OR (type? POSITION TRANS)
(SETQ TRANS (CONSTANT (create POSITION
XCOORD _ 0
YCOORD _ 0]
(SETQ STREAM (GETSTREAM STREAM (QUOTE OUTPUT)))
(COND
((DISPLAYSTREAMP STREAM)
(* This is because PRIN3 on displaystreams can sometimes cause CR's to be output. GRAPHER/CENTERPRINTINAREA doesn't
have the rightmargin kludge that the CENTERPRINTINAREA in MENU has.)
(DSPRIGHTMARGIN 65000 STREAM))
(T (SETQ SCALE (DSPSCALE NIL STREAM))
[SETQ TRANS (create POSITION
XCOORD _ (FIXR (FTIMES SCALE (fetch XCOORD
of TRANS)))
YCOORD _ (FIXR (FTIMES SCALE (fetch YCOORD
of TRANS]
(SETQ LINEWIDTH SCALE)))
(for N in (fetch (GRAPH GRAPHNODES) of GRAPH)
do (DISPLAYNODELINKS N TRANS STREAM GRAPH T LINEWIDTH))
(for N in (fetch (GRAPH GRAPHNODES) of GRAPH) do (PRINTDISPLAYNODE N TRANS
STREAM
CLIP/REG])
(HARDCOPYWHOLEGRAPH
[LAMBDA (GraphOrWindow File ImageType Translation NoAlignmentDots DontCloseStream)
(* N.H.Briggs "24-Apr-87 19:07")
(* * Hardcopy \a whole graph from \a window using as many pages as necessary)
(* fix: moved SCALE/GRAPH outside the for loops for 
effiency.)
(* fix: moved SCALE.REGION inline, in order to avoid 
the LOADFNS in the COMS list.)
(LET ((Stream (OR (AND File (OPENP File (QUOTE OUTPUT))
File)
(OPENIMAGESTREAM File ImageType)))
(Graph (COND
((WINDOWP GraphOrWindow)
(WINDOWPROP GraphOrWindow (QUOTE GRAPH)))
(T GraphOrWindow)))
GraphUnitsPerPageUnit PageUnitsPerGraphUnit GraphRegionInGraphUnits GraphRegionInPageUnits
PageRegion PageWidthInGraphUnits PageHeightInGraphUnits GraphWidthInGraphUnits
GraphHeightInGraphUnits CornerXOffsetInGraphUnits CornerYOffsetInGraphUnits PageScale
LeftCenteringOffsetInGraphUnits BottomCenteringOffsetInGraphUnits PageNumberFont
NumberOfXPages NumberOfYPages XPageNumberPositionInPageUnits YPageNumberPositionInPageUnits
LeftXAlignmentInPageUnits RightXAlignmentInPageUnits LowerYAlignmentInPageUnits
UpperYAlignmentInPageUnits PageUnitsPerInch)
(SETQ PageScale (DSPSCALE NIL Stream))
(SETQ GraphUnitsPerPageUnit (FQUOTIENT 1.0 PageScale))
(SETQ PageUnitsPerGraphUnit PageScale) (* 72 screen points per inch.)
(SETQ PageUnitsPerInch (TIMES PageScale 72))
(SETQ GraphRegionInGraphUnits (GRAPHREGION Graph))
(SETQ CornerXOffsetInGraphUnits (MINUS (fetch (REGION LEFT) of
GraphRegionInGraphUnits)))
(SETQ CornerYOffsetInGraphUnits (MINUS (fetch (REGION BOTTOM) of
GraphRegionInGraphUnits)))
(* fix: moved SCALE.REGION inline, in order to avoid 
the LOADFNS in the COMS list.)
[SETQ GraphRegionInPageUnits (CREATEREGION (FIXR (QUOTIENT (fetch (REGION LEFT)
of
GraphRegionInGraphUnits)
GraphUnitsPerPageUnit))
(FIXR (QUOTIENT (fetch (REGION BOTTOM)
of
GraphRegionInGraphUnits)
GraphUnitsPerPageUnit))
(FIXR (QUOTIENT (fetch (REGION WIDTH)
of
GraphRegionInGraphUnits)
GraphUnitsPerPageUnit))
(FIXR (QUOTIENT (fetch (REGION HEIGHT)
of
GraphRegionInGraphUnits)
GraphUnitsPerPageUnit]
(SELECTQ (IMAGESTREAMTYPE Stream)
[INTERPRESS
(* * Make the clipping region be the whole page on Interpress streams)
(DSPCLIPPINGREGION (CREATEREGION 0 0 (FIXR (TIMES
PageUnitsPerInch 8.5)
)
(FIXR (TIMES
PageUnitsPerInch
11.0)))
Stream)
(* * Get rid of 1 inch margins except .5 inch at right and top)
(SETQ PageRegion (CREATEREGION 0 0 (FIXR (TIMES
PageUnitsPerInch 8.0)
)
(FIXR (TIMES PageUnitsPerInch
10.5]
[PRESS
(* * Make the clipping region be the whole page on Press streams)
(DSPCLIPPINGREGION (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch
8.5))
(FIXR (TIMES PageUnitsPerInch
11.0)))
Stream)
(* * Get rid of 1 inch margins except 1 inch at right and top)
(SETQ PageRegion (CREATEREGION 0 0 (FIXR (TIMES PageUnitsPerInch
7.5))
(FIXR (TIMES PageUnitsPerInch 10.0]
(SETQ PageRegion (DSPCLIPPINGREGION NIL Stream)))
(SETQ PageWidthInGraphUnits (TIMES (fetch (REGION WIDTH) of PageRegion)
GraphUnitsPerPageUnit))
(SETQ PageHeightInGraphUnits (TIMES (fetch (REGION HEIGHT) of PageRegion)
GraphUnitsPerPageUnit))
(SETQ GraphWidthInGraphUnits (fetch (REGION WIDTH) of GraphRegionInGraphUnits))
(SETQ GraphHeightInGraphUnits (fetch (REGION HEIGHT) of GraphRegionInGraphUnits))
(SETQ BottomCenteringOffsetInGraphUnits (QUOTIENT (DIFFERENCE PageHeightInGraphUnits
(REMAINDER
GraphHeightInGraphUnits
PageHeightInGraphUnits))
1.75))
(SETQ LeftCenteringOffsetInGraphUnits (QUOTIENT (DIFFERENCE PageWidthInGraphUnits
(REMAINDER
GraphWidthInGraphUnits
PageWidthInGraphUnits))
1.75))
(SETQ NumberOfYPages (CEILING (QUOTIENT GraphHeightInGraphUnits PageHeightInGraphUnits)
))
(SETQ NumberOfXPages (CEILING (QUOTIENT GraphWidthInGraphUnits PageWidthInGraphUnits)))
(SETQ PageNumberFont (FONTCREATE (QUOTE MODERN)
6))
(* * The page numbers are \a quarter of in after the edge of the printing edge and are in the upper right hand 
corner of the page. The pages are printed row-wise and no page numbers are printed on the last page.
The page numbers are positioned .25 inch to the right of the right edge of the page region and .35 inch up from the
top of the page region. The alignment dots are .25 inch to the right of the right edge of the page region and .25 
inch up from the page region.)
(SETQ XPageNumberPositionInPageUnits (PLUS (fetch (REGION RIGHT) of PageRegion)
(TIMES PageUnitsPerInch .25)))
(SETQ YPageNumberPositionInPageUnits (PLUS (fetch (REGION TOP) of PageRegion)
(TIMES PageUnitsPerInch .35)))
(SETQ LeftXAlignmentInPageUnits (TIMES PageUnitsPerInch .25))
(SETQ RightXAlignmentInPageUnits (PLUS (fetch (REGION RIGHT) of PageRegion)
(TIMES PageUnitsPerInch .25)))
(SETQ LowerYAlignmentInPageUnits (TIMES PageUnitsPerInch .25))
(SETQ UpperYAlignmentInPageUnits (PLUS (fetch (REGION TOP) of PageRegion)
(TIMES PageUnitsPerInch .25)))
(* Latest fix: moved SCALE/GRAPH outside the for loops
for effiency.)
(SETQ Graph (SCALE/GRAPH Graph Stream PageScale))
[for BottomOfPageInGraphUnits from 0 to GraphHeightInGraphUnits by
PageHeightInGraphUnits
as YPageNumber from 1
do (for LeftOfPageInGraphUnits from 0 to GraphWidthInGraphUnits by
PageWidthInGraphUnits
as XPageNumber from 1
do [HARDCOPYDISPLAYGRAPH Graph Stream (DSPCLIPPINGREGION NIL Stream)
(create POSITION
XCOORD _ (FIXR (PLUS
CornerXOffsetInGraphUnits
LeftCenteringOffsetInGraphUnits
(MINUS
LeftOfPageInGraphUnits)))
YCOORD _ (FIXR (PLUS
BottomCenteringOffsetInGraphUnits
CornerYOffsetInGraphUnits
(MINUS
BottomOfPageInGraphUnits]
(* * Print the alignment points)
[COND
((NOT NoAlignmentDots)
(* * The lower left page should not have \a dot in the lower left corner. Similarly for other corner pages.)
(COND
((NOT (AND (EQ XPageNumber 1)
(EQ YPageNumber 1)))
(MOVETO LeftXAlignmentInPageUnits LowerYAlignmentInPageUnits
Stream)
(printout Stream ".")))
(COND
((NOT (AND (EQ XPageNumber NumberOfXPages)
(EQ YPageNumber 1)))
(MOVETO RightXAlignmentInPageUnits LowerYAlignmentInPageUnits
Stream)
(printout Stream ".")))
(COND
((NOT (AND (EQ YPageNumber NumberOfYPages)
(EQ XPageNumber 1)))
(MOVETO LeftXAlignmentInPageUnits UpperYAlignmentInPageUnits
Stream)
(printout Stream ".")))
(COND
((NOT (AND (EQ XPageNumber NumberOfXPages)
(EQ YPageNumber NumberOfYPages)))
(MOVETO RightXAlignmentInPageUnits UpperYAlignmentInPageUnits
Stream)
(printout Stream "."]
(COND
((NOT (AND (EQ XPageNumber NumberOfXPages)
(EQ YPageNumber NumberOfYPages)))
(* Not on the very last page)
(DSPFONT PageNumberFont Stream)
(MOVETO XPageNumberPositionInPageUnits YPageNumberPositionInPageUnits
Stream)
(printout Stream XPageNumber "," YPageNumber)
(* Print the page number)
(DSPNEWPAGE Stream]
(COND
((NOT DontCloseStream)
(CLOSEF Stream])
)
(MOVD (QUOTE HARDCOPYGRAPH)
(QUOTE OLDHARDCOPYGRAPH))
(MOVD (QUOTE HARDCOPYWHOLEGRAPH)
(QUOTE HARDCOPYGRAPH))
(* This is in order to fix the problem with borders on Interpress printers. I\t seems that you
cannot bitblt anything thinner than 36 pixel onto an Interpress stream, why? Anyway, this
fixes the problem by setting the border width to 36)
(PUTPROPS HGRAPH COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (779 12115 (CEILING 789 . 928) (HARDCOPYDISPLAYGRAPH 930 . 2653) (HARDCOPYWHOLEGRAPH
2655 . 12113)))))
STOP

BIN
lispusers/HGRAPH.LCOM
View File

Binary file not shown.

185
lispusers/HOSTUP
View File

@@ -1,185 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "19-Oct-89 17:18:44" {ICE}<KOOMEN>LISPUSERS>MEDLEY>HOSTUP.;1 9510
changes to%: (VARS HOSTUPCOMS)
previous date%: "19-Oct-89 16:52:50" {ICE}<KOOMEN>LISPUSERS>MEDLEY>HOSTUP.;1)
(* "
Copyright (c) 1988, 1989 by Johannes A. G. M. Koomen. All rights reserved.
")
(PRETTYCOMPRINT HOSTUPCOMS)
(RPAQQ HOSTUPCOMS
((FNS HOSTUP?)
(INITVARS (HOSTUP.TIMEOUT 15000)
(HOSTUP.RETRYCNT 5))
(GLOBALVARS HOSTUP.TIMEOUT HOSTUP.RETRYCNT)
(DECLARE%: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE
(FILES SYSEDIT [FROM VALUEOF (for D in LISPUSERSDIRECTORIES until
(INFILEP (PACKFILENAME 'NAME 'LLNSDECLS 'BODY
(SETQ $$VAL
(PACKFILENAME
'HOST
(FILENAMEFIELD D 'HOST)
'DIRECTORY
(CONCAT "LISP>" MAKESYSNAME
">SOURCES"]
LLNSDECLS
(LOADCOMP)
LLNS))))
(DEFINEQ
(HOSTUP?
[LAMBDA (name) (* ; "Edited 19-Oct-89 16:51 by koomen")
(* ;; "Adapted from FILECACHE function \FCACHE.HOSTUP?")
(* ;; "Uses the globalvar HOSTUP.TIMEOUT (default: 15,000 msecs) to limit total wait time, and the globalvar HOSTUP.RETRYCNT (default: 5 times) to limit the number of retries")
 (* smL " 3-Sep-86 16:04")
(* ;;; "Try to determine if the host if able to respond")
(LET* [(DEV (\GETDEVICEFROMNAME name T NIL))
(retryCount (MAX 1 (FIX HOSTUP.RETRYCNT)))
(initialInterval (FIX (QUOTIENT (MAX 1000 HOSTUP.TIMEOUT)
(SUB1 (LSH 1 retryCount]
(SELECTQ (if DEV
then
(* ;; "use real DEV to determine the DEV type")
(SELECTQ (fetch OPENFILE of DEV)
((\LEAF.OPENFILE \FTP.OPENFILE)
'LEAF)
(\NSFILING.OPENFILE
'NSFILING)
(fetch DEVICENAME of DEV))
else
(* ;;
 "the FDEV doesn't exist, and we can't create one for it, so it must be down")
'NOFDEV)
(LEAF
(* ;; "We think its a LEAF server, so try PUP.ECHOUSER")
(RESETLST
(PROG ((i 1)
(interval initialInterval)
(PORT (BESTPUPADDRESS name PROMPTWINDOW))
(SOC (OPENPUPSOCKET))
echo OPUP IPUP ECHOPUPLENGTH)
(RESETSAVE NIL (LIST 'CLOSEPUPSOCKET SOC))
(OR PORT (RETURN NIL))
TryAgain
(if (IGREATERP i retryCount)
then (RETURN NIL))
(SETQ OPUP (ALLOCATE.PUP))
(SETUPPUP OPUP PORT \PUPSOCKET.ECHO \PT.ECHOME NIL SOC T)
(PUTPUPWORD OPUP 0 1)
(add (fetch PUPLENGTH of OPUP)
BYTESPERWORD)
(SETQ ECHOPUPLENGTH (fetch PUPLENGTH of OPUP))
(SENDPUP SOC OPUP)
[COND
((SETQ IPUP (GETPUP SOC interval))
(COND
((PROG1 (AND (EQ (fetch PUPTYPE of IPUP)
\PT.IAMECHO)
(EQ (fetch PUPIDHI of IPUP)
(fetch PUPIDHI of OPUP))
(EQ (fetch PUPIDLO of IPUP)
(fetch PUPIDLO of OPUP))
(EQ (fetch PUPLENGTH of IPUP)
ECHOPUPLENGTH)
(IEQP (GETPUPWORD IPUP 0)
1))
(RELEASE.PUP IPUP))
(RETURN T]
(SETQ i (ADD1 i))
(SETQ interval (ITIMES interval 2))
(GO TryAgain))))
(NSFILING (* ;
 "We think its an NSFILING server, so try NS.ECHOUSER")
(RESETLST
(PROG ((i 1)
(interval initialInterval)
(ECHOADDRESS (OR (COERCE-TO-NSADDRESS name \NS.WKS.Echo)
(\ILLEGAL.ARG name)))
NSOC OXIP ECHOXIPLENGTH IXIP)
(OR ECHOADDRESS (RETURN NIL))
[RESETSAVE NIL (LIST 'CLOSENSOCKET (SETQ NSOC (OPENNSOCKET]
(if (IGREATERP i retryCount)
then (RETURN NIL))
(SETQ OXIP (\FILLINXIP \XIPT.ECHO NSOC ECHOADDRESS))
(XIPAPPEND.WORD OXIP \XECHO.OP.REQUEST)
(XIPAPPEND.WORD OXIP 1)
(SETQ ECHOXIPLENGTH (fetch XIPLENGTH of OXIP))
TryAgain
(if (IGREATERP i retryCount)
then (RETURN NIL))
(SENDXIP NSOC OXIP)
[COND
((SETQ IXIP (GETXIP NSOC interval))
(COND
((PROG1 (AND (EQ (fetch XIPTYPE of IXIP)
\XIPT.ECHO)
(EQ (fetch XIPLENGTH of IXIP)
ECHOXIPLENGTH)
(EQ (\GETBASE (fetch XIPCONTENTS
of IXIP)
0)
\XECHO.OP.REPLY))
(RELEASE.XIP IXIP))
(RETURN T]
(SETQ i (ADD1 i))
(SETQ interval (LLSH interval 1))
(GO TryAgain))))
(FLOPPY
(* ;; "the FLOPPY disk")
(* ;;
 "Should be (FLOPPY.CAN.READP) but this triggers a bug in the Floppy handler")
T)
(TCP
(* ;; "A TCP device. Punt on them")
T)
(NOFDEV
(* ;; "we can't create an FDEV for the device, so it can't be up")
NIL)
T])
)
(RPAQ? HOSTUP.TIMEOUT 15000)
(RPAQ? HOSTUP.RETRYCNT 5)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS HOSTUP.TIMEOUT HOSTUP.RETRYCNT)
)
(DECLARE%: DONTEVAL@LOAD DONTCOPY EVAL@COMPILE
(FILESLOAD SYSEDIT [FROM VALUEOF (for D in LISPUSERSDIRECTORIES
until (INFILEP (PACKFILENAME 'NAME 'LLNSDECLS
'BODY
(SETQ $$VAL
(PACKFILENAME 'HOST
(FILENAMEFIELD D
'HOST)
'DIRECTORY
(CONCAT "LISP>" MAKESYSNAME
">SOURCES"]
LLNSDECLS
(LOADCOMP)
LLNS)
)
(PUTPROPS HOSTUP COPYRIGHT ("Johannes A. G. M. Koomen" 1988 1989))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1512 8312 (HOSTUP? 1522 . 8310)))))
STOP

BIN
lispusers/HOSTUP.TEDIT
View File

Binary file not shown.

240
lispusers/IPTALK
View File

@@ -1,240 +0,0 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "22-Jul-88 14:16:28" |{MCS:MCS:STANFORD}<LANE>IPTALK.;1| 12755 )
(PRETTYCOMPRINT IPTALKCOMS)
(RPAQQ IPTALKCOMS ((* TALK (Interim)
IP Interface)
(LOCALVARS . T)
(FNS TALK.IP.SERVER)
(FNS TALK.IP.USERNAME TALK.IP.CONNECT TALK.IP.EVENT TALK.START.IP.SERVER)
(INITVARS (TALK.UDP.PORT 517))
(GLOBALVARS TALK.UDP.PORT TALK.IP.CONSTANTS)
(DECLARE%: DONTCOPY (RECORDS TALK.IP.PACKET)
(CONSTANTS * TALK.IP.CONSTANTS))
(* etc)
(FILES TALK TCP TCPUDP)
(APPENDVARS (TALK.PROTOCOLTYPES (IP DODIP.HOSTP TALK.IP.USERNAME
TALK.IP.CONNECT TALK.IP.EVENT
TALK.START.IP.SERVER)))
(DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE (FILES ETHERRECORDS TCPEXPORTS)
)
(P (TALK.START.IP.SERVER))))
(* TALK (Interim) IP Interface)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DEFINEQ
(TALK.IP.SERVER
[LAMBDA NIL (* ; "Edited 17-Jun-88 13:45 by cdl")
(DECLARE (GLOBALVARS \IP.READY))
(LET (SOCKET)
(DECLARE (SPECVARS SOCKET))
(RESETLST
[RESETSAVE NIL `(UDP.CLOSE.SOCKET ,(SETQ SOCKET (UDP.OPEN.SOCKET TALK.UDP.PORT]
[bind PACKET RESPONSE SERVICE GAP.SERVICETYPE TALK.SERVICETYPE INPUTSTREAM
OUTPUTSTREAM PORT USER while \IP.READY
do (SETQ PACKET (UDP.GET SOCKET T))
(UDP.SETUP (SETQ RESPONSE (\ALLOCATE.ETHERPACKET))
(with IP PACKET IPSOURCEADDRESS)
(with UDP PACKET UDPSOURCEPORT)
0 SOCKET 'FREE)
(UDP.APPEND.BYTE RESPONSE (with TALK.IP.PACKET PACKET TALK.SERVICE.BYTE))
(if [OR [NULL (if (SETQ GAP.SERVICETYPE (ASSOC (with TALK.IP.PACKET
PACKET
TALK.SERVICE.BYTE
)
GAP.SERVICETYPES))
then (SETQ SERVICE (with GAP.SERVICETYPE
GAP.SERVICETYPE
GAP.SERVICENAME]
(NULL (SETQ TALK.SERVICETYPE (ASSOC SERVICE TALK.SERVICETYPES]
then (UDP.APPEND.BYTE RESPONSE \IPTALK.NOSERVICE)
(UDP.SEND SOCKET RESPONSE)
elseif [OR TALK.GAG (NOT (TALK.ANSWER (SETQ USER (with TALK.IP.PACKET
PACKET
TALK.IP.USERNAME)
)
SERVICE
'IP
(with IP PACKET IPSOURCEADDRESS]
then (UDP.APPEND.BYTE RESPONSE \IPTALK.NOANSWER)
(UDP.SEND SOCKET RESPONSE)
else (UDP.APPEND.BYTE RESPONSE \IPTALK.SUCCESS)
(UDP.APPEND.WORD RESPONSE (SETQ PORT (\TCP.SELECT.PORT)))
(UDP.SEND SOCKET RESPONSE)
(if (SETQ INPUTSTREAM (TCP.OPEN (with IP PACKET IPSOURCEADDRESS
)
NIL PORT 'PASSIVE 'INPUT))
then (TALK.PROCESS INPUTSTREAM (TCP.OTHER.STREAM INPUTSTREAM)
TALK.SERVICETYPE
'IP
'SERVER USER T])])
)
(DEFINEQ
(TALK.IP.USERNAME
[LAMBDA (INPUTSTREAM OUTPUTSTREAM SERVICETYPE MODE USER)
(* ; "Edited 8-Jun-88 15:45 by cdl")
(SELECTQ (with TALK.SERVICETYPE SERVICETYPE TALK.SERVICENAME)
((TTY Sketch) (* For (backward) compatibility)
USER)
(LET ((NAME (USERNAME)))
(PRINTOUT OUTPUTSTREAM (if (NOT (STREQUAL NAME (CONSTANT null)))
then NAME)
T)
(FORCEOUTPUT OUTPUTSTREAM)
(SETQ NAME (RATOM INPUTSTREAM TALK.READTABLE)) (* Eat EOL)
(BIN INPUTSTREAM)
(OR NAME USER])
(TALK.IP.CONNECT
[LAMBDA (HOST SERVICETYPES) (* ; "Edited 13-Jun-88 17:54 by cdl")
(DECLARE (SPECVARS HOST SERVICETYPES))
(LET
(SOCKET)
(DECLARE (SPECVARS SOCKET))
(RESETLST
[RESETSAVE NIL `(UDP.CLOSE.SOCKET ,(SETQ SOCKET (UDP.OPEN.SOCKET]
[PROG (NAME REQUEST RESPONSE INPUTSTREAM RESULT)
(while (STREQUAL (SETQ NAME (USERNAME))
(CONSTANT null)) do (LOGIN))
(if
[LITATOM
(SETQ RESULT
(for SERVICETYPE in SERVICETYPES
thereis (PROGN (UDP.SETUP (SETQ REQUEST (\ALLOCATE.ETHERPACKET))
HOST TALK.UDP.PORT 0 SOCKET 'FREE)
(UDP.APPEND.BYTE
REQUEST
(with GAP.SERVICETYPE
[for GAP.SERVICETYPE in GAP.SERVICETYPES
thereis (with GAP.SERVICETYPE
GAP.SERVICETYPE
(with TALK.SERVICETYPE
SERVICETYPE
(EQ GAP.SERVICENAME
TALK.SERVICENAME]
GAP.UNSPECIFIED))
(UDP.APPEND.BYTE REQUEST 0)
(UDP.APPEND.WORD REQUEST 0)
(UDP.APPEND.WORD REQUEST (NCHARS NAME))
(UDP.APPEND.STRING REQUEST NAME)
(if [SETQ RESPONSE
(UDP.EXCHANGE SOCKET REQUEST
(TIMES TALK.ANSWER.WAIT
(CONSTANT (PROGN
(* Convert to milliseconds and
 double in case they are idle)
(TIMES 2 1000]
then (SELECT (with TALK.IP.PACKET RESPONSE
TALK.STATUS)
(\IPTALK.SUCCESS T)
(\IPTALK.NOSERVICE NIL)
(\IPTALK.NOANSWER (RETURN 'ANSWER))
(RETURN 'CONNECT))
else (* Can't connect)
(RETURN 'CONNECT]
then (RETURN RESULT)
else (if (STREAMP (SETQ INPUTSTREAM (TCP.OPEN HOST (with TALK.IP.PACKET
RESPONSE
TALK.TEDIT.PORT)
NIL
'ACTIVE
'INPUT T)))
then [RETURN (CONS RESULT (CONS INPUTSTREAM (TCP.OTHER.STREAM
INPUTSTREAM]
else (RETURN 'CONNECT])])
(TALK.IP.EVENT
[LAMBDA (INPUTSTREAM OUTPUTSTREAM) (* cdl "18-May-87 16:29")
(while (AND (OPENP INPUTSTREAM)
(OPENP OUTPUTSTREAM)
(NOT (READP INPUTSTREAM))) do (if (EOFP INPUTSTREAM)
then (CLOSEF? INPUTSTREAM))
(BLOCK])
(TALK.START.IP.SERVER
[LAMBDA (RESTART) (* ; "Edited 17-Jun-88 12:20 by cdl")
[LET [(DEVICE (\GETDEVICEFROMNAME 'TCP 'NOERROR 'DONTCREATE]
(if DEVICE
then (* (Temporary) patch to make TCP
 streams handle NS character codes)
(with FDEV DEVICE (if (NULL READCHARCODE)
then (SETQ READCHARCODE (FUNCTION \GENERIC.READCCODE
]
(bind PROCESS while (AND (SETQ PROCESS (FIND.PROCESS 'TALK.IP.SERVER))
RESTART) do (DEL.PROCESS PROCESS)
(BLOCK)
yield (if PROCESS
then PROCESS
elseif \IP.READY
then (ADD.PROCESS '(TALK.IP.SERVER)
'RESTARTABLE
'SYSTEM])
)
(RPAQ? TALK.UDP.PORT 517)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS TALK.UDP.PORT TALK.IP.CONSTANTS)
)
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
(ACCESSFNS TALK.IP.PACKET [(TALK.PACKET.BASE (with UDP DATUM UDPCONTENTS))
(TALK.IP.USERNAME (\GETBASESTRING (with UDP DATUM UDPCONTENTS)
6
(with TALK.IP.PACKET DATUM
TALK.USERNAME.LENGTH]
(BLOCKRECORD TALK.PACKET.BASE ((TALK.SERVICE.BYTE BYTE)
(TALK.STATUS BYTE)
(TALK.TEDIT.PORT WORD)
(TALK.USERNAME.LENGTH WORD))))
)
(RPAQQ TALK.IP.CONSTANTS ((\IPTALK.SUCCESS 0)
(\IPTALK.NOSERVICE 1)
(\IPTALK.NOANSWER 2)))
(DECLARE%: EVAL@COMPILE
(RPAQQ \IPTALK.SUCCESS 0)
(RPAQQ \IPTALK.NOSERVICE 1)
(RPAQQ \IPTALK.NOANSWER 2)
(CONSTANTS (\IPTALK.SUCCESS 0)
(\IPTALK.NOSERVICE 1)
(\IPTALK.NOANSWER 2))
)
)
(* etc)
(FILESLOAD TALK TCP TCPUDP)
(APPENDTOVAR TALK.PROTOCOLTYPES (IP DODIP.HOSTP TALK.IP.USERNAME TALK.IP.CONNECT TALK.IP.EVENT
TALK.START.IP.SERVER))
(DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE
(FILESLOAD ETHERRECORDS TCPEXPORTS)
)
(TALK.START.IP.SERVER)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1313 4720 (TALK.IP.SERVER 1323 . 4718)) (4721 11119 (TALK.IP.USERNAME 4731 . 5475) (
TALK.IP.CONNECT 5477 . 9538) (TALK.IP.EVENT 9540 . 9963) (TALK.START.IP.SERVER 9965 . 11117)))))
STOP

BIN
lispusers/IRIS.TEdit
View File

Binary file not shown.

1708
lispusers/IRISCONSTANTS
View File

File diff suppressed because it is too large Load Diff

469
lispusers/IRISDEMOFNS
View File

@@ -1,469 +0,0 @@
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")
(FILECREATED " 2-Feb-87 21:13:01" {ERIS}<IRIS>NEXT>IRISDEMOFNS.;10 21478
changes to%: (VARS IRISDEMOFNSCOMS)
(FNS TETRA TETRA.DRAW.FACE TETRA.OBJ)
previous date%: " 4-Mar-86 10:57:38" {ERIS}<IRIS>NEXT>IRISDEMOFNS.;8)
(PRETTYCOMPRINT IRISDEMOFNSCOMS)
(RPAQQ IRISDEMOFNSCOMS [(FNS IRIS.DEGREES SNOW SPHERE TETRA TETRA.COLOR TETRA.DRAW.FACE TETRA.OBJ
TETRA.TILT.AND.RECURSE)
(VARS IRIS.TILT TETRA.COLOR TETRA.EDGE.COLOR TETRA.SHRINK TETRA.TILT
IV.DEFAULT.STYLE)
(* ;; "minimal 3-d support for the tetra demo")
(RECORDS 3POINT)
(FNS 3DOT 3DRAWTO 3MOVETO 3NORMALIZE 3PLUS 3POINT 3UNITCROSSPRODUCT
3DIFFERENCE 3CROSSPRODUCT 3LENGTH 3LINE 3TIMES DRAW.FACE? IRIS.XLATE)
(VARS \IRIS.DUMMYBUFFER \IRIS.FEEDBACKBUFFER)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDVARS (NLAMA)
(NLAML)
(LAMA TETRA])
(DEFINEQ
(IRIS.DEGREES
[LAMBDA (DEGREES) (* edited%: "13-Dec-85 18:32")
(* Takes an angle in degrees and returns an angle as the iris likes it
 (tenths))
(FIX (TIMES DEGREES 10])
(SNOW
[LAMBDA (N) (* edited%: "11-Dec-85 23:12")
(for I to (OR N (RAND 5 20)) do (IRIS.PUSHMATRIX)
(IRIS.TRANSLATE (RAND 0 SCREENWIDTH)
(RAND 0 SCREENHEIGHT)
0 \IRISSTREAM)
(IRIS.ROTATE (RAND 0 1800)
88)
(IRIS.ROTATE (RAND 0 1800)
89)
(IRIS.ROTATE (RAND 0 1800)
90)
(IRIS.SCALE (RAND 0.1 1)
(RAND 0.1 1)
(RAND 0.1 1))
(SPHERE " Noel" (RAND 5 90)
(RAND 1 3))
(IRIS.POPMATRIX])
(SPHERE
[LAMBDA (MSG THETA COUNT) (* edited%: "11-Dec-85 15:24")
(IRIS.PUSHMATRIX)
(OR THETA (SETQ THETA 30))
(OR COUNT (SETQ COUNT 3))
(DSPCOLOR 'RED \IRISSTREAM)
(IRIS.PUSHMATRIX)
(for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM)
(DSPCOLOR (IMOD I 7)
\IRISSTREAM)
(IRIS.ROTATE (ITIMES 10 THETA)
IRIS.ZAXIS)
(PRINTOUT \IRISSTREAM MSG))
(IRIS.POPMATRIX)
(IRIS.PUSHMATRIX)
(IRIS.ROTATE 900 IRIS.YAXIS)
(DSPCOLOR 'BLACK \IRISSTREAM)
(SELECTQ COUNT
(1 NIL)
(for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM)
(DSPCOLOR (IMOD I 7)
\IRISSTREAM)
(IRIS.ROTATE (ITIMES 10 THETA)
IRIS.ZAXIS)
(PRINTOUT \IRISSTREAM MSG)))
(IRIS.POPMATRIX)
(DSPCOLOR 'CYAN \IRISSTREAM)
(IRIS.ROTATE 900 IRIS.XAXIS)
(SELECTQ COUNT
((1 2)
NIL)
(for I from 0 to (IQUOTIENT 360 THETA) do (MOVETO 0 0 \IRISSTREAM)
(DSPCOLOR (IMOD I 7)
\IRISSTREAM)
(IRIS.ROTATE (ITIMES 10 THETA)
IRIS.ZAXIS)
(PRINTOUT \IRISSTREAM MSG)))
(IRIS.POPMATRIX])
(TETRA
[CL:LAMBDA (&OPTIONAL (SIDE-LENGTH 200)
(RECURSIVE-DEPTH 3)
(SHRINK-FACTOR TETRA.SHRINK)
(STYLE 'WIREFRAME)
(DONTBASERECURSE NIL)) (* ; "Edited 31-Jan-87 17:29 by gbn")
(* ;;; "Draws a recursive tetrahedron. shrinkfactor is the ratio of side length of parent and child. style is one of 'wireframe, polygon or normal.")
(LET ((RECURSIVE-DEPTH (OR RECURSIVE-DEPTH 5))
(SHRINK-FACTOR (OR SHRINK-FACTOR TETRA.SHRINK))
(STYLE (OR STYLE IV.DEFAULT.STYLE)))
(if (EQ 0 RECURSIVE-DEPTH)
then (* ; "done")
NIL
else (TETRA.OBJ SIDE-LENGTH (TETRA.COLOR RECURSIVE-DEPTH)
STYLE DONTBASERECURSE)
(if (NOT DONTBASERECURSE)
then (IRIS.PUSHMATRIX)
(IRIS.ROTATE (IRIS.DEGREES 180)
IRIS.YAXIS)
(IRIS.ROTATE (IRIS.DEGREES (MINUS TETRA.TILT))
IRIS.XAXIS)
(IRIS.TRANSLATE 0 (QUOTIENT SIDE-LENGTH (SQRT 3))
0)
(TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE
)
(IRIS.POPMATRIX))
(IRIS.PUSHMATRIX)
(IRIS.TRANSLATE 0 (QUOTIENT SIDE-LENGTH (SQRT 3))
0) (* ;
 "move the origin to the middle of the base of the tetrahedron")
(TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE)
(IRIS.ROTATE (IRIS.DEGREES 120)
IRIS.ZAXIS)
(TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE)
(IRIS.ROTATE (IRIS.DEGREES 120)
IRIS.ZAXIS)
(TETRA.TILT.AND.RECURSE SIDE-LENGTH RECURSIVE-DEPTH SHRINK-FACTOR STYLE)
(* ;; "(IRIS.TRANSLATE 0 (MINUS (QUOTIENT X (SQRT 3))) 0) (IRIS.ROTATE (IRIS.DEGREES 180) IRIS.XAXIS) (IRIS.ROTATE (IRIS.DEGREES 180) IRIS.ZAXIS) (TETRA.TILT.AND.RECURSE X RECDEPTH)")
(IRIS.POPMATRIX])
(TETRA.COLOR
[LAMBDA (COLOR) (* gbn "21-Feb-86 17:11")
(IMOD COLOR 8])
(TETRA.DRAW.FACE
[LAMBDA (STYLE COLOR LEFT RIGHT TOP) (* ; "Edited 31-Jan-87 18:44 by gbn")
(* ;; "handles drawing a single face. Left right and top are just logical names for the points of the triangle. They need not correspond to Tetra's interpretation of those names.")
(SELECTQ STYLE
(WIREFRAME)
((POLYGON NORMALS BACKFACES)
(if (NOT DONTBASERECURSE)
then (IRIS.POLF 3 (LIST LEFT RIGHT FRONT)))
(DSPCOLOR COLOR \IRISSTREAM)
(IRIS.POLF 3 (LIST LEFT RIGHT TOP)) (* ;
 "(IRIS.POLF 3 (LIST FRONT RIGHT TOP)) (IRIS.POLF 3 (LIST FRONT LEFT TOP))")
(DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM)
(3MOVETO \IRISSTREAM LEFT)
(3DRAWTO \IRISSTREAM RIGHT)
(3DRAWTO \IRISSTREAM TOP)
(3DRAWTO \IRISSTREAM LEFT)
(SELECTQ STYLE
(POLYGON)
(NORMALS (* ;
 "compute and draw a normal to the face")
[LET* ((LEFTTOP (3DIFFERENCE TOP LEFT))
(LEFTRIGHT (3DIFFERENCE RIGHT LEFT))
(NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT))
(NORMAL (3DIFFERENCE NORMALENDPT LEFT)))
(3LINE LEFT (3PLUS LEFT (3TIMES (3NORMALIZE NORMAL)
50])
(BACKFACES (* ;
 "compute and draw a normal to the face")
(LET* ((LEFTTOP (3DIFFERENCE TOP LEFT))
(LEFTRIGHT (3DIFFERENCE RIGHT LEFT))
(NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT))
(NORMAL (3DIFFERENCE NORMALENDPT LEFT))
(EYEVECTOR (3DIFFERENCE (IRIS.XLATE IV.VIEWPT)
LEFT)))
(if (LESSP (3DOT EYEVECTOR NORMAL)
0.0)
then (* ; "this is not a backface so drawit")
(DSPCOLOR COLOR \IRISSTREAM)
(IRIS.POLF 3 (LIST LEFT RIGHT TOP))
(DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM)
(3MOVETO \IRISSTREAM LEFT)
(3DRAWTO \IRISSTREAM RIGHT)
(3DRAWTO \IRISSTREAM TOP)
(3DRAWTO \IRISSTREAM LEFT))))
(ERROR "Unknown drawing style: " STYLE)))
(ERROR "Unknown drawing style: " STYLE])
(TETRA.OBJ
[LAMBDA (X COLOR STYLE DONTBASERECURSE) (* ; "Edited 31-Jan-87 17:35 by gbn")
(* ;;; "The function that draws a single tetrahedron (and optionally, it's faces.)")
(LET ([TOP (3POINT 0 (QUOTIENT X (SQRT 3))
(SQRT (TIMES (TIMES X X)
(QUOTIENT 8 3.0]
(LEFT (3POINT (MINUS X)
0 0))
(RIGHT (3POINT X 0 0))
(FRONT (3POINT 0 (TIMES (SQRT 3)
X)
0)))
(IRIS.PUSHATTRIBUTES)
(SELECTQ STYLE
(WIREFRAME (DSPCOLOR COLOR \IRISSTREAM)
(3MOVETO \IRISSTREAM LEFT)
(3DRAWTO \IRISSTREAM RIGHT)
(3DRAWTO \IRISSTREAM FRONT)
(3DRAWTO \IRISSTREAM LEFT)
(3DRAWTO \IRISSTREAM TOP)
(3DRAWTO \IRISSTREAM RIGHT)
(3MOVETO \IRISSTREAM FRONT)
(3DRAWTO \IRISSTREAM TOP))
((POLYGON NORMALS BACKFACES)
(DSPCOLOR COLOR \IRISSTREAM)
(if (NOT DONTBASERECURSE)
then (TETRA.DRAW.FACE STYLE COLOR LEFT RIGHT FRONT))
(TETRA.DRAW.FACE STYLE COLOR LEFT RIGHT TOP)
(TETRA.DRAW.FACE STYLE COLOR RIGHT FRONT TOP)
(TETRA.DRAW.FACE STYLE COLOR FRONT LEFT TOP))
(ERROR "Unknown drawing style: " STYLE))
(IRIS.POPATTRIBUTES])
(TETRA.TILT.AND.RECURSE
[LAMBDA (X RECDEPTH SHRINKFACTOR STYLE) (* edited%: "16-Dec-85 17:41")
(* * sets up the transformations to recurse, and calls tetra)
(* * called with 0 0 0 already placed at the "bottom edge" on the face of the
 larger tetra)
(* BOTTOMY is the y component of the point BOTTOM, which is not explicitly
 calculated)
(LET [(BOTTOMY (QUOTIENT X (SQRT 3]
(IRIS.PUSHMATRIX)
(IRIS.TRANSLATE 0 (MINUS (QUOTIENT X (SQRT 3)))
0)
(IRIS.ROTATE (IRIS.DEGREES TETRA.TILT)
IRIS.XAXIS)
(IRIS.TRANSLATE 0 (DIFFERENCE BOTTOMY (TIMES BOTTOMY SHRINKFACTOR))
0)
(IRIS.SCALE SHRINKFACTOR SHRINKFACTOR SHRINKFACTOR)
(TETRA (TIMES SHRINKFACTOR X)
(SUB1 RECDEPTH)
SHRINKFACTOR STYLE T) (* IRIS.TRANSLATE 0 (MINUS BOTTOMY) 0)
(* put 0 0 0 back on the edge of the larger tetra)
(IRIS.POPMATRIX])
)
(RPAQQ IRIS.TILT 70.52878)
(RPAQQ TETRA.COLOR BLUE)
(RPAQQ TETRA.EDGE.COLOR BLACK)
(RPAQQ TETRA.SHRINK 0.7)
(RPAQQ TETRA.TILT 70.52878)
(RPAQQ IV.DEFAULT.STYLE WIREFRAME)
(* ;; "minimal 3-d support for the tetra demo")
(DECLARE%: EVAL@COMPILE
(RECORD 3POINT (|3X| |3Y| |3Z|))
)
(DEFINEQ
(3DOT
[LAMBDA (A B) (* gbn " 3-Mar-86 17:54")
(PLUS (TIMES (fetch |3X| of A)
(fetch |3X| of B))
(TIMES (fetch |3Y| of A)
(fetch |3Y| of B))
(TIMES (fetch |3Z| of A)
(fetch |3Z| of B])
(3DRAWTO
[LAMBDA (STREAM XOR3PT Y Z) (* edited%: "13-Dec-85 16:16")
(if (NUMBERP XOR3PT)
then (IRIS.DRAW XOR3PT Y Z STREAM)
else (IRIS.DRAW (fetch |3X| of XOR3PT)
(fetch |3Y| of XOR3PT)
(fetch |3Z| of XOR3PT)
STREAM])
(3MOVETO
[LAMBDA (STREAM XOR3PT Y Z) (* edited%: "13-Dec-85 16:16")
(if (NUMBERP XOR3PT)
then (IRIS.MOVE XOR3PT Y Z STREAM)
else (IRIS.MOVE (fetch |3X| of XOR3PT)
(fetch |3Y| of XOR3PT)
(fetch |3Z| of XOR3PT)
STREAM])
(3NORMALIZE
[LAMBDA (3VECTOR) (* gbn " 3-Mar-86 15:51")
(* * Produces a vector with the same direction but unit magnitude as 3VECTOR)
(LET ((LENGTH (3LENGTH 3VECTOR)))
(3POINT (QUOTIENT (fetch |3X| of 3VECTOR)
LENGTH)
(QUOTIENT (fetch |3Y| of 3VECTOR)
LENGTH)
(QUOTIENT (fetch |3Z| of 3VECTOR)
LENGTH])
(3PLUS
[LAMBDA (A B) (* gbn " 3-Mar-86 14:46")
(* vector sum of a and b)
(3POINT (PLUS (fetch |3X| of A)
(fetch |3X| of B))
(PLUS (fetch |3Y| of A)
(fetch |3Y| of B))
(PLUS (fetch |3Z| of A)
(fetch |3Z| of B])
(3POINT
[LAMBDA (X Y Z) (* edited%: "13-Dec-85 16:02")
(* creates a |3-d| point)
(create 3POINT
|3X| _ X
|3Y| _ Y
|3Z| _ Z])
(3UNITCROSSPRODUCT
[LAMBDA (A B) (* gbn " 3-Mar-86 15:51")
(LET* ((NORMAL (3CROSSPRODUCT A B))
(LENGTH (3LENGTH NORMAL)))
(replace |3X| of NORMAL with (QUOTIENT (fetch |3X| of NORMAL)
LENGTH))
(replace |3Y| of NORMAL with (QUOTIENT (fetch |3Y| of NORMAL)
LENGTH))
(replace |3Z| of NORMAL with (QUOTIENT (fetch |3Z| of NORMAL)
LENGTH))
NORMAL])
(3DIFFERENCE
[LAMBDA (DEST SOURCE) (* gbn "28-Feb-86 17:13")
(* vector difference from source to
 dest)
(3POINT (DIFFERENCE (fetch |3X| of DEST)
(fetch |3X| of SOURCE))
(DIFFERENCE (fetch |3Y| of DEST)
(fetch |3Z| of SOURCE))
(DIFFERENCE (fetch |3Z| of DEST)
(fetch |3Z| of SOURCE])
(3CROSSPRODUCT
[LAMBDA (A B) (* gbn "28-Feb-86 17:17")
(3POINT (DIFFERENCE (TIMES (fetch |3Y| of A)
(fetch |3Z| of B))
(TIMES (fetch |3Z| of A)
(fetch |3Y| of B)))
(DIFFERENCE (TIMES (fetch |3Z| of A)
(fetch |3X| of B))
(TIMES (fetch |3X| of A)
(fetch |3Z| of B)))
(DIFFERENCE (TIMES (fetch |3X| of A)
(fetch |3Y| of B))
(TIMES (fetch |3Y| of A)
(fetch |3X| of B])
(3LENGTH
[LAMBDA (A) (* gbn " 3-Mar-86 15:36")
(* * returns the euclidean norm of the |3d| vector)
(SQRT (PLUS (TIMES (fetch |3X| of A)
(fetch |3X| of A))
(TIMES (fetch |3Y| of A)
(fetch |3Y| of A))
(TIMES (fetch |3Z| of A)
(fetch |3Z| of A])
(3LINE
[LAMBDA (A B) (* gbn "28-Feb-86 17:22")
(3MOVETO \IRISSTREAM A)
(3DRAWTO \IRISSTREAM B])
(3TIMES
[LAMBDA (VECTOR SCALAR) (* gbn " 3-Mar-86 14:47")
(3POINT (TIMES (fetch |3X| of VECTOR)
SCALAR)
(TIMES (fetch |3Y| of VECTOR)
SCALAR)
(TIMES (fetch |3Z| of VECTOR)
SCALAR])
(DRAW.FACE?
[LAMBDA (LEFT RIGHT TOP COLOR) (* gbn " 3-Mar-86 18:45")
(* handles drawing a single face. Left right and top are just logical names for
 the points of the triangle. They need not correspond to Tetra's interpretation
 of those names.)
(LET* ((LEFTTOP (3DIFFERENCE TOP LEFT))
(LEFTRIGHT (3DIFFERENCE RIGHT LEFT))
(NORMALENDPT (3CROSSPRODUCT LEFTTOP LEFTRIGHT))
(NORMAL (3DIFFERENCE NORMALENDPT LEFT))
(EYEVECTOR (3DIFFERENCE (IRIS.XLATE IV.VIEWPT)
LEFT)))
(if (GREATERP (3DOT EYEVECTOR NORMAL)
0.0)
then (* this is not a backface so drawit)
(DSPCOLOR (OR COLOR 'CYAN)
\IRISSTREAM)
(IRIS.POLF 3 (LIST LEFT RIGHT TOP))
(DSPCOLOR TETRA.EDGE.COLOR \IRISSTREAM)
(3MOVETO \IRISSTREAM LEFT)
(3DRAWTO \IRISSTREAM RIGHT)
(3DRAWTO \IRISSTREAM TOP)
(3DRAWTO \IRISSTREAM LEFT])
(IRIS.XLATE
[LAMBDA (3VECTOR) (* gbn " 3-Mar-86 17:18")
(IRIS.FEEDBACK \IRIS.DUMMYBUFFER 9)
(IRIS.XFPT (fetch |3X| of 3VECTOR)
(fetch |3Y| of 3VECTOR)
(fetch |3Z| of 3VECTOR))
(if (NOT (EQUAL (IRIS.ENDFEEDBACK \IRIS.FEEDBACKBUFFER)
9))
then (HELP "NINE ITEMS NOT RETURNED"))
(3POINT (create FLOATP
HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 2)
LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 3))
(create FLOATP
HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 4)
LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 5))
(create FLOATP
HIWORD _ (ELT \IRIS.FEEDBACKBUFFER 6)
LOWORD _ (ELT \IRIS.FEEDBACKBUFFER 7])
)
(RPAQ \IRIS.DUMMYBUFFER (READARRAY 9 (QUOTE FIXP) 1))
(1 1 1 1 1 1 1 1 1 NIL
)
(RPAQ \IRIS.FEEDBACKBUFFER (READARRAY 9 (QUOTE FIXP) 1))
(56 17275 9800 17288 8544 17585 41814 17585 41814 NIL
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA TETRA)
)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1291 13248 (IRIS.DEGREES 1301 . 1568) (SNOW 1570 . 2622) (SPHERE 2624 . 4537) (TETRA
4539 . 7134) (TETRA.COLOR 7136 . 7267) (TETRA.DRAW.FACE 7269 . 10466) (TETRA.OBJ 10468 . 12107) (
TETRA.TILT.AND.RECURSE 12109 . 13246)) (13570 21123 (3DOT 13580 . 13945) (3DRAWTO 13947 . 14317) (
3MOVETO 14319 . 14689) (3NORMALIZE 14691 . 15221) (3PLUS 15223 . 15686) (3POINT 15688 . 15975) (
3UNITCROSSPRODUCT 15977 . 16640) (3DIFFERENCE 16642 . 17238) (3CROSSPRODUCT 17240 . 18011) (3LENGTH
18013 . 18495) (3LINE 18497 . 18667) (3TIMES 18669 . 19007) (DRAW.FACE? 19009 . 20260) (IRIS.XLATE
20262 . 21121)))))
STOP

574
lispusers/IRISIO
View File

@@ -1,574 +0,0 @@
(FILECREATED "12-Nov-85 19:11:43" {ERIS}<IRIS>KOTO>IRISIO.;2 21026
changes to: (VARS IRISIOCOMS)
(FNS IRIS.SENDFS)
previous date: " 9-Sep-85 13:47:28" {ERIS}<IRIS>KOTO>IRISIO.;1)
(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT IRISIOCOMS)
(RPAQQ IRISIOCOMS [(COMS (* User level primitives)
(FNS IRIS.GEXIT IRIS.GFLUSH IRIS.GINIT IRIS.GRESET)
(MACROS IRIS.GFLUSH))
(COMS (* Lower level primitives)
(FNS IRIS.RECBS IRIS.RECFS IRIS.RECLS IRIS.RECSS IRIS.SENDBS IRIS.SENDFS IRIS.SENDLS
IRIS.SENDQS IRIS.SENDSS IRIS.SETFASTCOM)
(MACROS IRIS.DOSYNC IRIS.ECHOFF IRIS.ECHOON IRIS.FLUSHG IRIS.GCMD IRIS.GETGCHAR
IRIS.GEXIT IRIS.GFINISH IRIS.PUTGCHAR IRIS.REC32 IRIS.REC6 IRIS.RECB IRIS.RECCR
IRIS.RECF IRIS.RECL IRIS.RECO IRIS.RECOS IRIS.RECS IRIS.SEND6 IRIS.SEND8
IRIS.SENDB IRIS.SENDC IRIS.SENDF IRIS.SENDL IRIS.SENDO IRIS.SENDS
SPPINPUTSTREAM SPPSTREAM?)
(CONSTANTS (STDERR T)
(IRIS\AESC 46)
(IRIS\RESC 126)
(IRIS\TESC 16)))
[DECLARE: EVAL@LOAD DONTCOPY (P (LOADDEF (QUOTE FLOATP)
(QUOTE RECORD)
(QUOTE LLARITH]
(INITVARS (IRISCONN)
(IRISSPPON T))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* User level primitives)
(DEFINEQ
(IRIS.GEXIT
(LAMBDA (stream)
(if stream
then (IRIS.FLUSHG stream)
else (IRIS.FLUSHG IRISCONN))))
(IRIS.GFLUSH
(LAMBDA (stream)
(if stream
then (IRIS.FLUSHG stream)
else (IRIS.FLUSHG IRISCONN))))
(IRIS.GINIT
(LAMBDA (STREAM) (* LeL, " 3-Sep-85 17:18")
(if (NOT STREAM)
then (SETQ STREAM IRISCONN))
(IRIS.SETFASTCOM STREAM) (* Assumes that we communicate on the net)
(IRIS.XGINIT STREAM)
(IRIS.FLUSHG STREAM)))
(IRIS.GRESET
(LAMBDA (STREAM) (* LeL, " 3-Sep-85 17:18")
(IRIS.XGRESET STREAM)
(IRIS.FLUSHG STREAM)))
)
(DECLARE: EVAL@COMPILE
[PUTPROPS IRIS.GFLUSH MACRO (arg? (* Just for speed...)
(if arg? then (CONS (QUOTE IRIS.FLUSHG)
arg?)
else
(QUOTE (IRIS.FLUSHG IRISCONN]
)
(* Lower level primitives)
(DEFINEQ
(IRIS.RECBS
(LAMBDA (values stream) (* LeL, " 6-Sep-85 14:15")
(* Receive an array of bytes and fill VALUES)
(PROG (nLongs nBytes)
(SETQ nLongs (LRSH (IPLUS (SETQ nBytes (IRIS.RECL stream))
3)
2)) (* Number of longs -
FIXP -
to recieve)
(if (NEQ IRIS\RESC (IRIS.GETGCHAR stream))
then (PRINT "IRIS.RECBS: error in array transport" STDERR)
(while (SPP.READP stream) do (BIN stream))
(* Flush input)
(RETURN))
(for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 3
bind aLong (arrayMax _(IPLUS (ARRAYORIG values)
nVals))
do (SETQ aLong (IRIS.REC32 stream)) (* Recieve 6 six-bits words to make a long)
(if (IRIS.DOSYNC i)
then (IRIS.GETGCHAR stream)
(IRIS.PUTGCHAR IRIS\AESC stream)
(IRIS.FLUSHG stream))
(for j from 0 to 2 when (LEQ (IPLUS ptr j)
arrayMax)
do (SETA values (IPLUS ptr j)
(LOGAND 255 (LRSH aLong (LLSH j 3))))))
(IRIS.GETGCHAR stream))))
(IRIS.RECFS
(LAMBDA (values stream) (* LeL, " 6-Sep-85 12:50")
(* Common subroutine to IRIS.RECFS and IRIS.RECLS)
(PROG (nLongs)
(SETQ nLongs (IRIS.RECL stream))
(if (NEQ IRIS\RESC (IRIS.GETGCHAR stream))
then (printout STDERR "IRIS.RECFLS: error in array transport" T)
(while (SPP.READP stream) do (BIN stream))
(* Empty the stream buffer)
(RETURN))
(for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values)
bind aLong (aFloat _(NCREATE 'FLOATP))
do (SETQ aLong (IRIS.REC32 stream))
(if (IRIS.DOSYNC i)
then (IRIS.GETGCHAR stream)
(IRIS.PUTGCHAR IRIS\AESC stream)
(IRIS.FLUSHG stream))
(replace (FLOATP HIWORD) of aFloat with (LRSH aLong 16))
(replace (FLOATP LOWORD) of aFloat with (LOGAND aLong 65535))
(SETA values ptr aFloat))
(IRIS.GETGCHAR stream))))
(IRIS.RECLS
(LAMBDA (values STREAM) (* LeL, " 6-Sep-85 10:22")
(* Recieve an array of longs)
(PROG (nLongs)
(SETQ nLongs (IRIS.RECL STREAM))
(if (NEQ IRIS\RESC (IRIS.GETGCHAR STREAM))
then (PRINT "IRIS.RECLS: error in array transport" STDERR)
(while (SPP.READP stream) do (BIN stream))
(RETURN))
(for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) bind aLong
do (SETQ aLong (IRIS.REC32 STREAM))
(if (IRIS.DOSYNC i)
then (IRIS.GETGCHAR STREAM)
(IRIS.PUTGCHAR IRIS\AESC STREAM)
(IRIS.FLUSHG STREAM))
(SETA values ptr aLong))
(IRIS.GETGCHAR STREAM))))
(IRIS.RECSS
(LAMBDA (values stream) (* LeL, " 6-Sep-85 14:17")
(* Recieve an array of SMALL INTEGERS)
(PROG (nLongs nShorts)
(SETQ nLongs (LRSH (ADD1 (SETQ nShorts (IRIS.RECL stream)))
1))
(if (NEQ IRIS\RESC (IRIS.GETGCHAR stream))
then (PRINT "IRIS.RECSS: error in array transport" STDERR)
(while (SPP.READP stream) do (BIN stream))
(RETURN))
(for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 2 bind aLong
do (SETQ aLong (IRIS.REC32 stream))
(if (IRIS.DOSYNC i)
then (IRIS.GETGCHAR stream)
(IRIS.PUTGCHAR IRIS\AESC stream)
(IRIS.FLUSHG stream))
(SETA values ptr (LRSH aLong 16))
(if (OR (LESSP i (SUB1 nLongs))
(EVENP nShorts))
then (SETA values (ADD1 ptr)
(LOGAND 65535 aLong))))
(IRIS.GETGCHAR stream))))
(IRIS.SENDBS
(LAMBDA (values nVals stream) (* LeL, " 9-Sep-85 05:29")
(* Send an array of bytes)
(PROG (nLongs)
(SETQ nLongs (LRSH (IPLUS nVals 3)
2))
(COND
((ARRAYP values)
(IRIS.SENDL nVals stream) (* Fill a 32 bits word starting from highest byte :)
(for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 4
bind aLong (arrayMax _(IPLUS (ARRAYORIG values)
nVals))
do (SETQ aLong (for j from 0 to 4 when (LEQ (IPLUS ptr j)
arrayMax)
sum (LLSH (ELT values (IPLUS ptr j))
(LLSH j 3))))
(if (IRIS.DOSYNC i)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL aLong stream)))
((LISTP values)
(IRIS.SENDL nVals stream)
(for i from 0 to (SUB1 nLongs) bind (ptr _ values)
do (SETQ aLong (for j from 24 to 0 by -8 when ptr sum (LLSH (pop ptr)
j)))
(if (IRIS.DOSYNC i)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL aLong stream)))))))
(IRIS.SENDFS
[LAMBDA (values nVals stream) (* gbn "11-Nov-85 19:48")
(* * Sends an array or (possibly two-layered) list of numbers)
(COND
([AND (ARRAYP values)
(NUMBERP (ELT values (ARRAYORIG values]
(* An array of numbers)
(IRIS.SENDL (LLSH nVals 2)
stream)
(for i from 0 to (SUB1 nVals) as ptr from (ARRAYORIG values)
do (if (IRIS.DOSYNC i)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDF (ELT values ptr)
stream)))
((AND (LISTP values)
(NUMBERP (CAR values))) (* A list of numbers)
(IRIS.SENDL (LLSH nVals 2)
stream)
(for i in values as counter from 0
do (if (IRIS.DOSYNC counter)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDF i stream)))
((AND (LISTP values)
(POSITIONP (CAR values))
(NUMBERP (CAAR values))) (* A list of positions)
(IRIS.SENDL (LLSH nVals 2)
stream)
(for i in values bind (counter _ -1)
do (if (IRIS.DOSYNC (add counter 1))
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDF (CAR i)
stream)
(if (IRIS.DOSYNC (add counter 1))
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDF (CDR i)
stream)))
[(AND (LISTP values)
(LISTP (CAR values))
(NUMBERP (CAAR values))) (* A list of list of numbers)
(IRIS.SENDL (LLSH nVals 2)
stream)
(for i in values bind (counter _ -1) do (for j in i eachtime (add counter 1)
do (if (IRIS.DOSYNC counter)
then (IRIS.PUTGCHAR IRIS\AESC
stream))
(IRIS.SENDF j stream]
(T (ERROR values "-- is not an list [of list]/array of numbers"])
(IRIS.SENDLS
(LAMBDA (values nVals stream) (* LeL, " 9-Sep-85 02:14")
(* * Sends an array or (possibly two-layered) list of numbers)
(COND
((AND (ARRAYP values)
(NUMBERP (ELT values (ARRAYORIG values)))) (* An array of numbers)
(IRIS.SENDL (LLSH nVals 2)
stream)
(for i from 0 to (SUB1 nVals) as ptr from (ARRAYORIG values)
do (if (IRIS.DOSYNC i)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL (ELT values ptr)
stream)))
((AND (LISTP values)
(NUMBERP (CAR values))) (* A list of numbers)
(IRIS.SENDL (LLSH nVals 2)
stream)
(for i in values as counter from 0
do (if (IRIS.DOSYNC counter)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL i stream)))
((AND (LISTP values)
(LISTP (CAR values))
(NUMBERP (CAAR values))) (* A list of list of numbers)
(IRIS.SENDL (LLSH nVals 2)
stream)
(for i in values bind (counter _ -1) do (for j in i eachtime (add counter 1)
do (if (IRIS.DOSYNC counter)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL j stream))))
(T (ERROR values "-- is not an list [of list]/array of numbers")))))
(IRIS.SENDQS
(LAMBDA (values nVals stream) (* LeL, " 2-Sep-85 12:47")
(IRIS.SENDL (LLSH nVals 3))
(COND
((ARRAYP values)
(for i from 0 to (LLSH nVals 1) by 2 as ptr from 0 by 8
do (if (IRIS.DOSYNC i)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL (LOGOR (LLSH (ELT values ptr)
16)
(LLSH (ELT values (IPLUS ptr 1))
24)
(LLSH (ELT values (IPLUS ptr 2))
8)
(ELT values (IPLUS ptr 3)))
stream)
(if (IRIS.DOSYNC (IPLUS i 1))
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL (LOGOR (LLSH (ELT values (IPLUS ptr 4))
24)
(LLSH (ELT values (IPLUS ptr 5))
16)
(ELT values (IPLUS ptr 6))
(LLSH (ELT values (IPLUS ptr 7))
8))
stream)))
((LISTP values)
(for i from 0 to (LLSH nVals 1) by 2 as ptr from values by 8
do (if (IRIS.DOSYNC i)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL (LOGOR (LLSH (CAR values)
16)
(LLSH (CADR values)
24)
(LLSH (CADDR values)
8)
(CADDDR values))
stream)
(SETQ values (NTH values 5))
(if (IRIS.DOSYNC (IPLUS i 1))
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL (LOGOR (LLSH (ELT values (CAR values))
24)
(LLSH (ELT values (CADR values))
16)
(CADDR values)
(LLSH (CADDDR values)
8))
stream)
(SETQ values (NTH values 5))))
(T (ERROR values "-- neither an array nor a list")))))
(IRIS.SENDSS
(LAMBDA (values nVals stream) (* LeL, " 6-Sep-85 14:20")
(* * Sends an array or list of numbers shorts (SMALLPs))
(LET ((nLongs (LRSH nVals 1))
(nBytes (LLSH nVals 1)))
(COND
((AND (ARRAYP values)
(NUMBERP (ELT values (ARRAYORIG values))))
(* An array of numbers)
(IRIS.SENDL nBytes stream)
(for i from 0 to (SUB1 nLongs) as ptr from (ARRAYORIG values) by 2 bind aLong
do (SETQ aLong (ELT values ptr))
(if (OR (LESSP i nLongs)
(EVENP nVals))
then (add aLong (LLSH (ELT values (ADD1 ptr))
16)))
(if (IRIS.DOSYNC i)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL aLong stream)))
((AND (LISTP values)
(NUMBERP (CAR values))) (* A list of numbers)
(IRIS.SENDL nBytes stream)
(for i from 0 to (SUB1 nLongs) bind aLong (pnt _ values)
do (SETQ aLong (pop pnt))
(if pnt
then (add aLong (LLSH (pop pnt)
16)))
(if (IRIS.DOSYNC i)
then (IRIS.PUTGCHAR IRIS\AESC stream))
(IRIS.SENDL i stream)))
(T (ERROR values "-- is not an list [of list]/array of numbers"))))))
(IRIS.SETFASTCOM
(LAMBDA (STREAM) (* gbn "19-Mar-85 21:02")
(IRIS.GCMD 1 STREAM)))
)
(DECLARE: EVAL@COMPILE
[PUTPROPS IRIS.DOSYNC MACRO ((i)
(COND ((EQ 0 (LOGAND i 7)))
(T NIL]
(PUTPROPS IRIS.ECHOFF MACRO ((STREAM)
(STREAMPROP STREAM (QUOTE IRIS\ECHOFLAG)
NIL)))
(PUTPROPS IRIS.ECHOON MACRO ((STREAM)
(STREAMPROP STREAM (QUOTE IRIS\ECHOFLAG)
T)))
(PUTPROPS IRIS.FLUSHG MACRO (= . SPP.FORCEOUTPUT))
(PUTPROPS IRIS.GCMD MACRO ((CMD STREAM)
(* Sends a command)
(BOUT STREAM IRIS\TESC)
(* Escape character)
(IRIS.SEND6 CMD STREAM)
(* ...followed by the number in two six bits transmission)
(IRIS.SEND6 (LRSH CMD 6)
STREAM)))
[PUTPROPS IRIS.GETGCHAR MACRO ((STREAM)
(BIN (SPPINPUTSTREAM STREAM]
[PUTPROPS IRIS.GEXIT MACRO ((stream)
(if stream then (IRIS.FLUSHG stream)
else
(IRIS.FLUSHG IRISCONN]
(PUTPROPS IRIS.GFINISH MACRO ((stream)
(* null defn)
(IRIS.FLUSHG stream)))
(PUTPROPS IRIS.PUTGCHAR MACRO ((onechar SPPSTREAM)
(BOUT SPPSTREAM onechar)))
[PUTPROPS IRIS.REC32 MACRO ((stream)
(for j from 0 to 30 by 6 sum (LLSH (IRIS.REC6 stream)
j]
(PUTPROPS IRIS.REC6 MACRO ((STREAM)
(* Recieve a 6 bit word; we substract 32 because the other end add3s 32 to avoid sending
control characters)
(* NO LONGER ANDS 63)
(IDIFFERENCE (IRIS.GETGCHAR STREAM)
32)))
[PUTPROPS IRIS.RECB MACRO (LAMBDA (STREAM)
(* Receive a byte)
(* is passed the spp outputstream, so must grab the input stream
from it)
(SETQ STREAM (SPPINPUTSTREAM STREAM))
(while (NEQ IRIS\RESC (BIN STREAM)))
(LOGOR (IRIS.REC6 STREAM)
(LLSH (IRIS.REC6 STREAM)
6]
[PUTPROPS IRIS.RECCR MACRO ((STREAM)
(* recieve a CarriageReturn)
(IRIS.GETGCHAR STREAM)
(* OR (EQ (IRIS.GETGCHAR STREAM)
(IPLUS 32 (CHARCODE CR)))
(ERROR "IRIS.RECCR received a non-carriage return from the IRIS"]
[PUTPROPS IRIS.RECF MACRO (LAMBDA (SPPSTREAM)
(* gbn "17-Jun-85 17:31")
(* receive a float. uses IRIS.RECL to receive a 32 bit word and
convert it to float)
(PROG (AFLOAT ALONG)
(SETQ ALONG (IRIS.RECL SPPSTREAM))
(SETQ AFLOAT (NCREATE (QUOTE FLOATP)))
(replace (FLOATP HIWORD)
of AFLOAT with (LRSH ALONG 16))
(replace (FLOATP LOWORD)
of AFLOAT with (LOGAND ALONG 65535))
(RETURN AFLOAT]
(PUTPROPS IRIS.RECL MACRO ((stream)
(while (NEQ IRIS\RESC (IRIS.GETGCHAR stream))
do NIL)
(IRIS.REC32 stream)))
(PUTPROPS IRIS.RECO MACRO ((STREAM)
(* Recieve a boolean)
(IRIS.RECB STREAM)))
(PUTPROPS IRIS.RECOS MACRO ((values STREAM)
(* Recieve an array of boolean)
(IRIS.RECBS values STREAM)))
[PUTPROPS IRIS.RECS MACRO ((stream)
(* Recieve a SMALL INTEGER)
(while (NEQ (IRIS.GETGCHAR stream)
IRIS\RESC)
do NIL)
(LET* ((1stbyte (IRIS.REC6 stream))
(2ndbyte (IRIS.REC6 stream)))
(LOGOR 1stbyte (LLSH 2ndbyte 6)
(LLSH (IRIS.REC6 stream)
12]
[PUTPROPS IRIS.SEND6 MACRO ((n STREAM)
(* Add 32 to avoid sending control characters)
(BOUT STREAM (IPLUS 32 (LOGAND 63 n]
(PUTPROPS IRIS.SEND8 MACRO ((n STREAM)
(BOUT STREAM n)))
(PUTPROPS IRIS.SENDB MACRO ((VALUE STREAM)
(* Send a byte)
(IRIS.SEND8 VALUE STREAM)))
(PUTPROPS IRIS.SENDC MACRO ((string stream)
(* Send a string of characters)
(* should probably allocate a global resource)
(IRIS.SENDBS (NCONC1 (CHCON string)
0)
(ADD1 (NCHARS string))
stream)))
[PUTPROPS IRIS.SENDF MACRO ((value stream)
(* Send a float)
(LET ((float (FLOAT value)))
(IRIS.SEND8 (\GETBASEBYTE float 0)
stream)
(IRIS.SEND8 (\GETBASEBYTE float 1)
stream)
(IRIS.SEND8 (\GETBASEBYTE float 2)
stream)
(IRIS.SEND8 (\GETBASEBYTE float 3)
stream]
[PUTPROPS IRIS.SENDL MACRO (LAMBDA (VALUE STREAM)
(* Sends a 32 bit integer)
(SELECTQ (TYPENAME VALUE)
(SMALLP (if (ILESSP VALUE 0)
then
(IRIS.SEND8 255 STREAM)
(IRIS.SEND8 255 STREAM)
else
(IRIS.SEND8 0 STREAM)
(IRIS.SEND8 0 STREAM))
(IRIS.SEND8 (LOGAND (LRSH VALUE 8)
255)
STREAM)
(IRIS.SEND8 (LOGAND VALUE 255)
STREAM))
(FIXP (IRIS.SEND8 (\GETBASEBYTE VALUE 0)
STREAM)
(IRIS.SEND8 (\GETBASEBYTE VALUE 1)
STREAM)
(IRIS.SEND8 (\GETBASEBYTE VALUE 2)
STREAM)
(IRIS.SEND8 (\GETBASEBYTE VALUE 3)
STREAM))
(ERROR VALUE
"can't be sent thru IRIS.SENDL (neither an FIXP nor a SMALLP)"]
(PUTPROPS IRIS.SENDO MACRO ((value STREAM)
(* send a boolean)
(IRIS.SENDB value STREAM)))
(PUTPROPS IRIS.SENDS MACRO ((value STREAM)
(* Send a SMALL INTEGER (16 bits))
(IRIS.SEND8 (LOGAND 255 (LRSH value 8))
STREAM)
(IRIS.SEND8 (LOGAND 255 value)
STREAM)))
[PUTPROPS SPPINPUTSTREAM MACRO ((OUTPUTSTREAM)
(* gbn "17-Jun-85 17:40")
(fetch (SPPCON SPPINPUTSTREAM)
of
(fetch (STREAM F1)
of OUTPUTSTREAM]
[PUTPROPS SPPSTREAM? MACRO (LAMBDA (STREAM)
(AND (TYPENAME STREAM (QUOTE STREAM))
(TYPENAMEP (fetch F1 of STREAM)
(QUOTE SPPCON]
)
(DECLARE: EVAL@COMPILE
(RPAQQ STDERR T)
(RPAQQ IRIS\AESC 46)
(RPAQQ IRIS\RESC 126)
(RPAQQ IRIS\TESC 16)
(CONSTANTS (STDERR T)
(IRIS\AESC 46)
(IRIS\RESC 126)
(IRIS\TESC 16))
)
(DECLARE: EVAL@LOAD DONTCOPY
(LOADDEF (QUOTE FLOATP)
(QUOTE RECORD)
(QUOTE LLARITH))
)
(RPAQ? IRISCONN )
(RPAQ? IRISSPPON T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS IRISIO COPYRIGHT ("Xerox Corporation" 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1379 2155 (IRIS.GEXIT 1389 . 1514) (IRIS.GFLUSH 1516 . 1642) (IRIS.GINIT 1644 . 1986) (
IRIS.GRESET 1988 . 2153)) (2392 15323 (IRIS.RECBS 2402 . 3820) (IRIS.RECFS 3822 . 4990) (IRIS.RECLS
4992 . 5841) (IRIS.RECSS 5843 . 6941) (IRIS.SENDBS 6943 . 8275) (IRIS.SENDFS 8277 . 10344) (
IRIS.SENDLS 10346 . 11826) (IRIS.SENDQS 11828 . 13707) (IRIS.SENDSS 13709 . 15181) (IRIS.SETFASTCOM
15183 . 15321)))))
STOP

3943
lispusers/IRISLIB
View File

File diff suppressed because it is too large Load Diff

279
lispusers/IRISNET
View File

@@ -1,279 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "10-May-88 00:46:44" {ERINYES}<LISPUSERS>MEDLEY>IRISNET.;1 15482
previous date%: " 4-Feb-87 19:47:55" {ERINYES}<LISPUSERS>LYRIC>IRISNET.;1)
(* "
Copyright (c) 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT IRISNETCOMS)
(RPAQQ IRISNETCOMS ([DECLARE%: EVAL@LOAD DONTCOPY (P (LOADCOMP 'LLETHER)
(LOADCOMP 'ETHERRECORDS]
(FNS IRIS.RESET IRIS.TRACE IRISBOOTPROCESS SENDIRISPACKET IRISFILTER
OPEN.IRISCONN IRISBOOTSERVER)
(VARS \IRIS.VERBOSE (PRINTSPPDATAFLG T))
(VARS (IRIS.LOCK (CREATE.MONITORLOCK "iris boot lock")))
(GLOBALVARS IRISNSHOSTNUMBER)
[INITVARS (IRISNET 146)
(IRISBOOTDIRECTORIES '({CORE} {ERIS}<IRIS>gl2>boot>]
(CONSTANTS (IRISSOCKET 37)
(IRIS.PACKETTYPE 32790)
(IRIS.BOOT.STREAM.NAME '|IRIS boot SPP|))
[DECLARE%: EVAL@LOAD DONTCOPY (FILES ETHERRECORDS)
(P (LOADCOMP 'LLETHER]
[P (ACCESSFNS IRISENCAPSULATION [(IRISBASE (LOCF (FETCH (ETHERPACKET
EPENCAPSULATION
)
OF DATUM]
[BLOCKRECORD IRISBASE ((IRISLENGTH WORD)
(IRISDESTHOSTO 3 WORD)
(IRISSOURCEHOSTO 3 WORD)
(IRISTYPE WORD)
(IRISEXCHID WORD)
(INFOCHAR1 BYTE)
(INFOCHAR2 BYTE))
[ACCESSFNS IRISDESTHOSTO ((IRISDESTHOST (\LOADNSHOSTNUMBER
(LOCF DATUM))
(\STORENSHOSTNUMBER
(LOCF DATUM)
NEWVALUE))
(IRISPACKETBASE (LOCF DATUM))
(IRISDESTHOSTBASE (LOCF DATUM]
(ACCESSFNS IRISSOURCEHOSTO ((IRISSOURCEHOST
(\LOADNSHOSTNUMBER (LOCF DATUM)
)
(\STORENSHOSTNUMBER
(LOCF DATUM)
NEWVALUE))
(IRISSOURCEHOSTBASE (LOCF DATUM]
(TYPE? (type? ETHERPACKET DATUM]
(MACROS BROADCASTP)))
(DECLARE%: EVAL@LOAD DONTCOPY
(LOADCOMP 'LLETHER)
(LOADCOMP 'ETHERRECORDS)
)
(DEFINEQ
(IRIS.RESET
[LAMBDA NIL (* gbn "24-Jun-85 01:31")
(PROG (PROC)
(CLOSEF? '{DSK}IRISBOOTFILE)
(if (SETQ PROC (FIND.PROCESS IRIS.BOOT.STREAM.NAME))
then (DEL.PROCESS PROC))
(if (SETQ PROC (FIND.PROCESS '|Iris Terminal SPP|))
then (DEL.PROCESS PROC))
(if (SETQ PROC (FIND.PROCESS 'IRISBOOTPROCESS))
then (DEL.PROCESS PROC))
(PROCESS.STATUS.WINDOW (CREATEPOSITION 5 5])
(IRIS.TRACE
[LAMBDA NIL (* gbn "25-Feb-86 12:24")
(SETQ PRINTSPPDATAFLG NIL)
(SETQ XIPIGNORETYPES '(1 TRANS))
(XIPTRACE T])
(IRISBOOTPROCESS
[LAMBDA (IRISPACKET) (* gbn "12-Nov-85 23:16")
(DECLARE (GLOBALVARS IRISBOOTDIRECTORIES IRISNSADDRESS IRIS.LOCK IRISNET IRISNSHOSTNUMBER))
(COND
((OBTAIN.MONITORLOCK IRIS.LOCK T T)
[PROG (DH CHAR NET IRISBOOTFILE INBOOTSTREAM OUTBOOTSTREAM IRISBOOTFILENAME BOOTFILENAME TEMP
)
(SETQ DH (fetch (IRISENCAPSULATION IRISSOURCEHOST) of IRISPACKET))
(SETQ CHAR (fetch (IRISENCAPSULATION INFOCHAR1) of IRISPACKET))
(replace (IRISENCAPSULATION IRISDESTHOST) of IRISPACKET
with (SETQ IRISNSHOSTNUMBER (fetch (IRISENCAPSULATION IRISSOURCEHOST)
of IRISPACKET)))
(replace (IRISENCAPSULATION IRISSOURCEHOST) of IRISPACKET with
\MY.NSHOSTNUMBER
)
[COND
(\IRIS.VERBOSE
(* inform the user that a boot attempt is being made)
(FLASHWINDOW PROMPTWINDOW)
(PROMPTPRINT (CONCAT "IRIS boot initiated to: " DH]
(* "E" for "reply" to booting and "H" for "hostname" for spp connection)
(SETQ NET (fetch (XIP XIPSOURCENET) of IRISPACKET))
(SETQ IRISNSADDRESS (create NSADDRESS
NSNET _ IRISNET
NSHOSTNUMBER _ IRISNSHOSTNUMBER))
(* this should be using the net from the iris, but it can't be trusted.
 SGI doesn't handle turning around packets properly)
(COND
((EQ CHAR (CHARCODE C)) (* replace EPSOCKET of IRISPACKET
 with 41)
(replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE
E))
(SENDIRISPACKET IRISPACKET)
(* just sends back an "E" packet with our host socket
 (41) filled in)
(SETQ INBOOTSTREAM (SPP.OPEN NIL 41 NIL IRIS.BOOT.STREAM.NAME))
(SETQ OUTBOOTSTREAM (SPPOUTPUTSTREAM INBOOTSTREAM))
(SPP.DSTYPE INBOOTSTREAM 108) (* returns a connection which is not
 yet established)
(BIN INBOOTSTREAM)
[SETQ TEMP (CONCAT (PACKC (while (SPP.READP INBOOTSTREAM)
collect (BIN INBOOTSTREAM]
[SETQ BOOTFILENAME (L-CASE (SUBSTRING TEMP (STRPOS ":*:" TEMP 1 NIL NIL T)
(SUB1 (STRPOS (CONCAT (CHARACTER 0))
TEMP]
[COND
((STREQUAL BOOTFILENAME (CONSTANT "defaultboot"))
(SETQ BOOTFILENAME (CONSTANT "iris"] (* This is a packet specifying the
 boot file name,)
[SETQ IRISBOOTFILE (OPENSTREAM (SETQ IRISBOOTFILENAME (FINDFILE BOOTFILENAME NIL
IRISBOOTDIRECTORIES))
'INPUT NIL '((TYPE BINARY]
[COND
(\IRIS.VERBOSE
(* inform the user that a boot attempt is being made)
(PROMPTPRINT (CONCAT "Booting IRIS from: " IRISBOOTFILENAME]
(COPYBYTES IRISBOOTFILE OUTBOOTSTREAM NIL NIL)
(FORCEOUTPUT OUTBOOTSTREAM)
(CLOSEF IRISBOOTFILE)
(PROMPTPRINT "IRIS boot server complete, closing boot file")
(CLOSEF INBOOTSTREAM))
((EQ CHAR (CHARCODE A)) (* replace EPSOCKET of IRISPACKET
 with 41)
(replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE
E))
(SENDIRISPACKET IRISPACKET)
(* just sends back an "E" packet with our host socket
 (41) filled in)
(SETQ INBOOTSTREAM (SPP.OPEN NIL 41 NIL IRIS.BOOT.STREAM.NAME))
(SETQ OUTBOOTSTREAM (SPPOUTPUTSTREAM INBOOTSTREAM))
(SPP.DSTYPE INBOOTSTREAM 108) (* returns a connection which is not
 yet established)
(BIN INBOOTSTREAM)
(while (SPP.READP INBOOTSTREAM) collect (BIN INBOOTSTREAM))
(SETQ BOOTFILENAME (CONSTANT "iris")) (* This is a packet specifying the
 boot file name,)
[SETQ IRISBOOTFILE (OPENSTREAM (SETQ IRISBOOTFILENAME (FINDFILE BOOTFILENAME NIL
IRISBOOTDIRECTORIES))
'INPUT NIL '((TYPE BINARY]
[COND
(\IRIS.VERBOSE
(* inform the user that a boot attempt is being made)
(PROMPTPRINT (CONCAT "Booting IRIS from: " IRISBOOTFILENAME]
(COPYBYTES IRISBOOTFILE OUTBOOTSTREAM NIL NIL)
(FORCEOUTPUT OUTBOOTSTREAM)
(CLOSEF IRISBOOTFILE)
(PROMPTPRINT "IRIS boot server complete, closing boot file")
(CLOSEF INBOOTSTREAM))
((EQ CHAR (CHARCODE H)) (* serv-hostname in SGIspeak)
(PRINT "workstation server connection") (* replace EPSOCKET of IRISPACKET
 with 41)
(replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with (CHARCODE
H))
(SETQ INBOOTSTREAM (SPP.OPEN NIL 37))
(SENDIRISPACKET IRISPACKET))
(T (PRINT "Iris connection") (* replace EPSOCKET of IRISPACKET
 with 41)
(PRINTOUT PROMPTWINDOW CHAR "RECEIVED")
(replace (IRISENCAPSULATION INFOCHAR1) of IRISPACKET with
(CHARCODE H))
(SETQ INBOOTSTREAM (SPP.OPEN NIL 37))
(SENDIRISPACKET IRISPACKET]
(RELEASE.MONITORLOCK IRIS.LOCK])
(SENDIRISPACKET
[LAMBDA (IRISPACKET) (* gbn "10-Jun-85 16:05")
(* * Sends a raw seething IRIS packet)
(COND
((fetch (ETHERPACKET EPTRANSMITTING) of IRISPACKET)
'AlreadyQueued)
(T (* (\RCLK (LOCF (fetch
 (ETHERPACKET EPTIMESTAMP) of
 IRISPACKET))))
(TRANSMIT.ETHERPACKET (fetch (ETHERPACKET EPNETWORK) of IRISPACKET)
IRISPACKET])
(IRISFILTER
[LAMBDA (IRISPACKET) (* gbn " 3-Jun-85 22:49")
(if (AND (EQ (fetch (ETHERPACKET EPTYPE) of IRISPACKET)
IRIS.PACKETTYPE)
(BROADCASTP IRISPACKET))
then (ADD.PROCESS `(IRISBOOTPROCESS %, IRISPACKET))
T
else (* not an iris packet)
NIL])
(OPEN.IRISCONN
[LAMBDA (NSADDRESS) (* gbn " 7-Jul-85 14:42")
(SETQ IRISCONN (SPP.OPEN (OR NSADDRESS IRISNSADDRESS)
IRISSOCKET T '|Iris Terminal SPP|])
(IRISBOOTSERVER
[LAMBDA (ON?) (* gbn " 7-Jul-85 14:54")
(if ON?
then (PROMPTPRINT "Enabling IRIS boot server")
(\ADD.PACKET.FILTER (FUNCTION IRISFILTER))
else (PROMPTPRINT "Disabling IRIS boot server")
(\DEL.PACKET.FILTER (FUNCTION IRISFILTER])
)
(RPAQQ \IRIS.VERBOSE T)
(RPAQQ PRINTSPPDATAFLG T)
(RPAQ IRIS.LOCK (CREATE.MONITORLOCK "iris boot lock"))
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS IRISNSHOSTNUMBER)
)
(RPAQ? IRISNET 146)
(RPAQ? IRISBOOTDIRECTORIES '({CORE} {ERIS}<IRIS>gl2>boot>))
(DECLARE%: EVAL@COMPILE
(RPAQQ IRISSOCKET 37)
(RPAQQ IRIS.PACKETTYPE 32790)
(RPAQQ IRIS.BOOT.STREAM.NAME |IRIS boot SPP|)
(CONSTANTS (IRISSOCKET 37)
(IRIS.PACKETTYPE 32790)
(IRIS.BOOT.STREAM.NAME '|IRIS boot SPP|))
)
(DECLARE%: EVAL@LOAD DONTCOPY
(FILESLOAD ETHERRECORDS)
(LOADCOMP 'LLETHER)
)
(ACCESSFNS IRISENCAPSULATION [(IRISBASE (LOCF (FETCH (ETHERPACKET EPENCAPSULATION)
OF DATUM]
[BLOCKRECORD IRISBASE ((IRISLENGTH WORD)
(IRISDESTHOSTO 3 WORD)
(IRISSOURCEHOSTO 3 WORD)
(IRISTYPE WORD)
(IRISEXCHID WORD)
(INFOCHAR1 BYTE)
(INFOCHAR2 BYTE))
[ACCESSFNS IRISDESTHOSTO ((IRISDESTHOST (\LOADNSHOSTNUMBER (LOCF DATUM))
(\STORENSHOSTNUMBER (LOCF DATUM)
NEWVALUE))
(IRISPACKETBASE (LOCF DATUM))
(IRISDESTHOSTBASE (LOCF DATUM]
(ACCESSFNS IRISSOURCEHOSTO ((IRISSOURCEHOST (\LOADNSHOSTNUMBER (LOCF DATUM))
(\STORENSHOSTNUMBER (LOCF DATUM)
NEWVALUE))
(IRISSOURCEHOSTBASE (LOCF DATUM]
(TYPE? (type? ETHERPACKET DATUM)))
(DECLARE%: EVAL@COMPILE
[PUTPROPS BROADCASTP MACRO ((PACKET)
([LAMBDA (NDB)
(AND NDB (APPLY* (fetch NDBBROADCASTP of NDB)
PACKET NDB]
(fetch EPNETWORK of PACKET]
)
(PUTPROPS IRISNET COPYRIGHT ("Xerox Corporation" 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3679 13267 (IRIS.RESET 3689 . 4230) (IRIS.TRACE 4232 . 4424) (IRISBOOTPROCESS 4426 .
11586) (SENDIRISPACKET 11588 . 12227) (IRISFILTER 12229 . 12677) (OPEN.IRISCONN 12679 . 12908) (
IRISBOOTSERVER 12910 . 13265)))))
STOP

1314
lispusers/IRISSTREAM
View File

File diff suppressed because it is too large Load Diff

1274
lispusers/IRISVIEW
View File

File diff suppressed because it is too large Load Diff

246
lispusers/LOADIRIS
View File

@@ -1,246 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "10-May-88 00:44:06" {ERINYES}<LISPUSERS>MEDLEY>LOADIRIS.;1 15990
previous date%: " 4-Feb-87 20:09:38" {ERINYES}<LISPUSERS>LYRIC>LOADIRIS.;1)
(* "
Copyright (c) 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT LOADIRISCOMS)
(RPAQQ LOADIRISCOMS ((FILES FREEMENU)
(FNS LI.CIRCLES LI.LOAD LI.MAKEMENU LI.SETUP IRIS.CREATE.ICON IRIS.DOMENU
IRIS.TRY LOADIRIS INSTALLIRIS LI.TRAVEL)
(VARS (IRIS.DIRECTORY '{ERIS}<IRIS>NEXT>)
IRIS.MENU.COMMANDS IRISFILES LI.SETUP.ALL LI.SETUP.CLEAR
LI.SETUP.DEBUG LI.SETUP.STANDARD LI.SHADE LOCATED.IRISFILES
LOCATED.IRISPATCHFILE (LI.MENU))
(BITMAPS LI.DOIT LI.IRISLOGO IRIS.ICON IRIS.ICON.MASK)
(P (IRIS.CREATE.ICON)
(printout T
"Boot the IRIS, then choose 'create IRISview Panel' from the IRIS icon menu."
T))))
(FILESLOAD FREEMENU)
(DEFINEQ
(LI.CIRCLES
[LAMBDA (X) (* gbn " 5-Aug-85 15:25")
(for F to (OR X 100) do (IRIS.COLOR (RAND 0 7))
(IRIS.CIRCF (RAND 0 1000)
(RAND 0 800)
(RAND 50 200)))
(IRIS.GFLUSH])
(LI.LOAD
[LAMBDA (item window button) (* ; "Edited 9-Jan-87 15:28 by gbn")
(printout PROMPTWINDOW T "[Loading Iris Files]")
(RESETLST [RESETSAVE (BITBLT NIL NIL NIL window NIL NIL NIL NIL 'TEXTURE 'INVERT LI.SHADE)
`(BITBLT NIL NIL NIL ,window NIL NIL NIL NIL TEXTURE INVERT ,LI.SHADE]
(* (QUOTE LIST) (QUOTE REDISPLAYW)
 window)
(* ;; "This cruft seems to count on the fact that the only the buttons that are selected are in fm.getstate. (so the list looks like (file1 t file2 t), and not (file1 t file2 nil file3 t))")
(FOR FILENAME IN (FM.GETSTATE WINDOW) WHEN (NEQ FILENAME T)
DO (SETQ FILENAME (PACKFILENAME 'DIRECTORY IRIS.DIRECTORY 'BODY FILENAME))
(IF (FILENAMEFIELD FILENAME 'EXTENSION)
THEN (LOAD FILENAME)
ELSE (LOAD FILENAME 'PROP])
(LI.MAKEMENU
[LAMBDA NIL (* ; "Edited 9-Jan-87 15:30 by gbn")
(if (WINDOWP LI.MENU)
then (CLOSEW LI.MENU))
(SETQ LI.MENU
(FREEMENU `(((LABEL Setup%: TYPE DISPLAY FONT (HELVETICA 10 BOLD))
(LABEL CLEAR TYPE MOMENTARY SELECTEDFN LI.SETUP)
(LABEL Standard TYPE MOMENTARY SELECTEDFN LI.SETUP)
(LABEL Debug TYPE MOMENTARY SELECTEDFN LI.SETUP)
(LABEL ALL TYPE MOMENTARY SELECTEDFN LI.SETUP))
,@[LET* ([strLength (ADD1 (APPLY (FUNCTION MAX)
(MAPCAR IRISFILES (FUNCTION NCHARS]
(spaces (ALLOCSTRING strLength " ")))
(MAPCAR IRISFILES (FUNCTION (LAMBDA (FILENAME)
`((LABEL ,(SUBSTRING (CONCAT FILENAME ":"
spaces)
1 strLength) TYPE DISPLAY
FONT (GACHA 8 BOLD))
(LABEL ,COMPILE.EXT ID
,(PACKFILENAME 'NAME FILENAME
'EXTENSION COMPILE.EXT) TYPE
TOGGLE FONT (GACHA 8 STANDARD))
(LABEL Source ID ,FILENAME TYPE TOGGLE FONT
(GACHA 8 STANDARD]
((LABEL "Load --" TYPE DISPLAY FONT (HELVETICA 12 BOLD))
(LABEL ,LI.IRISLOGO TYPE MOMENTARY SELECTEDFN LI.LOAD MESSAGE
"Loads the selected Iris files"))) "Iris Loadup Panel"))
(for setup in LI.SETUP.STANDARD when (CDR setup)
do (FM.CHANGESTATE (FM.GETITEM (CAR setup)
NIL LI.MENU)
(CDR setup)
LI.MENU))
(printout PROMPTWINDOW T "Please put the LoadIris menu somewhere")
(MOVEW LI.MENU LASTMOUSEX LASTMOUSEY)
(MOVEW LI.MENU)
LI.MENU])
(LI.SETUP
[LAMBDA (ITEM WINDOW BUTTON) (* ; "Edited 24-Dec-86 14:29 by gbn")
(FOR SETUP IN [EVALV (PACK* 'LI.SETUP. (U-CASE (FM.ITEMPROP ITEM 'LABEL]
DO (* ; "THIS IS RIDICULOUS...")
(IF (EQ (FM.CHANGESTATE (FM.GETITEM (CAR SETUP)
NIL WINDOW)
(CDR SETUP)
WINDOW)
(CDR SETUP))
THEN (FM.CHANGESTATE (FM.GETITEM (CAR SETUP)
NIL WINDOW)
(CDR SETUP)
WINDOW])
(IRIS.CREATE.ICON
[LAMBDA (position) (* ; "Edited 2-Feb-87 23:34 by gbn")
(if (NOT position)
then (printout PROMPTWINDOW T "Please position the Iris icon somewhere"))
(LET ((window (ICONW IRIS.ICON IRIS.ICON.MASK position)))
(WINDOWPROP window 'SHRINKFN 'DON'T)
(WINDOWPROP window 'BUTTONEVENTFN 'IRIS.DOMENU])
(IRIS.DOMENU
[LAMBDA (window) (* LeL, " 9-Sep-85 01:36")
(if (NOT (WINDOWPROP window 'MENU))
then (WINDOWPROP window 'MENU (create MENU
ITEMS _ IRIS.MENU.COMMANDS)))
(MENU (WINDOWPROP window 'MENU])
(IRIS.TRY
[LAMBDA NIL (* LeL, " 4-Sep-85 15:42")
(* opens a connection and runs two
 dumb demos)
(OPEN.IRISCONN) (* this defaults to the value of
 IRISNSHOSTNUMBER)
(IRIS.GINIT)
(* must be executed before the iris is ready to accept graphic commands)
(for I to 5 do (LI.CIRCLES)
(LI.TRAVEL])
(LOADIRIS
[LAMBDA (options) (* LeL, " 3-Sep-85 11:55")
(* * loads the files necessary to open a connection to the iris and use the
 graphics library)
[if (FMEMB %'DCOMS options)
then (MAPC LOCATED.IRISFILES (FUNCTION (LAMBDA (file)
(LOAD? (PACK* file %'.DCOM]
[if (FMEMB %'SOURCES options)
then (MAPC LOCATED.IRISFILES (FUNCTION (LAMBDA (file)
(LOAD? file %'PROP]
(if (FMEMB %'PATCHES options)
then (LOAD LOCATED.IRISPATCHFILE])
(INSTALLIRIS
[LAMBDA (NODCOMS NOSOURCES) (* BDV "19-Jul-85 19:08")
(* * moves the iris files from my working dir to {eris}<iris>current>)
(COPYFILES IRISFILES %'{ERIS}<IRIS>CURRENT>)
(COPYFILES (for F in IRISFILES collect (PACK* F ".DCOM"))
%'{ERIS}<IRIS>CURRENT>)
(COPYFILES %'IRISIO.DCOM %'{ERIS}<IRIS>CURRENT>])
(LI.TRAVEL
[LAMBDA (COLOR) (* gbn " 5-Aug-85 21:33")
(* dumb demo to try double buffering)
(IRIS.DOUBLEBUFFER)
(IRIS.GCONFIG)
(if (NOT COLOR)
then (SETQ COLOR (RAND 0 6)))
(for I from 5 to 1000 by 10 do (IRIS.COLOR 8)
(IRIS.CLEAR)
(IRIS.COLOR COLOR)
(IRIS.CIRCF I (IQUOTIENT I 2)
(IQUOTIENT I 5))
(IRIS.SWAPBUFFERS))
(IRIS.GFLUSH)
(IRIS.SINGLEBUFFER)
(IRIS.GCONFIG])
)
(RPAQQ IRIS.DIRECTORY {ERIS}<IRIS>NEXT>)
(RPAQQ IRIS.MENU.COMMANDS (("Clear IRIS" (CLEARIRIS))
("Open IRIS stream" (if (MOUSECONFIRM
"New stream? (lose fonts, etc.) Left to confirm"
)
then
(SETQ IRISCONN)
(OPENIRISSTREAM)))
("Create IRISview panel" (IV.INIT))
("Enable bootserver" (if (GETD 'IRISBOOTSERVER)
then
(IRISBOOTSERVER T)
else
(PROMPTPRINT
"IRISNET must be loaded to use the boot server"
))
"Allows the Lisp Machine to boot the IRIS")
("Disable bootserver" (if (GETD 'IRISBOOTSERVER)
then
(IRISBOOTSERVER NIL)
else
(PROMPTPRINT
"IRISNET must be loaded to use the boot server"
))
"Prevents the Lisp Machine from booting the IRIS")))
(RPAQQ IRISFILES (IRISSTREAM IRISNET IRISVIEW))
(RPAQQ LI.SETUP.ALL ((IRISSTREAM . T)
(IRISSTREAM.LCOM . T)
(IRISNET . T)
(IRISNET.LCOM . T)
(IRISVIEW.LCOM T)
(IRISVIEW T)))
(RPAQQ LI.SETUP.CLEAR ((IRISSTREAM)
(IRISSTREAM.LCOM)
(IRISNET)
(IRISNET.LCOM)
(IRISVIEW)
(IRISVIEW.LCOM)))
(RPAQQ LI.SETUP.DEBUG ((IRISSTREAM . T)
(IRISSTREAM.LCOM . T)
(IRISVIEW . T)
(IRISVIEW.LCOM . T)
(IRISNET.LCOM . T)))
(RPAQQ LI.SETUP.STANDARD ((IRISSTREAM.LCOM . T)
(IRISNET.LCOM . T)
(IRISVIEW.LCOM . T)))
(RPAQQ LI.SHADE 18432)
(RPAQQ LOCATED.IRISFILES ({QV}<PSYCH>IRIS>GL2>IRISLIB {ERIS}<IRIS>IRISSTREAM {ERIS}<IRIS>IRISNET
{QV}<PSYCH>IRIS>GL2>IRISIO {ERIS}<IRIS>IRISDIGDEMO))
(RPAQQ LOCATED.IRISPATCHFILE {QV}<PSYCH>IRIS>GL2>IRISPATCH)
(RPAQQ LI.MENU NIL)
(RPAQQ LI.DOIT #*(20 12)@@@@@@@@GOOOL@@@D@@@D@@@EHIGD@@@EEEBD@@@EEEBD@@@EEEBD@@@EHIBD@@@D@@@D@@@GOOOL@@@@@@@@@@@@@@@@@@@
)
(RPAQQ LI.IRISLOGO #*(16 16)@NG@CJELFBDFCHAL@NG@NCLGKHAMHNGAHBDAKJEMNBDGHJEACJELFBDFCJEL@NG@)
(RPAQQ IRIS.ICON #*(75 82)@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@N@@@@@@@@@@@@@@@@COAOH@@@@@@@@@@@@@@@OOAON@@@@@@@@@@@@@@COOAOOH@@@@@@@@@@@@@OOOAOON@@@@@@@@@@@@COOOAOOOH@@@@@@@@@@@OOLOANGON@@@@@@@@@@COO@OANAOOH@@@@@@@@@OOL@OAN@GON@@@@@@@@COO@@OAN@AOOH@@@@@@@OOL@@OAN@@GON@@@@@@COO@@@OAN@@AOOH@@@@@OOL@@@OAN@@@GON@@@@COO@@@@OAN@@@AOOH@@@OOL@@@@OAN@@@@GON@@AOO@@@@@OAN@@@@AOO@@COL@@@@@OAN@@@@@GOH@COH@@@@@OAN@@@@@COH@CON@@@@@OAN@@@@@OOH@AOOH@@@@OAN@@@@COO@@@OON@@@@OAN@@@@OON@@@COOH@@@OAN@@@COOH@@@@OON@@@OAN@@@OON@@@A@COOH@@OAN@@COOHA@@CL@OON@@OAN@@OON@GH@CO@COOH@OAN@COOHAOH@COL@OON@OAN@OON@GOH@COO@COOHOANCOOHAOOH@COOL@OONCAHOON@GOOH@COOO@COOH@COOHAOOOH@CLOOL@OON@OON@GONGH@CLCOO@COOKOOHAOOHGH@CL@OOL@OOOON@GON@GH@CL@COO@COOOHAOOH@GH@CL@@OOL@OON@GON@@GH@CL@@COO@COHAOOH@@GH@CL@@@OOL@N@GON@@@GH@CL@@@COO@@AOOH@@@GH@CL@@@@OOL@GON@@@@GH@CL@@@@CON@OOH@@@@GH@CL@@@@@OOAON@@@@@GH@CL@@@@BCOAOHH@@@@GH@CL@@@@OHOANCN@@@@GH@CL@@@COLOANGOH@@@GH@CL@@@OOLOANGON@@@GH@CL@@COO@OANAOOH@@GH@CL@@OOL@OAN@GON@@GH@CL@COO@BOANHAOOH@GH@CL@OOL@NOANN@GON@GH@CLCOO@CNOANOHAOOHGH@CLOOL@ONOANON@GONGH@COOO@CONOANOOHAOOOH@COOL@OOLOANGON@GOOH@COO@COO@OANAOOHAOOH@COL@OOL@OAN@GON@GOH@CO@COO@@OAN@AOOHAOH@CL@OOL@@OAN@@GON@GH@A@COO@@@OAN@@AOOHA@@@@OOL@@@OAN@@@GON@@@@COO@@@@OAN@@@AOOH@@@GOL@@@@OAN@@@@GOL@@@OO@@@@@OAN@@@@AON@@@OL@@@@@OAN@@@@@GN@@@OO@@@@@OAN@@@@AON@@@OOL@@@@OAN@@@@GOL@@@COO@@@@OAN@@@AOOH@@@@OOL@@@OAN@@@GON@@@@@COO@@@OAN@@AOOH@@@@@@OOL@@OAN@@GON@@@@@@@COO@@OAN@AOOH@@@@@@@@OOL@OAN@GON@@@@@@@@@COO@OANAOOH@@@@@@@@@@OOLOANGON@@@@@@@@@@@COOOAOOOH@@@@@@@@@@@@OOOAOON@@@@@@@@@@@@@COOAOOH@@@@@@@@@@@@@@OOAON@@@@@@@@@@@@@@@CN@OH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
)
(RPAQQ IRIS.ICON.MASK #*(75 82)@@@@@@@COKOH@@@@@@@@@@@@@@@OOOON@@@@@@@@@@@@@@COOOOOH@@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@OOOOOOOON@@@@@@@@@@COOOOOOOOOH@@@@@@@@@OOOOOOOOOON@@@@@@@@COOOOOOOOOOOH@@@@@@@OOOOOOOOOOOON@@@@@@COOOOOOOOOOOOOH@@@@@OOOOOOOOOOOOOON@@@@COOOOOCOOOIOOOOOH@@@OOOOOLCOOOHGOOOON@@COOOOO@COOOHAOOOOOH@GOOOOL@COOOH@GOOOOL@OOOOO@@COOOH@AOOOON@OOOOL@@COOOH@@GOOON@OOOO@@@COOOH@@AOOON@OOON@@@COOOH@@@GOON@OOOOH@@COOOH@@AOOON@OOOON@@COOOH@@GOOON@OOOOOH@COOOH@AOOOON@GOOOON@COOOH@OOOOOL@OOOOOOHCOOOHCOOOOON@OOOOOONCOOOHOOOOOON@OOOOOOOKOOOKOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOCOOOOOOOOOOOOOION@OO@OOOOOOOOOOOONAON@OO@COOOOOOOOOOOHAON@OO@@OOOOOOOOOON@AON@OO@@COOOOOOOOOH@AON@OO@@@OOOOOOOON@@AON@OO@@@COOOOOOOH@@AON@OO@@@OOOOOOOON@@AON@OO@@COOOOOOOOOH@AON@OO@@OOOOOOOOOON@AON@OO@COOOOOOOOOOOHAON@OO@OOOOOOOOOOOONAON@OOCOOOOOOOOOOOOOION@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOON@OOOOOOOCOOOIOOOOOON@OOOOOOLCOOOHGOOOOON@OOOOOO@COOOHAOOOOON@GOOOOL@COOOH@GOOOOL@COOOO@@COOOH@AOOOOH@COOOL@@COOOH@@GOOOH@COOO@@@COOOH@@AOOOH@COOOL@@COOOH@@GOOOH@COOOO@@COOOH@AOOOOH@COOOOL@COOOH@GOOOOH@AOOOOO@COOOHAOOOOO@@@OOOOOLCOOOHGOOOON@@@COOOOOCOOOIOOOOOH@@@@OOOOOOOOOOOOOON@@@@@COOOOOOOOOOOOOH@@@@@@OOOOOOOOOOOON@@@@@@@COOOOOOOOOOOH@@@@@@@@OOOOOOOOOON@@@@@@@@@COOOOOOOOOH@@@@@@@@@@OOOOOOOON@@@@@@@@@@@COOOOOOOH@@@@@@@@@@@@OOOOOON@@@@@@@@@@@@@COOOOOH@@@@@@@@@@@@@@OOKON@@@@@@@@
)
(IRIS.CREATE.ICON)
(printout T "Boot the IRIS, then choose 'create IRISview Panel' from the IRIS icon menu." T)
(PUTPROPS LOADIRIS COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1223 9129 (LI.CIRCLES 1233 . 1608) (LI.LOAD 1610 . 2687) (LI.MAKEMENU 2689 . 5066) (
LI.SETUP 5068 . 5825) (IRIS.CREATE.ICON 5827 . 6230) (IRIS.DOMENU 6232 . 6559) (IRIS.TRY 6561 . 7221)
(LOADIRIS 7223 . 7894) (INSTALLIRIS 7896 . 8300) (LI.TRAVEL 8302 . 9127)))))
STOP

1485
lispusers/LUPINE
View File

File diff suppressed because it is too large Load Diff

72
lispusers/LoadPatches
View File

@@ -1,72 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "16-Nov-88 14:11:42" {PHYLUM}<BURWELL>LISP>LYRIC>LOADPATCHES.;3 3441
changes to%: (VARS LOADPATCHESCOMS)
(FNS LoadPatches COLLECT-PATCH-FILES)
previous date%: "27-Sep-88 22:56:49" {PHYLUM}<BURWELL>LISP>LYRIC>LOADPATCHES.;1)
(* "
Copyright (c) 1985, 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT LOADPATCHESCOMS)
(RPAQQ LOADPATCHESCOMS ((FNS LoadPatches COLLECT-PATCH-FILES)
(DECLARE%: DONTCOPY (PROP FILETYPE LOADPATCHES))))
(DEFINEQ
(LoadPatches
[LAMBDA (DIRECTORY LDFLG AFTERDATE) (* ; "Edited 16-Nov-88 13:08 by Burwell")
(* ;;; "Load all compiled files from the directory")
(DECLARE (GLOBALVARS *COMPILED-EXTENSIONS*))
(LET [(files (SORT (for EXT in *COMPILED-EXTENSIONS*
bind (AFTERIDATE _ (if AFTERDATE
then (OR (IDATE AFTERDATE)
0)
else 0)) join (COLLECT-PATCH-FILES DIRECTORY EXT
AFTERIDATE))
(FUNCTION (LAMBDA (X Y)
(LESSP (CDR X)
(CDR Y] (* ;
 "files are sorted by increasing date")
(for file in files do (SELECTQ LDFLG
(HIDDEN (* ;
 "Load the file, but don't put it on FILELST")
(LOAD? (CAR file)
T)
(SETQ FILELST (DREMOVE (FILENAMEFIELD (CAR file)
'NAME)
FILELST)))
(LOAD? (CAR file)
LDFLG)))
files])
(COLLECT-PATCH-FILES
[LAMBDA (DIRECTORY EXT AFTERIDATE) (* ; "Edited 16-Nov-88 13:13 by Burwell")
(* ;; "Generate list of files in DIRECTORY with extension EXT more recent than idate AFTERIDATE. Return list of pairs (file . date). Omits subdirectories.")
(RESETLST
(LET ((FILING.ENUMERATION.DEPTH 1)
(NAKED-DIR (UNPACKFILENAME.STRING DIRECTORY 'DIRECTORY))
FILE DATE)
(bind [GEN _ (\GENERATEFILES (CONCAT DIRECTORY "*." EXT ";")
'(ICREATIONDATE)
'(SORT RESETLST] while (SETQ FILE (\GENERATENEXTFILE GEN))
when (AND (STRING-EQUAL (UNPACKFILENAME.STRING FILE 'DIRECTORY)
NAKED-DIR)
(> (SETQ DATE (\GENERATEFILEINFO GEN 'ICREATIONDATE))
AFTERIDATE)) collect (CONS FILE DATE))))])
)
(DECLARE%: DONTCOPY
(PUTPROPS LOADPATCHES FILETYPE :COMPILE-FILE)
)
(PUTPROPS LOADPATCHES COPYRIGHT ("Xerox Corporation" 1985 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (608 3275 (LoadPatches 618 . 2308) (COLLECT-PATCH-FILES 2310 . 3273)))))
STOP

3637
lispusers/MATHSERVER
View File

File diff suppressed because it is too large Load Diff

13
lispusers/MATHSERVER.COMMANDFILES
View File

File diff suppressed because one or more lines are too long

BIN
lispusers/MATHSERVER.LCOM
View File

Binary file not shown.

BIN
lispusers/MATHSERVERPLOT.LCOM
View File

Binary file not shown.

1005
lispusers/MATRIXOPS
View File

File diff suppressed because it is too large Load Diff

5810
lispusers/MESATOLISP
View File

File diff suppressed because it is too large Load Diff

344
lispusers/MICROTEK
View File

File diff suppressed because one or more lines are too long

BIN
lispusers/MICROTEK.LCOM
View File

Binary file not shown.

187
lispusers/MICROTEKPRINT
View File

@@ -1,187 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "27-Jan-89 10:23:15" {DSK}<LISPFILES>MICROTEK>MICROTEKPRINT.;1 10179
changes to%: (FNS MT.CREATEPRINTMASTER)
previous date%: "23-Jul-88 15:18:48" {ERINYES}<LISP>MEDLEY>LISPUSERS>MICROTEKPRINT.;1)
(* "
Copyright (c) 1986, 1987, 1988, 1989 by XEROX Corporation. All rights reserved.
")
(PRETTYCOMPRINT MICROTEKPRINTCOMS)
(RPAQQ MICROTEKPRINTCOMS
[(P (FILESLOAD MICROTEK))
(FNS MT.PRINT.MENU MT.GETXPOS MT.GETYPOS MT.CREATEPRINT MT.CREATEPRINTMASTER
MT.SELECT.SCALEFACTOR)
(P (IF (AND (BOUNDP 'MT.DISPLAY.MENUWINDOW)
(OPENWP MT.DISPLAY.MENUWINDOW))
THEN
(MT.PRINT.MENU])
(FILESLOAD MICROTEK)
(DEFINEQ
(MT.PRINT.MENU
[LAMBDA NIL (* ;
 "Edited 21-May-87 09:23 by ronald clarke:xsis:xerox")
(PROG (MENU.DESCRIPTION)
[SETQ MENU.DESCRIPTION
`(((PROPS ID MPRINT)
(GROUP (PROPS FORMAT EXPLICIT COORDINATES GROUP BACKGROUND 23130)
(TYPE MOMENTARY LABEL "PRINT" BOX 3 LEFT 0 BOTTOM 2 FONT (MODERN 12 BOLD)
SELECTEDFN MT.CREATEPRINT)
(TYPE STATE LABEL "Printer!: " ID PRINTERTYPE MENUITEMS (8044 4045)
INITSTATE 8044 LINKS (DISPLAY (GROUP PRINTER))
FONT
(MODERN 10 BOLD)
BOX 1 LEFT 60 BOTTOM 3)
(TYPE DISPLAY ID PRINTER LABEL "" LEFT 115 BOTTOM 3 BOX 1 MAXWIDTH 30)
(TYPE MOMENTARY LABEL "XPOS!: " SELECTEDFN MT.GETXPOS FONT (MODERN 10 BOLD)
LEFT 175 BOTTOM 3 BOX 1)
(TYPE EDIT ID XPOS LABEL 0 MAXWIDTH 45 LEFT 220 BOTTOM 3 BOX 1)
(TYPE MOMENTARY LABEL "YPOS!: " SELECTEDFN MT.GETYPOS FONT (MODERN 10 BOLD)
LEFT 280 BOTTOM 3 BOX 1)
(TYPE EDIT ID YPOS LABEL 0 MAXWIDTH 45 LEFT 325 BOTTOM 3 BOX 1)
(TYPE MOMENTARY LABEL "SCALE!: " FONT (MODERN 10 BOLD)
LEFT 385 BOTTOM 3 BOX 1 SELECTEDFN MT.SELECT.SCALEFACTOR)
(TYPE EDIT LABEL "1:1" ID SCALEFACTOR LEFT 435 BOTTOM 3 BOX 1]
(SETQ MT.PRINT.MENUWINDOW (FREEMENU MENU.DESCRIPTION "Microtek Print Menu" 23130 5))
(OPENW MT.PRINT.MENUWINDOW)
(ATTACHWINDOW MT.PRINT.MENUWINDOW MT.DISPLAY.MENUWINDOW 'BOTTOM 'JUSTIFY])
(MT.GETXPOS
[LAMBDA NIL (* ;
 "Edited 21-May-87 09:15 by ronald clarke:xsis:xerox")
(FM.EDITITEM (FM.GETITEM 'XPOS NIL MT.PRINT.MENUWINDOW)
MT.PRINT.MENUWINDOW])
(MT.GETYPOS
[LAMBDA NIL (* ;
 "Edited 21-May-87 09:17 by ronald clarke:xsis:xerox")
(FM.EDITITEM (FM.GETITEM 'YPOS NIL MT.PRINT.MENUWINDOW)
MT.PRINT.MENUWINDOW])
(MT.CREATEPRINT
[LAMBDA NIL (* ;
 "Edited 21-May-87 09:29 by ronald clarke:xsis:xerox")
(PROG NIL
(if (AND [BOUNDP (SETQ BITMAP (MKATOM (LISTGET (FM.GETSTATE MT.DISPLAY.MENUWINDOW)
'BITMAPNAME]
(BITMAPP (SETQ BITMAP (EVAL BITMAP)))
(if (OR [AND (EQ (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
'PRINTERTYPE))
4045)
(FMEMB (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
'SCALEFACTOR))
'(4%:1 2%:1 1%:1 1%:2 1%:4]
(EQ (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
'PRINTERTYPE))
8044))
then T
else (FLASHWINDOW MT.STATUSWINDOW 3)
(MT.PRINT.STATUS "Not a valid scale for 4045 printer")
(RETURN NIL)))
then (MT.PRINT.STATUS "")
[MT.CREATEPRINTMASTER BITMAP (MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
'XPOS))
(MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
'YPOS))
(MKATOM (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
'SCALEFACTOR]
else (FLASHWINDOW MT.STATUSWINDOW 3)
(MT.PRINT.STATUS "This atom is not a bitmap")
(RETURN NIL])
(MT.CREATEPRINTMASTER
[LAMBDA (BITMAP X Y SCALEFACTOR) (* ; "Edited 27-Jan-89 10:21 by rclarke.pa")
(PROG (IPS SCANFACTOR SCALE)
[if (EQP (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
'PRINTERTYPE)
8044)
then (if [NOT (SETQ SCANFACTOR
(LISTGET '(0 0.24 5 0.252 10 0.266 15 0.282 20 0.3 25 0.32 33
0.36 35 0.369 40 0.4 45 0.439 50 0.48 55 0.533 60
0.6 67 0.7200001 70 0.8 75 0.96)
(GETPROP (MKATOM (LISTGET (FM.GETSTATE
MT.DISPLAY.MENUWINDOW)
'BITMAPNAME))
'RESOLUTION]
then (MT.PRINT.STATUS "")
(FLASHWINDOW MT.STATUSWINDOW 3)
(if [NOT (NUMBERP (SETQ SCANFACTOR
(MKATOM (PROMPTFORWORD
"Resolution not on Bitmap proplist. Enter #:"
"1" NIL MT.STATUSWINDOW]
then (FLASHWINDOW MT.STATUSWINDOW 2)
(MT.PRINT.STATUS "This is not a number")
(RETURN NIL))
(MT.PRINT.STATUS ""))
[SETQ SCALE (FQUOTIENT (CAR (UNPACK SCALEFACTOR))
(CADDR (UNPACK SCALEFACTOR]
(SETQ IPS (OPENIMAGESTREAM '{LPT}.IP))
(SCALEDBITBLT BITMAP 0 0 IPS X Y 21590 27940 'INPUT 'REPLACE NIL
'(0 0 21590 27940)
(FTIMES SCALE SCANFACTOR))
else (if [NOT (SETQ SCANFACTOR
(LISTGET '(0 1 5 1 10 1 15 1 20 1 25 1 33 1 35 1 40 2 45 2 50 2 55
2 60 2 67 4 70 4 75 4)
(GETPROP (MKATOM (LISTGET (FM.GETSTATE
MT.DISPLAY.MENUWINDOW)
'BITMAPNAME))
'RESOLUTION]
then (MT.PRINT.STATUS "")
(FLASHWINDOW MT.STATUSWINDOW 3)
(if [NOT (NUMBERP (SETQ SCANFACTOR
(MKATOM (PROMPTFORWORD
"Resolution not on Bitmap proplist. Enter #:"
"1" NIL MT.STATUSWINDOW]
then (FLASHWINDOW MT.STATUSWINDOW 2)
(MT.PRINT.STATUS "This is not a number")
(RETURN NIL))
(MT.PRINT.STATUS ""))
[SETQ SCALE (FQUOTIENT (CAR (UNPACK SCALEFACTOR))
(CADDR (UNPACK SCALEFACTOR]
(SETQ IPS (OPENIMAGESTREAM '{LPT}.4045XLP))
(if (GREATERP (FTIMES SCALE SCANFACTOR)
4)
then (FLASHWINDOW MT.STATUSWINDOW 2)
(MT.PRINT.STATUS "Not a valid scale for reduction used on this bitmap")
(RETURN NIL))
(SCALEDBITBLT BITMAP 0 0 IPS X Y 2550 3300 'INPUT 'REPLACE NIL
'(0 0 2550 3300)
(FIXR (FTIMES SCALE SCANFACTOR]
(CLOSEF IPS)
(MT.PRINT.STATUS "Bitmap sent to printer"])
(MT.SELECT.SCALEFACTOR
[LAMBDA NIL (* ;
 "Edited 21-May-87 09:26 by ronald clarke:xsis:xerox")
(PROG [(PRINTERTYPE (LISTGET (FM.GETSTATE MT.PRINT.MENUWINDOW)
'PRINTERTYPE]
[if (EQP PRINTERTYPE 8044)
then (SETQ FACTORS
'(8%:1 7%:1 6%:1 5%:1 4%:1 3%:1 2%:1 1%:1 1%:2 1%:3 1%:4 1%:5 1%:6 1%:7 1%:8))
else (SETQ FACTORS '(4%:1 2%:1 1%:1 1%:2 1%:4]
(FM.CHANGESTATE (FM.GETITEM 'SCALEFACTOR NIL MT.PRINT.MENUWINDOW)
(MENU (create MENU
ITEMS _ FACTORS))
MT.PRINT.MENUWINDOW])
)
(IF (AND (BOUNDP 'MT.DISPLAY.MENUWINDOW)
(OPENWP MT.DISPLAY.MENUWINDOW))
THEN (MT.PRINT.MENU))
(PUTPROPS MICROTEKPRINT COPYRIGHT ("XEROX Corporation" 1986 1987 1988 1989))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (794 9954 (MT.PRINT.MENU 804 . 2630) (MT.GETXPOS 2632 . 2912) (MT.GETYPOS 2914 . 3194) (
MT.CREATEPRINT 3196 . 5070) (MT.CREATEPRINTMASTER 5072 . 9197) (MT.SELECT.SCALEFACTOR 9199 . 9952))))
)
STOP

BIN
lispusers/MICROTEKPRINT.LCOM
View File

Binary file not shown.

737
lispusers/MTP
View File

@@ -1,737 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Feb-2022 17:06:07" {DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MTP.;2 31571
:CHANGES-TO (VARS MTPCOMS)
(FNS MTP.MAKEANSWERFORM)
:PREVIOUS-DATE "19-May-86 16:54:58"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>MTP.;1)
(* ; "
Copyright (c) 1983-1984, 1986 by Xerox Corporation.
")
(PRETTYCOMPRINT MTPCOMS)
(RPAQQ MTPCOMS
((COMS (* Lafite mode MTP)
(FNS MTP.GET.USERDATA MTP.DELIVERMESSAGE MTP.PREPARE.SEND MTP.MAKEANSWERFORM)
(ADDVARS (LAFITEMODELST (MTP MTP.PREPARE.SEND MTP.DELIVERMESSAGE MTP.MAKEANSWERFORM
MTP.GET.USERDATA)))
(FNS \MTP.AUTHENTICATE \MTP.COERCE.MSG \MTP.FILL \MTP.INDENT \MTP.CLRBUF
\MTP.PRINTADDRESSES)
(INITVARS (MTP.SERVER)
(MTP.LINELENGTH 70)
(MTP.RIGHTMARGINWIDTH 10)
(MTP.FILLMSGFLG %'ASK)
(MTP.INSERTANSWERFLG T)
(MTP.INSERTANSWERNSPACES 3)))
[COMS (* MTP mail server)
(FNS MTP.OPENMAILBOX MTP.POLLNEWMAIL MTP.NEXTMESSAGE MTP.RETRIEVEMESSAGE
MTP.CLOSEMAILBOX)
(FNS \MTP.ENDOFMESSAGESTATE \MTP.POLLNEWMAIL)
(ADDVARS (MAILSERVERTYPES (MTP MTP.POLLNEWMAIL MTP.OPENMAILBOX MTP.NEXTMESSAGE
MTP.RETRIEVEMESSAGE MTP.CLOSEMAILBOX ETHERPORT]
(FILES LAFITE)
(DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MTPMAILBOX MTPPARSE)
(CONSTANTS \PUPSOCKET.MTP \PUPSOCKET.MISCSERVICES)
(CONSTANTS * PUPTYPES)
(GLOBALVARS MTP.SERVER MTP.LINELENGTH MTP.RIGHTMARGINWIDTH MTP.FILLMSGFLG
MTP.INSERTANSWERFLG MTP.INSERTANSWERNSPACES \LAPARSE.FULL LAFITEEDITORFONT
UNSUPPLIEDFIELDSTR MESSAGESTR \LAFITEUSERDATA MAILSERVERTYPES
\LAFITE.AUTHENTICATION.FAILURE)
(FILES (LOADCOMP)
LAFITE DPUPFTP))))
(* Lafite mode MTP)
(DEFINEQ
(MTP.GET.USERDATA
[LAMBDA NIL (* drc%: "29-Apr-86 23:31")
(LET ((PORT (ETHERPORT MTP.SERVER))
USER/PWD)
(SETQ \LAFITEUSERDATA
(if (NULL PORT)
then (PRINTOUT PROMPTWINDOW T "MTP.SERVER not found -- " MTP.SERVER T)
(SETQ \LAFITE.AUTHENTICATION.FAILURE "No Server")
NIL
else (SETQ USER/PWD (\INTERNAL/GETPASSWORD MTP.SERVER))
(AND (\MTP.AUTHENTICATE MTP.SERVER USER/PWD)
(create LAFITEUSERDATA
FULLUSERNAME _ (CAR USER/PWD)
ENCRYPTEDPASSWORD _ (CDR USER/PWD)
SHORTUSERNAME _ (CAR USER/PWD)
MAILSERVERS _ (LIST (create MAILSERVER
MAILPORT _ PORT
MAILSERVERNAME _ MTP.SERVER
MAILSERVEROPS _ (CDR (ASSOC %'MTP
MAILSERVERTYPES])
(MTP.DELIVERMESSAGE
[LAMBDA (MSG PARSE W ABORTW) (* drc%: "29-Apr-86 23:38")
(DECLARE (GLOBALVARS FTPDEBUGFLG FTPDEBUGLOG))
(RESETLST
(LET* ((USERDATA (\LAFITE.GET.USER.DATA))
(USER (fetch (LAFITEUSERDATA FULLUSERNAME) of USERDATA))
(MAILSERVER (CAR (fetch (LAFITEUSERDATA MAILSERVERS) of USERDATA)))
[PLIST (LIST (LIST %'MAILBOX (fetch (MTPPARSE MAILBOX) of PARSE))
(LIST %'SENDER (CONCAT USER "@" (fetch MAILSERVERNAME of MAILSERVER]
(PW (GETPROMPTWINDOW W))
(TEXT (\MTP.COERCE.MSG MSG (fetch (MTPPARSE EOH) of PARSE)
PW))
INS OUTS)
(AND (WINDOWPROP ABORTW %'ABORT)
(ERROR!))
(PRINTOUT PW "delivering...")
(SETQ INS (OPENBSPSTREAM (CONS (CAR (fetch (MAILSERVER MAILPORT) of MAILSERVER))
\PUPSOCKET.MTP)
NIL %'\FTP.ERRORHANDLER))
(if INS
then (RESETSAVE NIL (LIST %'CLOSEBSPSTREAM INS 5000))
else (PRINTOUT PW (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER)
" not responding. ")
(ERROR!))
(SETQ OUTS (BSPOUTPUTSTREAM INS))
(FTPPUTMARK OUTS (MARK# STORE-MAIL))
(\FTP.PRINTPLIST OUTS PLIST)
(FTPPUTMARK OUTS (MARK# EOC))
(SELECTC (FTPGETMARK INS)
((MARK# YES)
(FTPGETCODE INS)
(\FTP.FLUSH.TO.EOC INS (AND FTPDEBUGFLG FTPDEBUGLOG)))
((MARK# NO)
(FTPGETCODE INS)
(\FTP.FLUSH.TO.EOC INS PW)
(ERROR!))
(\FTPERROR INS))
(FTPPUTMARK OUTS (MARK# HERE-IS-FILE))
(PRINTOUT OUTS (fetch (MTPPARSE FROMLINE) of PARSE)
T)
(PRINTOUT OUTS (fetch (MTPPARSE DATELINE) of PARSE)
T)
(COPYBYTES TEXT OUTS)
(if (WINDOWPROP ABORTW %'ABORT)
then (FTPPUTMARK OUTS (MARK# NO))
(ERROR!)
else (FTPPUTMARK OUTS (MARK# YES)))
(FTPPUTMARK OUTS (MARK# EOC))
(SELECTC (FTPGETMARK INS)
((MARK# YES)
(FTPGETCODE INS)
(\FTP.FLUSH.TO.EOC INS (AND FTPDEBUGFLG FTPDEBUGLOG)))
(PROGN (FTPGETCODE INS)
(\FTP.FLUSH.TO.EOC INS PROMPTWINDOW)
(ERROR!)))
T))])
(MTP.PREPARE.SEND
[LAMBDA (MSG W) (* drc%: "17-May-86 17:34")
(LET* [(PARSE (\LAFITE.PREPARE.SEND MSG W))
(RECIPIENTS (APPEND (CDR (FASSOC %'To PARSE))
(CDR (FASSOC %'cc PARSE]
(OR PARSE (\SENDMESSAGEFAIL W "Bad message format."))
(AND (FASSOC %'Sender PARSE)
(\SENDMESSAGEFAIL W "Can't specify Sender!"))
(AND (FASSOC %''Date PARSE)
(\SENDMESSAGEFAIL W "Can't specify Date!"))
(OR RECIPIENTS (\SENDMESSAGEFAIL W "No recipients?"))
(create MTPPARSE
FROMLINE _ (CONCAT (if (ASSOC %'From PARSE)
then "Sender: "
else "From: ")
(FULLUSERNAME))
MAILBOX _ [CONCATLIST (for TAIL on RECIPIENTS
collect (if (CDR TAIL)
then (CONCAT (CAR TAIL)
", ")
else (CAR TAIL]
EOH _ (CADR (FASSOC %'EOF PARSE))
DATELINE _ (CONCAT "Date: " (DATE (DATEFORMAT DAY.OF.WEEK SPACES TIME.ZONE
NO.SECONDS])
(MTP.MAKEANSWERFORM
[LAMBDA (MSGS FOLDER) (* ; "Edited 1-Feb-2022 17:05 by rmk")
(* drc%: "19-May-86 15:39")
(PROG ((OLD.MSG (OR (CAR (LISTP MSGS))
MSGS))
[INSERT? (AND MTP.INSERTANSWERFLG (MENU (\LAFITE.CREATE.MENU %' (("Yes" T
"Insert the text of the message being answered"
)
("No" NIL
"Normal answer form"
)
("Abort" %'ABORT
"Abort Answer command"
))
"Insert Message?"]
(OLD.TEXT (\LAFITE.OPEN.FOLDER FOLDER %'INPUT))
START END OLD.FIELDS SUBJECT FROM TO CC DATE REPLY-TO SENDER NEW.MSG NEW.TO NEW.CC)
(if (EQ INSERT? %'ABORT)
then (RETURN))
(SETQ START (fetch (LAFITEMSG START) of OLD.MSG))
(SETQ END (fetch (LAFITEMSG END) of OLD.MSG))
(SETQ OLD.FIELDS (LAFITE.PARSE.HEADER OLD.TEXT \LAPARSE.FULL START END))
(for PAIR in OLD.FIELDS do (SELECTQ (CAR PAIR)
(Subject (SETQ SUBJECT (CADR PAIR)))
(From (SETQ FROM (CDR PAIR)))
(To (SETQ TO (CDR PAIR)))
(cc (SETQ CC (CDR PAIR)))
(Date (SETQ DATE (CADR PAIR)))
(Reply-to (SETQ REPLY-TO (CDR PAIR)))
(Sender (SETQ SENDER (CDR PAIR)))
NIL))
(SETQ NEW.TO (OR REPLY-TO FROM SENDER))
(OR NEW.TO (RETURN (LAB.PROMPTPRINT FOLDER "Can't reply -- no From or Sender")))
(SETQ NEW.MSG (OPENTEXTSTREAM NIL NIL NIL NIL (LIST %'FONT LAFITEEDITORFONT)))
(LINELENGTH MAX.SMALLP NEW.MSG)
(PRINTOUT NEW.MSG "Subject: ")
(if (NOT (STRING-EQUAL (SUBSTRING SUBJECT 1 3)
"Re:"))
then (printout NEW.MSG "Re: "))
(PRINTOUT NEW.MSG (OR SUBJECT UNSUPPLIEDFIELDSTR)
T)
(AND FROM (PRINTOUT NEW.MSG "In-reply-to: " (CAR FROM)
"'s message of " DATE T))
(PRINTOUT NEW.MSG "To: ")
(\MTP.PRINTADDRESSES NEW.TO NEW.MSG)
(SETQ NEW.CC (LA.SETDIFFERENCE (if REPLY-TO
then (LIST (FULLUSERNAME))
else (LA.REMOVEDUPLICATES (APPEND TO CC)))
NEW.TO))
(if NEW.CC
then (PRINTOUT NEW.MSG "cc: ")
(\MTP.PRINTADDRESSES NEW.CC NEW.MSG))
(TERPRI NEW.MSG)
(if INSERT?
then (\MTP.FILL OLD.TEXT NEW.MSG MTP.INSERTANSWERNSPACES MTP.LINELENGTH START END)
(PRINTOUT NEW.MSG MESSAGESTR T)
else (LET [(SELECTPOSITION (ADD1 (GETFILEPTR NEW.MSG]
(PRINTOUT NEW.MSG MESSAGESTR T)
(TEDIT.SETSEL NEW.MSG SELECTPOSITION (NCHARS MESSAGESTR)
%'RIGHT T)))
(RETURN NEW.MSG])
)
(ADDTOVAR LAFITEMODELST (MTP MTP.PREPARE.SEND MTP.DELIVERMESSAGE MTP.MAKEANSWERFORM MTP.GET.USERDATA))
(DEFINEQ
(\MTP.AUTHENTICATE
[LAMBDA (HOST USER/PWD) (* drc%: "25-Apr-86 13:06")
(* I couldn't get PUP authentication to work w/ our Misc server, so we just check
 for mailbox existence. Password checking is done when retrieving mail.)
(LET* ((RESPONSE (\MTP.POLLNEWMAIL HOST (CAR USER/PWD)))
(TYPE (CAR RESPONSE))
(MESSAGE (CDR RESPONSE)))
(SELECTC TYPE
((LIST \PT.NEWMAIL \PT.NONEWMAIL)
T)
((LIST \PT.NOMAILBOX \PT.ERROR)
(SETQ \LAFITE.AUTHENTICATION.FAILURE MESSAGE)
NIL)
(NIL (PRINTOUT PROMPTWINDOW T HOST " not responding to authentication request." T)
(SETQ \LAFITE.AUTHENTICATION.FAILURE "No Server")
NIL)
NIL])
(\MTP.COERCE.MSG
[LAMBDA (MSG EOH ECHOSTREAM) (* drc%: "19-May-86 16:08")
(DECLARE (GLOBALVARS MTP.LINELENGTH))
(LET [(STREAM (COERCETEXTOBJ MSG %'STREAM))
(FILL? (SELECTQ MTP.FILLMSGFLG
(ALWAYS T)
(ASK (MENU (\LAFITE.CREATE.MENU %' (("Yes" T
"Break long lines in message to MTP.LINELENGTH"
)
("No" NIL "Deliver message as is")
("Abort" %'ABORT "Abort deliver command"))
"Fill Text?")))
(NEVER NIL)
(SHOULDNT]
(if (EQ FILL? %'ABORT)
then (ERROR!))
(if FILL?
then (PRINTOUT ECHOSTREAM "filling...")
(LET ((OUTS (OPENSTREAM %'{NODIRCORE} %'BOTH)))
(COPYBYTES STREAM OUTS 0 EOH)
(\MTP.FILL STREAM OUTS 0 MTP.LINELENGTH)
(SETFILEPTR OUTS 0)
OUTS)
else STREAM])
(\MTP.FILL
[LAMBDA (INS OUTS LMARGIN RMARGIN START END) (* drc%: "19-May-86 16:46")
(* * Copy bytes from INS to OUTS, indenting to LMARGIN.
 New lines started at last space before RMARGIN --
 unless the line ends before RMARGIN + MTP.RIGHTMARGINWIDTH anyway.
 Copy from START (default is current pos) to END
 (default is EOF)%.)
(until (GEQ (GETFILEPTR INS)
END) as COLUMN from (ADD1 LMARGIN) bind (LINEBUF _ (OPENSTREAM %'{NODIRCORE} %'BOTH))
(CARRY _ LMARGIN)
(END _ (OR END (GETEOFPTR INS)))
(LIMIT _ (IPLUS RMARGIN MTP.RIGHTMARGINWIDTH)
)
(EDGE _ (ADD1 RMARGIN))
BYTE SPACE SPACES
first (AND START (SETFILEPTR INS START))
(\MTP.INDENT INS OUTS END LMARGIN) eachtime (SETQ BYTE (BIN INS))
(SELCHARQ BYTE
((SPACE TAB)
(BOUT LINEBUF BYTE)
(push SPACES COLUMN))
(EOL (SETFILEPTR LINEBUF 0)
(\MTP.CLRBUF LINEBUF OUTS)
(BOUT OUTS (CHARCODE EOL))
(\MTP.INDENT INS OUTS END LMARGIN)
(SETQ CARRY (SETQ COLUMN LMARGIN)))
(BOUT LINEBUF BYTE))
when (IGREATERP COLUMN LIMIT) do [if (SETQ SPACE (for SPACE in SPACES
thereis (LEQ SPACE EDGE)))
then (* dump line up to space)
(COPYBYTES LINEBUF OUTS 0 (SUB1 (IDIFFERENCE SPACE
CARRY)))
(BIN LINEBUF)
(* eat up space)
(SETQ COLUMN (IPLUS LMARGIN (IDIFFERENCE COLUMN
SPACE)))
else (* punt)
(COPYBYTES LINEBUF OUTS 0 (IDIFFERENCE RMARGIN CARRY))
(SETQ COLUMN (ADD1 (IPLUS LMARGIN MTP.RIGHTMARGINWIDTH
]
(BOUT OUTS (CHARCODE EOL))
(\MTP.INDENT INS OUTS END LMARGIN)
(\MTP.CLRBUF LINEBUF OUTS)
(SETQ SPACES)
(SETQ CARRY COLUMN) finally (SETFILEPTR LINEBUF 0)
(COPYBYTES LINEBUF OUTS])
(\MTP.INDENT
[LAMBDA (INS OUTS END LMARGIN) (* drc%: "18-May-86 18:31")
(* * indent OUTS to LMARGIN, unless at end of INS or on an empty line)
(if (AND (ILESSP (GETFILEPTR INS)
END)
(NEQ (PEEKCCODE INS)
(CHARCODE EOL)))
then (to LMARGIN do (BOUT OUTS (CHARCODE SPACE])
(\MTP.CLRBUF
[LAMBDA (INS OUTS) (* drc%: "30-Apr-86 00:14")
(* * Flush INS to OUTS, and then clear INS)
(COPYBYTES INS OUTS)
(\SETEOFPTR INS 0)
(SETFILEPTR INS 0])
(\MTP.PRINTADDRESSES
[LAMBDA (ADDRESSLIST STREAM) (* bvm%: "20-Dec-83 18:20")
(for ADDR in ADDRESSLIST bind NTHTIME when ADDR do (COND
(NTHTIME (PRIN1 ", " STREAM))
(T (SETQ NTHTIME T)))
(PRIN1 ADDR STREAM))
(TERPRI STREAM])
)
(RPAQ? MTP.SERVER )
(RPAQ? MTP.LINELENGTH 70)
(RPAQ? MTP.RIGHTMARGINWIDTH 10)
(RPAQ? MTP.FILLMSGFLG %'ASK)
(RPAQ? MTP.INSERTANSWERFLG T)
(RPAQ? MTP.INSERTANSWERNSPACES 3)
(* MTP mail server)
(DEFINEQ
(MTP.OPENMAILBOX
[LAMBDA (PORT USER PWD MAILSERVER) (* drc%: "20-Apr-86 17:49")
(PROG ((MTP.PORT (CONS (CAR PORT)
\PUPSOCKET.MTP))
(HOST (fetch (MAILSERVER MAILSERVERNAME) of MAILSERVER))
(LOGINFO (CONS USER PWD))
INS OUTS)
(SELECTQ (MTP.POLLNEWMAIL PORT USER)
(NIL (RETURN %'EMPTY))
(? (RETURN))
NIL)
NEWCONNECTION
(OR (SETQ INS (OPENBSPSTREAM MTP.PORT NIL (FUNCTION \FTP.ERRORHANDLER)))
(RETURN))
(SETQ OUTS (BSPOUTPUTSTREAM INS))
RETRY
(FTPPUTMARK OUTS (MARK# RETRIEVE-MAIL))
[\FTP.PRINTPLIST OUTS (LIST (LIST %'USER-NAME (CAR LOGINFO))
(LIST %'USER-PASSWORD (CDR LOGINFO]
(.EOC. OUTS)
(SELECTC (FTPGETMARK INS)
((MARK# NO)
(SELECTQ (FTPGETCODE INS)
((16 17) (* bad user/pwd)
(PRINTOUT PROMPTWINDOW T HOST " : ")
(\FTP.FLUSH.TO.EOC INS PROMPTWINDOW)
(TERPRI PROMPTWINDOW)
(SETQ LOGINFO (\INTERNAL/GETPASSWORD HOST T NIL NIL NIL %'UNIX))
(MTP.GET.USERDATA)
(if (BSPOPENP INS %'INPUT)
then (GO RETRY)
else (GO NEWCONNECTION)))
(RETURN (\FTPERROR INS "MTP error"))))
((MARK# HERE-IS-PLIST)
(RETURN (CONS (create MTPMAILBOX
MTPIN _ INS
MTPOUT _ OUTS
MTPSTATE _ %'OPEN))))
(RETURN (\FTPERROR NIL "MTP error"])
(MTP.POLLNEWMAIL
[LAMBDA (HOSTPORT USER) (* drc%: "25-Apr-86 12:44")
(LET* ((RESPONSE (\MTP.POLLNEWMAIL HOSTPORT USER))
(TYPE (CAR RESPONSE))
(MESSAGE (CDR RESPONSE)))
(SELECTC TYPE
(\PT.NEWMAIL T)
(\PT.NONEWMAIL NIL)
((LIST \PT.NOMAILBOX \PT.ERROR)
(printout PROMPTWINDOW T HOSTPORT " : " MESSAGE T)
%'?)
(NIL %'?)
NIL])
(MTP.NEXTMESSAGE
[LAMBDA (MAILBOX) (* bvm%: " 6-JUL-83 14:27")
(SELECTQ (fetch MTPSTATE of MAILBOX)
(EMPTY NIL)
(OPEN [PROG ((PLIST (READPLIST (fetch MTPIN of MAILBOX)))
(NEXTSTATE 'MESSAGE))
(RETURN (PROG1 (OR (for PAIR in PLIST
do (SELECTQ (CAR PAIR)
(LENGTH (push $$VAL 'LENGTH (CADR PAIR)))
(OPENED (SELECTQ (CADR PAIR)
((YES Yes yes)
(push $$VAL 'EXAMINED T))
NIL))
(DELETED (SELECTQ (CADR PAIR)
((YES Yes yes)
(push $$VAL 'DELETEDFLG T)
(FTPGETMARK (fetch MTPIN
of MAILBOX))
(\FTP.FLUSH.TO.MARK (fetch MTPIN
of MAILBOX)
)
(SETQ NEXTSTATE
(\MTP.ENDOFMESSAGESTATE
(fetch MTPIN of MAILBOX))))
NIL))
NIL))
T)
(replace MTPSTATE of MAILBOX with NEXTSTATE])
(ERROR "Mailbox not in good state for NEXTMESSAGE" MAILBOX])
(MTP.RETRIEVEMESSAGE
[LAMBDA (MAILBOX OUTSTREAM) (* bvm%: " 6-JUL-83 14:27")
(SELECTQ (fetch MTPSTATE of MAILBOX)
(MESSAGE [COND
((EQ (FTPGETMARK (fetch MTPIN of MAILBOX))
(MARK# HERE-IS-FILE))
(\FTP.FLUSH.TO.MARK (fetch MTPIN of MAILBOX)
OUTSTREAM)
(replace MTPSTATE of MAILBOX with (\MTP.ENDOFMESSAGESTATE (fetch MTPIN
of MAILBOX])
(\FTPERROR])
(MTP.CLOSEMAILBOX
[LAMBDA (MAILBOX FLUSHP) (* bvm%: " 9-May-84 15:35")
(COND
((BSPOPENP (fetch MTPIN of MAILBOX))
(PROG1 [COND
((AND FLUSHP (EQ (fetch MTPSTATE of MAILBOX)
'EMPTY))
(FTPPUTMARK (fetch MTPOUT of MAILBOX)
(MARK# FLUSH-MAILBOX))
(.EOC. (fetch MTPOUT of MAILBOX))
(SELECTC (FTPGETMARK (fetch MTPIN of MAILBOX))
((MARK# YES)
(FTPGETCODE (fetch MTPIN of MAILBOX))
(\FTP.FLUSH.TO.EOC (fetch MTPIN of MAILBOX)
(.FTPDEBUGLOG.))
T)
((MARK# NO)
(FTPGETCODE (fetch MTPIN of MAILBOX))
(\FTP.FLUSH.TO.EOC (fetch MTPIN of MAILBOX)
PROMPTWINDOW)
'?)
(PROGN (\FTPERROR)
'?]
(CLOSEBSPSTREAM (fetch MTPIN of MAILBOX)
5000))])
)
(DEFINEQ
(\MTP.ENDOFMESSAGESTATE
[LAMBDA (INSTREAM) (* bvm%: " 5-SEP-83 18:08")
(SELECTC (FTPGETMARK INSTREAM)
((MARK# HERE-IS-PLIST)
'OPEN)
((MARK# YES)
(FTPGETCODE INSTREAM)
(\FTP.FLUSH.TO.EOC INSTREAM (.FTPDEBUGLOG.))
'EMPTY)
((MARK# NO)
(FTPGETCODE INSTREAM)
(\FTP.FLUSH.TO.EOC INSTREAM PROMPTWINDOW)
'ERROR)
(\FTPERROR])
(\MTP.POLLNEWMAIL
[LAMBDA (HOSTPORT USER) (* drc%: "25-Apr-86 12:28")
(* * Does a Laurel-style mail check for USER on machine HOSTPORT, returning NIL
 (timeout) or a cons of the PUP type of the response and the contents of the
 response)
(LET ((SOC (\GETMISCSOCKET))
(OUTPUP (ALLOCATE.PUP))
INPUP RESPONSE)
(SETUPPUP OUTPUP HOSTPORT \PUPSOCKET.MISCSERVICES \PT.LAURELCHECK NIL SOC T)
(PUTPUPSTRING OUTPUP USER)
[SETQ RESPONSE (to \MAXETHERTRIES when (SETQ INPUP (EXCHANGEPUPS SOC OUTPUP NIL T))
do (RETURN (CONS (fetch PUPTYPE of INPUP)
(GETPUPSTRING INPUP)))
finally (AND PUPTRACEFLG (printout PUPTRACEFILE "Mail check timed out" T]
(AND INPUP (RELEASE.PUP INPUP))
(RELEASE.PUP OUTPUP)
RESPONSE])
)
(ADDTOVAR MAILSERVERTYPES (MTP MTP.POLLNEWMAIL MTP.OPENMAILBOX MTP.NEXTMESSAGE MTP.RETRIEVEMESSAGE
MTP.CLOSEMAILBOX ETHERPORT))
(FILESLOAD LAFITE)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD MTPMAILBOX (MTPIN MTPOUT MTPSTATE))
(RECORD MTPPARSE (FROMLINE MAILBOX EOH DATELINE))
)
(DECLARE%: EVAL@COMPILE
(RPAQQ \PUPSOCKET.MTP 7)
(RPAQQ \PUPSOCKET.MISCSERVICES 4)
(CONSTANTS \PUPSOCKET.MTP \PUPSOCKET.MISCSERVICES)
)
(RPAQQ PUPTYPES
((\PT.ECHOME 1)
(\PT.IAMECHO 2)
(\PT.IAMBADECHO 3)
(\PT.ERROR 4)
(\PT.RFC 8)
(\PT.ABORT 9)
(\PT.END 10)
(\PT.ENDREPLY 11)
(\PT.DATA 16)
(\PT.ADATA 17)
(\PT.ACK 18)
(\PT.MARK 19)
(\PT.INTERRUPT 20)
(\PT.INTERRUPTREPLY 21)
(\PT.AMARK 22)
(\PT.GATEWAYREQUEST 128)
(\PT.GATEWAYRESPONSE 129)
(\PT.ALTOTIMEREQUEST 134)
(\PT.ALTOTIMERESPONSE 135)
(\PT.MSGCHECK 136)
(\PT.NEWMAIL 137)
(\PT.NONEWMAIL 138)
(\PT.NOMAILBOX 139)
(\PT.LAURELCHECK 140)
(\PT.NAMELOOKUP 144)
(\PT.NAMERESPONSE 145)
(\PT.NAME/ADDRERROR 146)
(\PT.ADDRLOOKUP 147)
(\PT.ADDRRESPONSE 148)
(\PT.PRINTERSTATUS 128)
(\PT.STATUSRESPONSE 129)
(\PT.PRINTERCAPABILITY 130)
(\PT.CAPABILITYRESPONSE 131)
(\PT.PRINTJOBSTATUS 132)
(\PT.PRINTJOBRESPONSE 133)
(\PT.WHEREUSERREQUEST 152)
(\PT.WHEREUSERRESPONSE 153)
(\PT.WHEREUSERERROR 154)
(\PT.AUTHREQ 168)
(\PT.AUTHPOSRESP 169)
(\PT.AUTHNEGRESP 170)))
(DECLARE%: EVAL@COMPILE
(RPAQQ \PT.ECHOME 1)
(RPAQQ \PT.IAMECHO 2)
(RPAQQ \PT.IAMBADECHO 3)
(RPAQQ \PT.ERROR 4)
(RPAQQ \PT.RFC 8)
(RPAQQ \PT.ABORT 9)
(RPAQQ \PT.END 10)
(RPAQQ \PT.ENDREPLY 11)
(RPAQQ \PT.DATA 16)
(RPAQQ \PT.ADATA 17)
(RPAQQ \PT.ACK 18)
(RPAQQ \PT.MARK 19)
(RPAQQ \PT.INTERRUPT 20)
(RPAQQ \PT.INTERRUPTREPLY 21)
(RPAQQ \PT.AMARK 22)
(RPAQQ \PT.GATEWAYREQUEST 128)
(RPAQQ \PT.GATEWAYRESPONSE 129)
(RPAQQ \PT.ALTOTIMEREQUEST 134)
(RPAQQ \PT.ALTOTIMERESPONSE 135)
(RPAQQ \PT.MSGCHECK 136)
(RPAQQ \PT.NEWMAIL 137)
(RPAQQ \PT.NONEWMAIL 138)
(RPAQQ \PT.NOMAILBOX 139)
(RPAQQ \PT.LAURELCHECK 140)
(RPAQQ \PT.NAMELOOKUP 144)
(RPAQQ \PT.NAMERESPONSE 145)
(RPAQQ \PT.NAME/ADDRERROR 146)
(RPAQQ \PT.ADDRLOOKUP 147)
(RPAQQ \PT.ADDRRESPONSE 148)
(RPAQQ \PT.PRINTERSTATUS 128)
(RPAQQ \PT.STATUSRESPONSE 129)
(RPAQQ \PT.PRINTERCAPABILITY 130)
(RPAQQ \PT.CAPABILITYRESPONSE 131)
(RPAQQ \PT.PRINTJOBSTATUS 132)
(RPAQQ \PT.PRINTJOBRESPONSE 133)
(RPAQQ \PT.WHEREUSERREQUEST 152)
(RPAQQ \PT.WHEREUSERRESPONSE 153)
(RPAQQ \PT.WHEREUSERERROR 154)
(RPAQQ \PT.AUTHREQ 168)
(RPAQQ \PT.AUTHPOSRESP 169)
(RPAQQ \PT.AUTHNEGRESP 170)
(CONSTANTS (\PT.ECHOME 1)
(\PT.IAMECHO 2)
(\PT.IAMBADECHO 3)
(\PT.ERROR 4)
(\PT.RFC 8)
(\PT.ABORT 9)
(\PT.END 10)
(\PT.ENDREPLY 11)
(\PT.DATA 16)
(\PT.ADATA 17)
(\PT.ACK 18)
(\PT.MARK 19)
(\PT.INTERRUPT 20)
(\PT.INTERRUPTREPLY 21)
(\PT.AMARK 22)
(\PT.GATEWAYREQUEST 128)
(\PT.GATEWAYRESPONSE 129)
(\PT.ALTOTIMEREQUEST 134)
(\PT.ALTOTIMERESPONSE 135)
(\PT.MSGCHECK 136)
(\PT.NEWMAIL 137)
(\PT.NONEWMAIL 138)
(\PT.NOMAILBOX 139)
(\PT.LAURELCHECK 140)
(\PT.NAMELOOKUP 144)
(\PT.NAMERESPONSE 145)
(\PT.NAME/ADDRERROR 146)
(\PT.ADDRLOOKUP 147)
(\PT.ADDRRESPONSE 148)
(\PT.PRINTERSTATUS 128)
(\PT.STATUSRESPONSE 129)
(\PT.PRINTERCAPABILITY 130)
(\PT.CAPABILITYRESPONSE 131)
(\PT.PRINTJOBSTATUS 132)
(\PT.PRINTJOBRESPONSE 133)
(\PT.WHEREUSERREQUEST 152)
(\PT.WHEREUSERRESPONSE 153)
(\PT.WHEREUSERERROR 154)
(\PT.AUTHREQ 168)
(\PT.AUTHPOSRESP 169)
(\PT.AUTHNEGRESP 170))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS MTP.SERVER MTP.LINELENGTH MTP.RIGHTMARGINWIDTH MTP.FILLMSGFLG MTP.INSERTANSWERFLG
MTP.INSERTANSWERNSPACES \LAPARSE.FULL LAFITEEDITORFONT UNSUPPLIEDFIELDSTR MESSAGESTR
\LAFITEUSERDATA MAILSERVERTYPES \LAFITE.AUTHENTICATION.FAILURE)
)
(FILESLOAD (LOADCOMP)
LAFITE DPUPFTP)
)
(PUTPROPS MTP COPYRIGHT ("Xerox Corporation" 1983 1984 1986))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2193 11600 (MTP.GET.USERDATA 2203 . 3410) (MTP.DELIVERMESSAGE 3412 . 6253) (
MTP.PREPARE.SEND 6255 . 7703) (MTP.MAKEANSWERFORM 7705 . 11598)) (11709 18664 (\MTP.AUTHENTICATE 11719
. 12593) (\MTP.COERCE.MSG 12595 . 13858) (\MTP.FILL 13860 . 17553) (\MTP.INDENT 17555 . 17955) (
\MTP.CLRBUF 17957 . 18197) (\MTP.PRINTADDRESSES 18199 . 18662)) (18894 25470 (MTP.OPENMAILBOX 18904 .
20828) (MTP.POLLNEWMAIL 20830 . 21345) (MTP.NEXTMESSAGE 21347 . 23541) (MTP.RETRIEVEMESSAGE 23543 .
24195) (MTP.CLOSEMAILBOX 24197 . 25468)) (25471 26963 (\MTP.ENDOFMESSAGESTATE 25481 . 25977) (
\MTP.POLLNEWMAIL 25979 . 26961)))))
STOP

47
lispusers/NOTECARDS-4045XLPPATCH
View File

@@ -1,47 +0,0 @@
(FILECREATED "15-Dec-86 16:30:35" {DANTE}<SNOW>4045>V1.4>NOTECARDS-4045XLPPATCH.;2 1578
changes to: (FNS 4045XLP.NoteCardsAdvice)
previous date: "26-Sep-86 14:20:43" {DANTE}<SNOW>4045>V1.4>NOTECARDS-4045XLPPATCH.;1)
(* Copyright (c) 1986 by Xerox Corporation and Will Snow. All rights reserved.)
(PRETTYCOMPRINT NOTECARDS-4045XLPPATCHCOMS)
(RPAQQ NOTECARDS-4045XLPPATCHCOMS ((FNS 4045XLP.NoteCardsAdvice)
(P (4045XLP.NoteCardsAdvice))))
(DEFINEQ
(4045XLP.NoteCardsAdvice
[LAMBDA NIL (* edited: "15-Dec-86 16:29")
[ADVISE (QUOTE NC.LinkIconDisplayFn)
(QUOTE BEFORE)
NIL
(QUOTE (COND ((OR (NULL STREAMTYPE)
(EQ STREAMTYPE (QUOTE 4045XLP)))
(SETQ STREAMTYPE (QUOTE DISPLAY]
(ADVISE (QUOTE (STRINGWIDTH IN NC.LinkIconImageBoxFn))
(QUOTE AFTER)
NIL
(QUOTE (AND (EQ (IMAGESTREAMTYPE ImageStream)
(QUOTE 4045XLP))
(RETURN (IQUOTIENT (STRINGWIDTH (CONCAT "nn"
(if Label
then
(CONCAT "<"
Label ">")
else "")
(if (AND Label
Title)
then " "
else "")
(OR Title ""))
ImageStream)
Scale])
)
(4045XLP.NoteCardsAdvice)
(PUTPROPS NOTECARDS-4045XLPPATCH COPYRIGHT ("Xerox Corporation and Will Snow" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (478 1445 (4045XLP.NoteCardsAdvice 488 . 1443)))))
STOP

106
lispusers/NSALLOCATION
View File

@@ -1,106 +0,0 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "19-Feb-88 19:27:57" {QV}<BURWELL>LISP>NSALLOCATION.\;3 6361
|changes| |to:| (FNS NSALLOCATION.STATS NSALLOCATION)
|previous| |date:| "19-Feb-88 18:05:54" {QV}<BURWELL>LISP>NSALLOCATION.\;1)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT NSALLOCATIONCOMS)
(RPAQQ NSALLOCATIONCOMS ((FNS NSALLOCATION NSALLOCATION.STATS)))
(DEFINEQ
(NSALLOCATION
(LAMBDA (|FileServers| |ReportFile| |Filter|) (* \; "Edited 19-Feb-88 18:10 by bbb")
(LET ((|NSDiskSizeInPages| 433907)
|ReportFileStream|)
(CL:WITH-OPEN-FILE (|ReportFileStream| |ReportFile| :DIRECTION :OUTPUT)
(|if| |Filter|
|then| (|printout| |ReportFileStream| "Using Filter " |Filter| T T))
(|printout| |ReportFileStream| .FONT '(TERMINAL 12) "File Service" .TAB 20
"# Pages Used" .TAB 35 "as %" .TAB 45 "# Pages Used" .TAB 60 "as %" .TAB 70
"# Pages" .TAB 80 "as %" .TAB 90 "Total % Used" T)
(|printout| |ReportFileStream| "Name" .TAB 20 "Unrestricted" .TAB 35 "of disk" .TAB
45 "Restricted" .TAB 60 "of alloc" .TAB 70 "alloc" .TAB 80 "of disk" .TAB 90
"of disk" T)
(|printout| |ReportFileStream| "----------------" .TAB 20 "------------" .TAB 35
"-------" .TAB 45 "------------" .TAB 60 "--------" .TAB 70 "-------" .TAB 80
"-------" .TAB 90 "------------" T)
(|printout| |ReportFileStream| T)
(|for| |Server| |in| |FileServers| |bind| |Result| |PagesUnrestricted|
|PagesRestricted| |PagesAllocated|
|PercentUnrestricted|
|PercentRestrictedofAllocated|
|PercentAllocated| |TotalPercentUsed|
|when| (SETQ |Result| (NSALLOCATION.STATS |Server| |Filter|))
|do| (SETQ |PagesUnrestricted| (CAR (NTH |Result| 1)))
(SETQ |PagesRestricted| (CAR (NTH |Result| 2)))
(SETQ |PagesAllocated| (CAR (NTH |Result| 3)))
(SETQ |PercentUnrestricted| (TIMES (FQUOTIENT |PagesUnrestricted|
|NSDiskSizeInPages|)
100.0))
(SETQ |PercentRestrictedofAllocated| (TIMES (FQUOTIENT |PagesRestricted|
|PagesAllocated|)
100.0))
(SETQ |PercentAllocated| (TIMES (FQUOTIENT |PagesAllocated|
|NSDiskSizeInPages|)
100.0))
(SETQ |TotalPercentUsed| (TIMES (FQUOTIENT (PLUS |PagesUnrestricted|
|PagesRestricted|)
|NSDiskSizeInPages|)
100.0))
(|printout| |ReportFileStream| |Server| .TAB 20 |.I12| |PagesUnrestricted|
.TAB 35 |.F7.1| |PercentUnrestricted| .TAB 45 |.I12| |PagesRestricted|
.TAB 60 |.F8.2| |PercentRestrictedofAllocated| .TAB 70 |.I7|
|PagesAllocated| .TAB 80 |.F7.1| |PercentAllocated| .TAB 90 |.F12.1|
|TotalPercentUsed| T))))))
(NSALLOCATION.STATS
(LAMBDA (|FileServiceName| |Filter|) (* \; "Edited 19-Feb-88 19:20 by bbb")
(* |;;|
 "Given a file service name the following three pieces of data are returned in a list: ")
(* |;;| " 1) number of pages in use of unrestricted file drawers")
(* |;;| " 2) number of pages in use in restricted file drawers")
(* |;;| " 3) number of pages allocated to file drawers")
(* |;;| "")
(* |;;| " If Filter is NON-NIL then it is used as a file pattern for selecting directories")
(LET* ((|FileServiceDirectories| (DIRECTORY (CONCAT "{" |FileServiceName| "}")
'COLLECT))
(|FileServiceDevice| (\\GETDEVICEFROMNAME |FileServiceName|))
(|NumBytesUnrestricted| 0)
(|NumBytesRestricted| 0)
(|NumBytesAllocated| 0)
(|BytesPerPage| 512)
(|Filter| (|if| |Filter|
|then| (DIRECTORY.MATCH.SETUP |Filter|))))
(|for| |Directory| |in| |FileServiceDirectories| |bind| |DirectoryAllocation|
|DirectoryUsed|
|when| (OR (NULL |Filter|)
(DIRECTORY.MATCH |Filter| |Directory|))
|do| (SETQ |DirectoryAllocation| (\\NSFILING.GETFILEINFO |Directory| 'SUBTREE.SIZE.LIMIT
|FileServiceDevice|))
(SETQ |DirectoryUsed| (\\NSFILING.GETFILEINFO |Directory| 'SUBTREE.SIZE
|FileServiceDevice|))
(|if| (IGEQ |DirectoryAllocation| 0)
|then| (|add| |NumBytesAllocated| |DirectoryAllocation|)
(|add| |NumBytesRestricted| |DirectoryUsed|)
|else| (|add| |NumBytesUnrestricted| |DirectoryUsed|)))
(LIST (FQUOTIENT |NumBytesUnrestricted| |BytesPerPage|)
(FQUOTIENT |NumBytesRestricted| |BytesPerPage|)
(FQUOTIENT |NumBytesAllocated| |BytesPerPage|)))))
)
(PUTPROPS NSALLOCATION COPYRIGHT ("Xerox Corporation" 1988))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (457 6277 (NSALLOCATION 467 . 3985) (NSALLOCATION.STATS 3987 . 6275)))))
STOP

37
lispusers/NSCOPYFILE
View File

@@ -1,37 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "10-Dec-87 11:40:53" {ERIS}<VANMELLE>LISP>NSCOPYFILE.;3 2187
changes to%: (FNS NSCOPYFILE)
previous date%: " 9-Oct-87 17:35:59" {ERIS}<VANMELLE>LISP>NSCOPYFILE.;2)
(* "
Copyright (c) 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT NSCOPYFILECOMS)
(RPAQQ NSCOPYFILECOMS ((FNS NSCOPYFILE) (PROP FILETYPE NSCOPYFILE) (LOCALVARS . T) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE COPYFILE) (QUOTE \GENERIC.COPYFILE)) (AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM)) (AND (CCODEP (QUOTE \NSFILING.COPYFILE)) (CCODEP (QUOTE NSCOPYFILE)) (MOVD (QUOTE NSCOPYFILE) (QUOTE COPYFILE) NIL T)))))
)
(DEFINEQ
(NSCOPYFILE
(LAMBDA (FROMFILE TOFILE DESTPARAMETERS) (* ; "Edited 10-Dec-87 11:40 by bvm:") (* ;; "Special version of COPYFILE that lets NS servers do efficient or information-preserving copy. Perhaps COPYFILE will be a device method some day.") (LET ((*UPPER-CASE-FILE-NAMES* NIL) FROMDEV TODEV) (if (AND (NULL DESTPARAMETERS) (NOT (NULL TOFILE)) (NEQ TOFILE T) (SETQ FROMDEV (\GETDEVICEFROMNAME (SETQ FROMFILE (\ADD.CONNECTED.DIR (if (TYPEP FROMFILE (QUOTE PATHNAME)) then (\CONVERT-PATHNAME FROMFILE) else FROMFILE))))) (EQ (fetch (FDEV OPENFILE) of FROMDEV) (FUNCTION \NSFILING.OPENFILE)) (SETQ TODEV (\GETDEVICEFROMNAME (SETQ TOFILE (\ADD.CONNECTED.DIR (if (TYPEP TOFILE (QUOTE PATHNAME)) then (\CONVERT-PATHNAME TOFILE) else TOFILE))))) (EQ (fetch (FDEV OPENFILE) of TODEV) (FUNCTION \NSFILING.OPENFILE))) then (* ; "Both source and destination are NS servers.") (\NSFILING.COPYFILE FROMDEV FROMFILE TODEV TOFILE) else (\GENERIC.COPYFILE FROMFILE TOFILE DESTPARAMETERS))))
)
)
(PUTPROPS NSCOPYFILE FILETYPE :COMPILE-FILE)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(MOVD? (QUOTE COPYFILE) (QUOTE \GENERIC.COPYFILE))
(AND (EQ MAKESYSNAME :LYRIC) (FILESLOAD (SYSLOAD) NSRANDOM))
(AND (CCODEP (QUOTE \NSFILING.COPYFILE)) (CCODEP (QUOTE NSCOPYFILE)) (MOVD (QUOTE NSCOPYFILE) (QUOTE COPYFILE) NIL T))
)
(PUTPROPS NSCOPYFILE COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (738 1735 (NSCOPYFILE 748 . 1733)))))
STOP

BIN
lispusers/NSCOPYFILE.LCOM
View File

Binary file not shown.

BIN
lispusers/NSCOPYFILE.TEDIT
View File

Binary file not shown.

269
lispusers/NSPROTECTION
View File

@@ -1,269 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "21-Apr-2021 11:56:06" 
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>NSPROTECTION.;4 32481
changes to%: (FNS NSPROT.LIMITCHARS)
previous date%: " 7-Sep-89 12:31:44"
{DSK}<Users>kaplan>Local>medley3.5>git-medley>lispusers>NSPROTECTION.;2)
(* ; "
Copyright (c) 1987, 1989, 2021 by Xerox Corporation.
")
(PRETTYCOMPRINT NSPROTECTIONCOMS)
(RPAQQ NSPROTECTIONCOMS
[(COMS (* ; "Main window selection handlers")
(FNS NSPROTECTION NSPROT.SHOW NSPROT.FETCH.PROTECTION NSPROT.NEW.ENTRY NSPROT.APPLY
NSPROT.SET.PROTECTION NSPROT.SET.PROTECTION.ONE NSPROT.SET.MULTIPLE
NSPROT.SET.TO.DEFAULT NSPROT.BEGIN.COMMAND)
(FNS NSPROT.HANDLE.TYPE NSPROT.RESTORE.TYPE NSPROT.HANDLE.VERIFY NSPROT.RESTORE.VERIFY
NSPROT.PARSE.FILENAME NSPROT.PARSE.PROTECTIONS NSPROT.STRIP.HOST
NSPROT.EXPAND.FULLNAME))
(COMS (* ; "Handle protection submenus")
(FNS NSPROT.GET.SUBMENU NSPROT.ADD.SUBMENU NSPROT.REMOVE.SUBMENUS NSPROT.CHANGE.STATE
NSPROT.HANDLE.ALL NSPROT.MESSAGE.ALL NSPROT.HANDLE.SUBTYPE NSPROT.SHOW.PROT.VALUE)
)
(COMS (* ; "utilities")
(FNS NSPROT.DIRECTORY.SYNTAXP NSPROT.TOP.LEVELP NSPROT.GET.FONT NSPROT.PROMPT
NSPROT.CLEAR.PROMPT NSPROT.LIMITCHARS NSPROT.PAGEFULLFN NSPROT.ICONFN))
(INITVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT)
(VARS NSPROT.ICON)
(GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON
\DEFAULTTTYDISPLAYSTREAM)
(LOCALVARS . T)
[COMS [DECLARE%: DONTEVAL@LOAD DOCOPY (P (AND (EQ MAKESYSNAME :LYRIC)
(FILESLOAD (SYSLOAD)
NSRANDOM]
(FNS ADD.NSPROTECTION)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (ADD.NSPROTECTION]
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA])
(* ; "Main window selection handlers")
(DEFINEQ
(NSPROTECTION
(LAMBDA NIL (* ; "Edited 1-Sep-87 10:31 by bvm:") (* ;; "Main entry--create the NS protection tool main window and prompt window.") (LET* ((PLAINFONT (NSPROT.GET.FONT)) (BOLDFONT (NSPROT.GET.FONT T)) (HEIGHTDIFFERENCE (- (FONTPROP BOLDFONT (QUOTE HEIGHT)) (FONTPROP PLAINFONT (QUOTE HEIGHT)))) (W (FREEMENU (BQUOTE ((PROPS COLUMNSPACE 14 FONT (\, BOLDFONT)) ((LABEL "Show" SELECTEDFN NSPROT.SHOW MESSAGE "Show the current protection of the specified directory/file.") (LABEL "New Entry" SELECTEDFN NSPROT.NEW.ENTRY MESSAGE "Add a new protection entry (you fill it in).") (LABEL "Apply" SELECTEDFN NSPROT.APPLY MESSAGE "Apply the indicated protections to the file.") (LABEL "Set to Default" SELECTEDFN NSPROT.SET.TO.DEFAULT MESSAGE "Make the file inherit protection from its parent (sub)directory." MAXWIDTH 275)) ((PROPS COLUMNSPACE 4) (LABEL "Type:" TYPE STATE CHANGESTATE NSPROT.HANDLE.TYPE INITSTATE "Principal" MESSAGE "Show directory's own protection, or default for its children? (can be different)" ID TYPE LINKS (DISPLAY PROTECTION-TYPE)) (LABEL "" TYPE DISPLAY ID PROTECTION-TYPE FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "Children Only " PLAINFONT))) (LABEL "Check:" TYPE STATE CHANGESTATE NSPROT.HANDLE.VERIFY INITSTATE "New Names Only" MESSAGE "Check names in protection entries against Clearinghouse?" ID CHECK LINKS (DISPLAY VERIFYFLG)) (LABEL "" TYPE DISPLAY ID VERIFYFLG FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE) MAXWIDTH (\, (STRINGWIDTH "New Names Only" PLAINFONT)))) ((PROPS COLUMNSPACE (\, (+ 6 (- (STRINGWIDTH "Dir/File:" BOLDFONT) (STRINGWIDTH "Host:" BOLDFONT))))) (LABEL "Host:" TYPE EDITSTART MESSAGE "Fill in the name of the NS file server" LINKS (EDIT HOST)) (LABEL (\, (CONCAT)) TYPE EDIT ID HOST LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))) ((PROPS COLUMNSPACE 6) (LABEL "Dir/File:" TYPE EDITSTART MESSAGE "Fill in the name of the desired directory or file." LINKS (EDIT DIR)) (LABEL (\, (CONCAT)) TYPE EDIT ID DIR LIMITCHARS NSPROT.LIMITCHARS FONT (\, PLAINFONT) BOTTOM (\, HEIGHTDIFFERENCE))))) "NS File Protection Tool")) (REG (WINDOWREGION W)) PW) (* ;; "The HEIGHTDIFFERENCE hacking is to get the baselines of the bold and plain fonts to line up (odd that they don't already). (CONCAT) instead of %"%" to ease my pain of debugging--otherwise, the edit items would all be fat, and Lyric's Courier doesn't handle that gracefully.") (WINDOWPROP W (QUOTE FM.DONTRESHAPE) T) (WINDOWPROP W (QUOTE MINSIZE) (CONS (fetch (REGION WIDTH) of REG) (fetch (REGION HEIGHT) of REG))) (* ; "Don't let window shape any smaller than it is.") (WINDOWPROP W (QUOTE VERIFYFLG) :NEW) (WINDOWPROP W (QUOTE PROTECTION-TYPE) T) (WINDOWPROP W (QUOTE ICONFN) (FUNCTION NSPROT.ICONFN)) (MOVEW W (GETBOXPOSITION (fetch (REGION WIDTH) of REG) (+ (fetch (REGION HEIGHT) of REG) (HEIGHTIFWINDOW (FONTPROP PLAINFONT (QUOTE HEIGHT)))))) (OPENW W) (SETQ PW (GETPROMPTWINDOW W NIL PLAINFONT)) (* ; "Arrange for prompt window to expand itself by one line at a time if it overflows") (WINDOWPROP PW (QUOTE PAGEFULLFN) (QUOTE NSPROT.PAGEFULLFN)) (WINDOWPROP W (QUOTE FM.PROMPTWINDOW) PW) NIL))
)
(NSPROT.SHOW
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 1-Sep-87 10:50 by bvm:") (LET ((DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) OLDWINDOWS) (if DEV&FILESPEC then (NSPROT.REMOVE.SUBMENUS WINDOW) (CL:MULTIPLE-VALUE-BIND (PROT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.FETCH.PROTECTION WINDOW DEV FILESPEC))) (if CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION) ELSE (for P in PROT do (NSPROT.SHOW.PROT.VALUE P WINDOW))) (NSPROT.RESTORE.VERIFY WINDOW)))))
)
(NSPROT.FETCH.PROTECTION
(LAMBDA (WINDOW DEV FILESPEC) (* ; "Edited 3-Dec-87 17:09 by bvm:") (* ;; "Return the access list of FILESPEC on DEV of the flavor requested by window (or implicitly by the filespec being a non-directory). This fn prints its own messages when the defaulting is interesting.") (if (SETQ FILESPEC (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) then (LET* ((TYPE (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE ACCESS.LIST))) TOPLEVELP (DIRP (NSPROT.DIRECTORY.SYNTAXP FILESPEC)) (DESIREDPROPS (if DIRP then (* ; "Check both kinds of access list, and if top-level also get usage stats") (BQUOTE ((\,@ (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)) (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST))))) (\,@ (AND (EQ TYPE (QUOTE ACCESS.LIST)) (SETQ TOPLEVELP (NSPROT.TOP.LEVELP FILESPEC)) (CONSTANT (LIST (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE)) (\FILING.ATTRIBUTE.TYPE (QUOTE SUBTREE.SIZE.LIMIT)))))))) else (LIST (\FILING.ATTRIBUTE.TYPE TYPE)))) (PROPS (\NSFILING.GET/SETINFO DEV FILESPEC (FUNCTION \NSFILING.GET.ATTRIBUTES))) PROT OTHER) (DECLARE (CL:SPECIAL DESIREDPROPS)) (* ; "Go thru internal filing interface in order to intercept errors and get more than one attribute at once. DESIREDPROPS is used free under \nsfiling.get/setinfo.") (if (OR (NULL PROPS) (EQ (CAR PROPS) (QUOTE ERROR))) then (NSPROT.PROMPT WINDOW "Failed: ~A" (CADDR PROPS)) elseif (NULL (SETQ PROT (CADR (ASSOC TYPE PROPS)))) then (NSPROT.PROMPT WINDOW "Failed to fetch protection.") else (if (AND DIRP (EQ TYPE (QUOTE ACCESS.LIST)) (SETQ OTHER (CADR (ASSOC (QUOTE DEFAULT.ACCESS.LIST) PROPS))) (NOT (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))) then (* ; "We're fetching the principal access list for a directory, but it has a non-defaulted DEFAULT.ACCESS.LIST, so warn user") (NSPROT.PROMPT WINDOW "Note: this ~:[~;protection is inherited, but the ~]directory has a separate default protection for its children." (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT)) elseif (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of PROT) then (* ; "defaulted value, explain.") (if (EQ TYPE (QUOTE ACCESS.LIST)) then (NSPROT.PROMPT WINDOW "The protection shown is inherited from the parent.") else (NSPROT.PROMPT WINDOW "This is the directory's principal protection~:[~;, which is itself inherited~]." (AND (SETQ OTHER (CADR (ASSOC (QUOTE ACCESS.LIST) PROPS))) (COURIER.FETCH (FILING . ACCESS.LIST) DEFAULTED of OTHER))))) (if TOPLEVELP then (* ; "Top-level directory, also give usage stats.") (LET ((USED (CADR (ASSOC (QUOTE SUBTREE.SIZE) PROPS))) (LIMIT (CADR (ASSOC (QUOTE SUBTREE.SIZE.LIMIT) PROPS)))) (NSPROT.PROMPT WINDOW "~&Directory contains ~D pages ~:[(unlimited allocation)~;out of ~:*~D allocated~]" (FOLDHI USED BYTESPERPAGE) (AND (>= LIMIT 0) (FOLDHI LIMIT BYTESPERPAGE))))) (COURIER.FETCH (FILING . ACCESS.LIST) ENTRIES of PROT)))))
)
(NSPROT.NEW.ENTRY
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 16:14 by bvm:") (* ;; "Handles the NEW ENTRY button -- adds another protection entry and starts editing the name field of it") (NSPROT.BEGIN.COMMAND WINDOW) (LET* ((SUBW (NSPROT.GET.SUBMENU WINDOW)) (NAMEITEM (FM.GETITEM (QUOTE NAME) NIL SUBW))) (FM.CHANGESTATE (FM.GETITEM (QUOTE READ) NIL SUBW) T SUBW) (* ; "Initial protection = READ") (FM.CHANGELABEL NAMEITEM (CONCAT) SUBW) (* ; "Initial name is empty") (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) NIL) (* ; "erase any previous cache") (NSPROT.ADD.SUBMENU SUBW WINDOW) (FM.EDITITEM NAMEITEM SUBW)))
)
(NSPROT.APPLY
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 14:38 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm setting the displayed protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW)) (SETQ PROT (NSPROT.PARSE.PROTECTIONS WINDOW))) then (if (AND (NULL (SETQ PROT (CAR PROT))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW "Can't set empty protection.") elseif (AND (for PAIR in PROT never (MEMB (QUOTE OWNER) (CADR PAIR))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) then (NSPROT.PROMPT WINDOW T "Can't: Somebody must retain owner access.") else (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC PROT))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION)))) (NSPROT.RESTORE.VERIFY WINDOW))))
)
(NSPROT.SET.PROTECTION
(LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 31-Aug-87 18:22 by bvm:") (if (STRPOS "*" FILESPEC) then (NSPROT.SET.MULTIPLE WINDOW DEV FILESPEC PROT) elseif (NULL (NSPROT.EXPAND.FULLNAME WINDOW DEV FILESPEC)) elseif (NSPROT.SET.PROTECTION.ONE DEV FILESPEC PROT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) then (NSPROT.PROMPT WINDOW "Done, ~:[~;children's default ~]protection set ~A." (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (if (EQ PROT T) then "to default" else "as shown")) else (NSPROT.PROMPT WINDOW "Failed to set protection.")))
)
(NSPROT.SET.PROTECTION.ONE
(LAMBDA (DEV FILESPEC PROT DEFAULTP) (* ; "Edited 27-Aug-87 13:51 by bvm:") (* ;; "Performs the filing call that sets the protection of FILESPEC on DEV to be PROT. PROT=T means default protection. DEFAULTP = NIL means access, T means default access.") (if (EQ PROT T) then (* ; "Set to default protection. Can't do this in the obvious way, because the PROTECTION attribute hides the hair about defaulted") (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE DEFAULT.ACCESS.LIST))) else (CONSTANT (\FILING.ATTRIBUTE.TYPE (QUOTE ACCESS.LIST)))) (CONSTANT (COURIER.WRITE.REP (COURIER.CREATE (FILING . ACCESS.LIST) ENTRIES _ NIL DEFAULTED _ T) (QUOTE FILING) (QUOTE ACCESS.LIST))) DEV) else (\NSFILING.SETFILEINFO FILESPEC (if DEFAULTP then (QUOTE DEFAULT.ACCESS.LIST) else (QUOTE PROTECTION)) PROT DEV)))
)
(NSPROT.SET.MULTIPLE
(LAMBDA (WINDOW DEV FILESPEC PROT) (* ; "Edited 7-Sep-89 12:31 by bvm") (if (NSPROT.RESTORE.TYPE WINDOW) then (NSPROT.PROMPT WINDOW "(Will set Principal protection) ")) (NSPROT.PROMPT WINDOW "Enumerating...") (LET ((FILES (RESETLST (LET* ((FILING.ENUMERATION.DEPTH MAX.SMALLP) (GEN (\GENERATEFILES (DIRECTORY.FILL.PATTERN FILESPEC) (QUOTE (FILE.ID)) (QUOTE (RESETLST)))) FILE) (DECLARE (CL:SPECIAL FILING.ENUMERATION.DEPTH)) (* ; "sets depth to infinity without telling the generator to filter out directories.") (while (SETQ FILE (\GENERATENEXTFILE GEN)) collect (NSPROT.PROMPT WINDOW T "~A" (SETQ FILE (CDR (NSPROT.STRIP.HOST FILE)))) (LIST (\GENERATEFILEINFO GEN (QUOTE FILE.ID)) (\GENERATEFILEINFO GEN (QUOTE IS.DIRECTORY)) FILE)))))) (if (NULL FILES) then (NSPROT.PROMPT WINDOW "no files match the pattern.") else (NSPROT.PROMPT WINDOW T "Setting...") (for F in FILES bind (OK _ 0) (FAILED _ 0) do (* ;; "Set explicit protection for file with this id. If it's a directory, also set its default access list to defaulted.") (if (AND (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) PROT) (OR (NULL (CADR F)) (NSPROT.SET.PROTECTION.ONE DEV (BQUOTE (FILE.ID (\, (CAR F)))) T T))) then (add OK 1) else (add FAILED 1) (NSPROT.PROMPT WINDOW T "Failed on ~A" (CADDR F))) finally (NSPROT.PROMPT WINDOW T "Done, set ~A on ~D files~:[~; out of ~D~]." (if (EQ PROT T) then "default protection" else "the displayed protection") OK (NEQ FAILED 0) (+ OK FAILED))))))
)
(NSPROT.SET.TO.DEFAULT
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (DEV&FILESPEC PROT) (if (AND (MOUSECONFIRM "Click LEFT to confirm restoring the file to inherited protection" T (GETPROMPTWINDOW WINDOW)) (SETQ DEV&FILESPEC (NSPROT.PARSE.FILENAME WINDOW))) then (CL:MULTIPLE-VALUE-BIND (RESULT CONDITION) (IGNORE-ERRORS (DESTRUCTURING-BIND (DEV . FILESPEC) DEV&FILESPEC (if (AND (NSPROT.TOP.LEVELP FILESPEC) (NOT (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS))) (NEQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO)) THEN (* ; "Dangerous operation!") (NSPROT.PROMPT WINDOW "Can't set top-level directory to default protection.") ELSE (NSPROT.SET.PROTECTION WINDOW DEV FILESPEC T)))) (IF CONDITION THEN (NSPROT.PROMPT WINDOW "Failed: ~A" CONDITION))) (NSPROT.RESTORE.VERIFY WINDOW))))
)
(NSPROT.BEGIN.COMMAND
(LAMBDA (WINDOW) (* ; "Edited 20-Aug-87 17:35 by bvm:") (* ;; "Begin a new command. Clear old prompt window, if any, and stop any editing.") (LET ((PW (GETPROMPTWINDOW WINDOW NIL NIL T))) (AND PW (CLEARW PW))) (FM.ENDEDIT WINDOW) (for W in (WINDOWPROP WINDOW (QUOTE PROTMENUS)) do (FM.ENDEDIT W)) (if (EQ (GETSTREAM WINDOW) (TTYDISPLAYSTREAM)) then (* ; "Bug--freemenu leaves this guy being the ttydisplaystream") (TTYDISPLAYSTREAM \DEFAULTTTYDISPLAYSTREAM)))
)
)
(DEFINEQ
(NSPROT.HANDLE.TYPE
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 27-Aug-87 13:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) (SELECTQ (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS)) (T (SETQ LABEL "Principal") NIL) (NIL (SETQ LABEL "Children Only") T) (SHOULDNT))) LABEL))
)
(NSPROT.RESTORE.TYPE
(LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 13:56 by bvm:") (* ;; "Replace the %"children only%" state with %"Principal%"--do this when working on a non-directory. Returns T if it changed.") (if (WINDOWPROP WINDOW (QUOTE USE-DEFAULT-ACCESS) NIL) then (FM.CHANGESTATE (FM.GETITEM (QUOTE TYPE) NIL WINDOW) "Principal" WINDOW) T))
)
(NSPROT.HANDLE.VERIFY
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 24-Aug-87 14:53 by bvm:") (LET (LABEL) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) (SELECTQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) (:NEW (SETQ LABEL "All Names") T) (T (SETQ LABEL "Don't") NIL) (NIL (SETQ LABEL "I really mean it") :NO) (:NO (SETQ LABEL "New Names Only") :NEW) (SHOULDNT))) LABEL))
)
(NSPROT.RESTORE.VERIFY
(LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 15:11 by bvm:") (* ;; "Replace the %"I really mean it%" state with a better one.") (if (EQ (WINDOWPROP WINDOW (QUOTE VERIFYFLG)) :NO) then (FM.CHANGESTATE (FM.GETITEM (QUOTE CHECK) NIL WINDOW) "New Names Only" WINDOW) (WINDOWPROP WINDOW (QUOTE VERIFYFLG) :NEW)))
)
(NSPROT.PARSE.FILENAME
(LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (NSPROT.BEGIN.COMMAND WINDOW) (PROG ((STATE (FM.GETSTATE WINDOW)) HOST FILENAME FULLNAME HOST&FILE FULLHOST DEV) (for TL on STATE by (CDDR TL) do (SELECTQ (CAR TL) (HOST (SETQ HOST (CADR TL))) (DIR (SETQ FILENAME (CADR TL))) NIL)) (if (OR (NULL FILENAME) (EQ (NCHARS FILENAME) 0)) then (NSPROT.PROMPT WINDOW "No directory or file name was specified.") (RETURN NIL)) (if (SETQ HOST&FILE (NSPROT.STRIP.HOST FILENAME)) then (* ;; "User gave a full file name including host in the %"Dir/File%" field. Separate them out now.") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) (SETQ FILENAME (CDR HOST&FILE)) WINDOW) (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) (SETQ HOST (CAR HOST&FILE)) WINDOW)) (if (OR (NULL HOST) (EQ (NCHARS HOST) 0)) then (NSPROT.PROMPT WINDOW "No host was specified.") (RETURN NIL)) (SETQ FULLHOST (CAR (LOOKUP.NS.SERVER HOST NIL T))) (if (NOT (STRING-EQUAL HOST (SETQ HOST (NSNAME.TO.STRING (OR FULLHOST (PARSE.NSNAME HOST)) T)))) then (* ;; "Show fully-qualified name, either from lookup or from parse. In latter case, we may be reminding user of default domain.") (FM.CHANGELABEL (FM.GETITEM (QUOTE HOST) NIL WINDOW) HOST WINDOW)) (if (NEQ (CHCON1 FILENAME) (CHARCODE "<")) then (SETQ FILENAME (CONCAT "<" FILENAME)) (if (NOT (STRPOS ">" FILENAME 2)) then (SETQ FILENAME (CONCAT FILENAME ">"))) (* ; "Show modified file name") (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) FILENAME WINDOW)) (if (OR (NOT FULLHOST) (NULL (SETQ DEV (\GETDEVICEFROMNAME (SETQ FULLNAME (CONCAT "{" HOST "}" FILENAME)) T)))) then (NSPROT.PROMPT WINDOW "Server ~A not found." HOST) (RETURN NIL)) (RETURN (CONS DEV FULLNAME))))
)
(NSPROT.PARSE.PROTECTIONS
(LAMBDA (WINDOW) (* ; "Edited 27-Aug-87 14:45 by bvm:") (* ;; "Parse and as necessary validate the protection entries attached to WINDOW, returning a valid PROTECTION value, or NIL if something is wrong.") (LET ((PROTWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS))) (VERIFYFLG (WINDOWPROP WINDOW (QUOTE VERIFYFLG))) WHO HOW NSWHO OLDWHO FULLNAME DEADWINDOWS PROT VERIFIEDNAME) (for W in PROTWINDOWS do (SETQ WHO NIL) (SETQ HOW (for TAIL on (FM.GETSTATE W) by (CDDR TAIL) when (SELECTQ (CAR TAIL) ((READ WRITE ADD REMOVE OWNER) (CADR TAIL)) (NAME (SETQ WHO (CADR TAIL)) NIL) NIL) collect (CAR TAIL))) (if (NOT (AND HOW WHO (> (NCHARS WHO) 0))) then (* ; "No protection, remove this guy") (push DEADWINDOWS W) elseif (AND (NEQ VERIFYFLG T) (STREQUAL WHO (CAR (SETQ OLDWHO (WINDOWPROP W (QUOTE KNOWN-VALUE)))))) then (* ;; "This name hasn't been changed since we put it up, so use the parse that's there. We're assuming that not having to validate old protection names makes up for occasionally reinstalling a bogus name that just happened to be there.") (push PROT (LIST (CADR OLDWHO) HOW)) else (SETQ NSWHO (PARSE.NSNAME WHO)) (if (NOT (STREQUAL WHO (SETQ WHO (NSNAME.TO.STRING (OR (SETQ FULLNAME (if (SELECTQ VERIFYFLG ((NIL :NO) T) (STRPOS "*" WHO)) then (* ; "for now, accept any pattern") NSWHO else (* ; "get canonical name") (SETQ VERIFIEDNAME (CH.LOOKUP.OBJECT NSWHO)))) NSWHO) T)))) then (* ; "Show our parse or canonical name") (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL W) WHO W)) (if FULLNAME then (* ; "good name") (SETQ NSWHO FULLNAME) (if VERIFIEDNAME then (* ; "Remember this parse") (WINDOWPROP W (QUOTE KNOWN-VALUE) (LIST WHO VERIFIEDNAME HOW))) else (NSPROT.PROMPT WINDOW "~A not a registered name." WHO) (RETURN NIL)) (push PROT (LIST NSWHO HOW))) finally (if DEADWINDOWS then (* ; "Remove the windows showing no entry") (LET ((LASTDEAD (CAR DEADWINDOWS)) LOWERWINDOWS) (* ; "First detach everything up to the last dead one.") (for OLDW in PROTWINDOWS do (DETACHWINDOW OLDW) (if (MEMB OLDW DEADWINDOWS) then (CLOSEW OLDW) else (push LOWERWINDOWS OLDW)) repeatuntil (EQ OLDW LASTDEAD)) (* ; "Now reattach the good ones") (for OLDW in LOWERWINDOWS do (ATTACHWINDOW OLDW WINDOW (QUOTE BOTTOM))) (* ; "Add the dead ones to scratch heap") (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND DEADWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS)))) (WINDOWPROP WINDOW (QUOTE PROTMENUS) (CL:SET-DIFFERENCE PROTWINDOWS DEADWINDOWS)))) (RETURN (LIST PROT)))))
)
(NSPROT.STRIP.HOST
(LAMBDA (FILENAME) (* ; "Edited 20-Aug-87 14:17 by bvm:") (* ;; "Strips the host field off the front of FILENAME and returns a dotted pair (host . restOfName).") (PROG (I) (RETURN (AND (SETQ I (STRPOS (SELCHARQ (CHCON1 FILENAME) ({ "}") ("[" "]") ("(" ")") (RETURN NIL)) FILENAME 2)) (CONS (SUBSTRING FILENAME 2 (SUB1 I)) (SUBSTRING FILENAME (ADD1 I)))))))
)
(NSPROT.EXPAND.FULLNAME
(LAMBDA (WINDOW DEV FILENAME) (* ; "Edited 27-Aug-87 15:19 by bvm:") (* ;; "Looks up FILENAME on DEV, returning the full name (sans host). WINDOW is the window in which FILENAME is the DIR item--we will change it if appropriate. Returns NIL on file not found.") (LET ((FULLNAME (\NSFILING.GETFILE DEV FILENAME (QUOTE NONE) (QUOTE OLD) (QUOTE HANDLE) (FUNCTION \NSFILING.FULLNAME) T)) STRIPPED-NAME) (if (NULL FULLNAME) then (NSPROT.PROMPT WINDOW "~A not found." (if (NSPROT.DIRECTORY.SYNTAXP FILENAME) then "Directory" elseif (STRPOS ">" FILENAME) then (* ; "Looks like a file") "File" else (* ; "Could be either if they were sloppy") "Directory/file")) NIL else (SETQ STRIPPED-NAME (CDR (NSPROT.STRIP.HOST FULLNAME))) (if (NOT (STREQUAL STRIPPED-NAME FILENAME)) then (FM.CHANGELABEL (FM.GETITEM (QUOTE DIR) NIL WINDOW) STRIPPED-NAME WINDOW)) (if (NOT (NSPROT.DIRECTORY.SYNTAXP FULLNAME)) then (* ; "Force Principal protection, since non-directories don't have a default access list.") (NSPROT.RESTORE.TYPE WINDOW)) FULLNAME)))
)
)
(* ; "Handle protection submenus")
(DEFINEQ
(NSPROT.GET.SUBMENU
(LAMBDA (MAINWINDOW) (* ; "Edited 26-Aug-87 18:03 by bvm:") (LET ((SUBW (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS))) HEIGHT) (if SUBW then (* ; "Return a cached window to avoid overhead of creating a whole new freemenu. Don't forget to clear the old one out!") (PROG1 (NSPROT.CHANGE.STATE (CAR SUBW) NIL) (WINDOWPROP MAINWINDOW (QUOTE SCRATCHMENUS) (CDR SUBW))) else (SETQ SUBW (FREEMENU (BQUOTE ((PROPS FONT (\, (NSPROT.GET.FONT)) COLUMNSPACE 5) ((LABEL "Read" ID READ TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Read: User may read (if a file) or enumerate (if a directory)") (LABEL "Wrt" ID WRITE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Write: User may write/change/delete the file.") (LABEL "Add" ID ADD TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Add: User can create files in the directory.") (LABEL "Del" ID REMOVE TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Delete: User can remove files from the directory.") (LABEL "Own" ID OWNER TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.SUBTYPE MESSAGE "Owner: User can change the protection.") (LABEL "All" ID ALL TYPE TOGGLE SELECTEDFN NSPROT.HANDLE.ALL MESSAGE NSPROT.MESSAGE.ALL) (LABEL " to:" ID TO TYPE EDITSTART MESSAGE "Fill in name (user or group) or pattern (*:Domain)." FONT (\, (NSPROT.GET.FONT T)) LINKS (EDIT NAME)) (LABEL (\, (CONCAT)) TYPE EDIT ID NAME)))) NIL NIL 3)) (WINDOWPROP SUBW (QUOTE FM.DONTRESHAPE) T) (* ; "Don't want any extra space added between columns when the window gets wider--add it all on the right.") (WINDOWPROP SUBW (QUOTE MINSIZE) (CONS 0 (SETQ HEIGHT (fetch (REGION HEIGHT) of (WINDOWPROP SUBW (QUOTE REGION)))))) (WINDOWPROP SUBW (QUOTE MAXSIZE) (CONS MAX.SMALLP HEIGHT)) (WINDOWPROP SUBW (QUOTE FM.PROMPTWINDOW) (GETPROMPTWINDOW MAINWINDOW)) SUBW)))
)
(NSPROT.ADD.SUBMENU
(LAMBDA (MENUW MAINWINDOW) (* ; "Edited 20-Aug-87 10:13 by bvm:") (* ;; "Appends MENUW to MAINWINDOW's set of protection value entries") (ATTACHWINDOW MENUW MAINWINDOW (QUOTE BOTTOM)) (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS) (CONS MENUW (WINDOWPROP MAINWINDOW (QUOTE PROTMENUS)))))
)
(NSPROT.REMOVE.SUBMENUS
(LAMBDA (WINDOW) (* ; "Edited 24-Aug-87 12:34 by bvm:") (* ;; "Removes all the submenus (protection entries) from WINDOW, adding them to the scratch list for the window.") (LET ((OLDWINDOWS (WINDOWPROP WINDOW (QUOTE PROTMENUS) NIL))) (for W in OLDWINDOWS do (DETACHWINDOW W) (CLOSEW W)) (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS) (APPEND OLDWINDOWS (WINDOWPROP WINDOW (QUOTE SCRATCHMENUS))))))
)
(NSPROT.CHANGE.STATE
(LAMBDA (WINDOW NEWSTATE) (* ; "Edited 19-Aug-87 16:15 by bvm:") (* ;; "Change all the protection buttons to the specified state") (for ID in (QUOTE (READ WRITE ADD REMOVE OWNER ALL)) do (FM.CHANGESTATE (FM.GETITEM ID NIL WINDOW) NEWSTATE WINDOW)) WINDOW)
)
(NSPROT.HANDLE.ALL
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 16:16 by bvm:") (* ;; "Called when ALL is selected--turn all protection bits to the specified state") (NSPROT.CHANGE.STATE WINDOW (FM.ITEMPROP ITEM (QUOTE STATE))))
)
(NSPROT.MESSAGE.ALL
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 20-Aug-87 14:15 by bvm:") (* ;; "Called when ALL is held--return appropriate help message") (if (FM.ITEMPROP ITEM (QUOTE STATE)) then "Deny user all access rights" else "Grant user all 5 access rights"))
)
(NSPROT.HANDLE.SUBTYPE
(LAMBDA (ITEM WINDOW BUTTONS) (* ; "Edited 19-Aug-87 14:46 by bvm:") (LET ((OTHER (FM.GETITEM (QUOTE ALL) NIL WINDOW))) (if (FM.ITEMPROP OTHER (QUOTE STATE)) then (* ; "If the ALL button was on, turn it off") (FM.CHANGESTATE OTHER NIL WINDOW)) (SELECTQ (FM.ITEMPROP ITEM (QUOTE ID)) ((WRITE ADD) (* ; "these accesses really need READ as well") (if (AND (FM.ITEMPROP ITEM (QUOTE STATE)) (NOT (FM.ITEMPROP (SETQ OTHER (FM.GETITEM (QUOTE READ) NIL WINDOW)) (QUOTE STATE)))) then (FM.CHANGESTATE OTHER T WINDOW))) NIL)))
)
(NSPROT.SHOW.PROT.VALUE
(LAMBDA (ENTRY MAINWINDOW) (* ; "Edited 24-Aug-87 16:16 by bvm:") (DESTRUCTURING-BIND (NAME TYPES) ENTRY (LET ((SUBW (NSPROT.GET.SUBMENU MAINWINDOW)) (STRINGNAME (NSNAME.TO.STRING NAME T)) ITEM) (for P in TYPES do (FM.CHANGESTATE (OR (SETQ ITEM (FM.GETITEM P NIL SUBW)) (HELP "Bad protection value" P)) T SUBW) (if (EQ P (QUOTE ALL)) then (NSPROT.HANDLE.ALL ITEM SUBW))) (FM.CHANGELABEL (FM.GETITEM (QUOTE NAME) NIL SUBW) STRINGNAME SUBW) (WINDOWPROP SUBW (QUOTE KNOWN-VALUE) (CONS STRINGNAME ENTRY)) (* ; "Save the parse of this value so we can avoid worrying about it later.") (NSPROT.ADD.SUBMENU SUBW MAINWINDOW) SUBW)))
)
)
(* ; "utilities")
(DEFINEQ
(NSPROT.DIRECTORY.SYNTAXP
(LAMBDA (FILENAME) (* ; "Edited 27-Aug-87 14:53 by bvm:") (* ; "True if FILENAME looks like a directory") (EQ (NTHCHARCODE FILENAME -1) (CHARCODE ">")))
)
(NSPROT.TOP.LEVELP
(LAMBDA (FILESPEC) (* ; "Edited 20-Nov-87 12:26 by bvm:") (LET (I) (NOT (AND (SETQ I (STRPOS ">" FILESPEC)) (NEQ I (NCHARS FILESPEC))))))
)
(NSPROT.GET.FONT
(LAMBDA (BOLDP) (* ; "Edited 1-Sep-87 17:23 by bvm:") (if BOLDP then (OR NSPROT.BOLD.FONT (SETQ NSPROT.BOLD.FONT (FONTCOPY (NSPROT.GET.FONT) (QUOTE WEIGHT) (QUOTE BOLD)))) elseif NSPROT.PLAIN.FONT elseif (> (FONTHEIGHT (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 10))) 12) then (* ; "Yes, this is the one I had in mind (10 pt coerced to 12)") NSPROT.PLAIN.FONT else (* ; "The %"real%" 12 pt display font is about the right size.") (SETQ NSPROT.PLAIN.FONT (FONTCREATE (QUOTE MODERN) 12))))
)
(NSPROT.PROMPT
(LAMBDA WINDOW&ARGS (* ; "Edited 2-Aug-89 17:10 by bvm") (LET* ((*PRINT-CASE* :UPCASE) (MAINW (ARG WINDOW&ARGS 1)) (WINDOW (GETPROMPTWINDOW MAINW)) (ARGS (for J from (if (EQ (ARG WINDOW&ARGS 2) T) then (* ; "First arg of T means clear window first.") (NSPROT.CLEAR.PROMPT MAINW WINDOW) 3 else 2) to WINDOW&ARGS collect (ARG WINDOW&ARGS J)))) (RESETFORM (TTYDISPLAYSTREAM WINDOW) (* ; "Unfortunately, have to make it the tty to get pagefullfn action.") (CL:APPLY (FUNCTION CL:FORMAT) WINDOW ARGS)) NIL))
)
(NSPROT.CLEAR.PROMPT
(LAMBDA (MAINW PW) (* ; "Edited 2-Aug-89 17:14 by bvm") (* ;; "Clear's FOLDER's prompt window, and shrinks it back to a single line if it has grown") (LET ((PROP (WINDOWPROP MAINW (QUOTE PROMPTWINDOW))) (IDEALHEIGHT (OR (WINDOWPROP MAINW (QUOTE PROMPTLINES)) 1)) HEIGHT) (* ;; "PROP = (promptwindow . #lines)") (if (AND PROP (> (CDR PROP) IDEALHEIGHT)) then (* ; "Window has grown, so shape it back down") (SETQ HEIGHT (HEIGHTIFWINDOW (TIMES IDEALHEIGHT (FONTPROP PW (QUOTE HEIGHT))))) (WINDOWPROP PW (QUOTE MINSIZE) (CONS 0 HEIGHT)) (* ; "have to adjust the fixed size of the window before shaping, since SHAPEW obeys the minimum.") (WINDOWPROP PW (QUOTE MAXSIZE) (CONS 64000 HEIGHT)) (SHAPEW PW (create REGION using (WINDOWPROP PW (QUOTE REGION)) HEIGHT _ HEIGHT)) (RPLACD PROP IDEALHEIGHT) (* ; "Clear it last to get coordinates right.")) (CLEARW PW)))
)
(NSPROT.LIMITCHARS
[LAMBDA (ITEM WINDOW CHAR) (* ; "Edited 21-Apr-2021 11:55 by rmk:")
(* ;; "RMK: Got rid of literal %%<CR> in favor of CHARCODE CR, for switch to default LF EOL convention. But compiled file may end up with LF")
(SELECTC CHAR
((LIST (CHARACTER (CHARCODE CR))
'Â)
(FM.SKIPNEXT WINDOW)
NIL)
T])
(NSPROT.PAGEFULLFN
(LAMBDA (PW) (* ; "Edited 2-Aug-89 16:19 by bvm") (* ;; "PAGEFULLFN for prompt window--makes the window a line bigger and allows output to proceed") (SETQ \CURRENTDISPLAYLINE (PROG1 \#DISPLAYLINES (GETPROMPTWINDOW (MAINWINDOW PW) (+ 1 \#DISPLAYLINES)) (* ; "\Currentdisplayline is the line we're on when window fills, origin zero"))))
)
(NSPROT.ICONFN
(LAMBDA (WINDOW OLDICON) (* ; "Edited 1-Sep-87 10:29 by bvm:") (LET ((HOST (FM.ITEMPROP (FM.GETITEM (QUOTE HOST) NIL WINDOW) (QUOTE LABEL)))) (SETQ HOST (if (AND HOST (NEQ (NCHARS HOST) 0) (SETQ HOST (PARSE.NSNAME HOST))) then (fetch NSOBJECT of HOST) else "")) (* ; "show host's main name") (if OLDICON then (ICONW.TITLE OLDICON HOST) OLDICON else (TITLEDICONW NSPROT.ICON HOST (NSPROT.GET.FONT)))))
)
)
(RPAQ? NSPROT.PLAIN.FONT NIL)
(RPAQ? NSPROT.BOLD.FONT NIL)
(RPAQQ NSPROT.ICON (#*(80 40)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@AN@@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@CL@O@CL@@@@@@@@@@@@@GH@G@CL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@GH@GHCL@@@@@@@@@@@@@O@@CHCL@@@@@@@@@@@@@O@@CHCLAOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLCOOOOOOOOOOOOO@@CHCLAOOOOOOOOOOOOO@@CHCL@GNGNGN@@@@@@O@@CHCL@GNGNGN@@@@@@O@@CHCL@GNFFGN@@@@@@GH@GHCL@FFFFGN@@@@@@GH@GHCL@FF@@GN@@@@@@GH@G@CL@@@@@FF@@@@@@CL@O@CL@@@@@FF@@@@@@CL@O@CL@@@@@@@@@@@@@ANAN@CL@@@@@@@@@@@@@AOCN@CL@@@@@@@@@@@@@@OOL@CL@@@@@@@@@@@@@@GOH@CL@@@@@@@@@@@@@@CO@@CL@@@@@@@@@@@@@@@L@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@CL@@@@@@@@@@@@@@@@@@COOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO
NIL
(4 22 51 14)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS NSPROT.PLAIN.FONT NSPROT.BOLD.FONT \NSFILING.ATTRIBUTES NSPROT.ICON
\DEFAULTTTYDISPLAYSTREAM)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(AND (EQ MAKESYSNAME :LYRIC)
(FILESLOAD (SYSLOAD)
NSRANDOM))
)
(DEFINEQ
(ADD.NSPROTECTION
(LAMBDA (LST) (* ; "Edited 2-Sep-87 11:53 by bvm:") (* ;; "Add an entry for the NSPROTECTION tool to the background menu") (for X in (if LST then (* ; "Mumbling thru sub items") (CDR LST) else (SETQ LST BackgroundMenuCommands)) bind (COM _ (QUOTE ("NS Protection" (QUOTE (NSPROTECTION)) "Start up the NS File protection tool."))) do (if (STRING-EQUAL (CAR X) "NS Protection") then (RETURN (RPLACD X (CDR COM))) elseif (AND (STRING-EQUAL (CAR X) "System") (CADDDR X)) then (RETURN (ADD.NSPROTECTION (CADDDR X)))) finally (NCONC1 LST COM)) (SETQ BackgroundMenu NIL) (* ; "also, load fonts") (NSPROT.GET.FONT T) (COND ((CCODEP (QUOTE ADD.NSPROTECTION)) (* ; "self destruct") (AND (PUTD (QUOTE ADD.NSPROTECTION))))))
)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(ADD.NSPROTECTION)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS NSPROTECTION COPYRIGHT ("Xerox Corporation" 1987 1989 2021))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2525 14996 (NSPROTECTION 2535 . 5721) (NSPROT.SHOW 5723 . 6241) (
NSPROT.FETCH.PROTECTION 6243 . 9177) (NSPROT.NEW.ENTRY 9179 . 9802) (NSPROT.APPLY 9804 . 10733) (
NSPROT.SET.PROTECTION 10735 . 11311) (NSPROT.SET.PROTECTION.ONE 11313 . 12189) (NSPROT.SET.MULTIPLE
12191 . 13690) (NSPROT.SET.TO.DEFAULT 13692 . 14504) (NSPROT.BEGIN.COMMAND 14506 . 14994)) (14997
22029 (NSPROT.HANDLE.TYPE 15007 . 15307) (NSPROT.RESTORE.TYPE 15309 . 15660) (NSPROT.HANDLE.VERIFY
15662 . 16022) (NSPROT.RESTORE.VERIFY 16024 . 16355) (NSPROT.PARSE.FILENAME 16357 . 18086) (
NSPROT.PARSE.PROTECTIONS 18088 . 20583) (NSPROT.STRIP.HOST 20585 . 20966) (NSPROT.EXPAND.FULLNAME
20968 . 22027)) (22073 26624 (NSPROT.GET.SUBMENU 22083 . 23887) (NSPROT.ADD.SUBMENU 23889 . 24196) (
NSPROT.REMOVE.SUBMENUS 24198 . 24618) (NSPROT.CHANGE.STATE 24620 . 24902) (NSPROT.HANDLE.ALL 24904 .
25146) (NSPROT.MESSAGE.ALL 25148 . 25420) (NSPROT.HANDLE.SUBTYPE 25422 . 25967) (
NSPROT.SHOW.PROT.VALUE 25969 . 26622)) (26651 30154 (NSPROT.DIRECTORY.SYNTAXP 26661 . 26845) (
NSPROT.TOP.LEVELP 26847 . 27009) (NSPROT.GET.FONT 27011 . 27530) (NSPROT.PROMPT 27532 . 28056) (
NSPROT.CLEAR.PROMPT 28058 . 28941) (NSPROT.LIMITCHARS 28943 . 29366) (NSPROT.PAGEFULLFN 29368 . 29728)
(NSPROT.ICONFN 29730 . 30152)) (31446 32195 (ADD.NSPROTECTION 31456 . 32193)))))
STOP

BIN
lispusers/NSPROTECTION.LCOM
View File

Binary file not shown.

BIN
lispusers/NSPROTECTION.TEDIT
View File

Binary file not shown.

19
lispusers/NSREADERPATCH
View File

@@ -1,19 +0,0 @@
(FILECREATED "18-Jun-86 16:14:22" {ERIS}<LISPUSERS>LISPCORE>NSREADERPATCH.;1 577
changes to: (VARS NSREADERPATCHCOMS))
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT NSREADERPATCHCOMS)
(RPAQQ NSREADERPATCHCOMS [(ADDVARS (FILEINFOTYPES (READER 11))
(\LISP.TO.NSFILING.ATTRIBUTES (READER READ.BY])
(ADDTOVAR FILEINFOTYPES (READER 11))
(ADDTOVAR \LISP.TO.NSFILING.ATTRIBUTES (READER READ.BY))
(PUTPROPS NSREADERPATCH COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL)))
STOP

206
lispusers/NSROUTINGHASH
View File

@@ -1,206 +0,0 @@
(FILECREATED " 7-Feb-89 23:16:44" {ERINYES}<LISPUSERS>KOTO>NSROUTINGHASH.;2 13641
changes to: (RECORDS NSROUTINGINFO) (VARS NSROUTINGHASHCOMS)
previous date: "11-Jan-88 21:27:31" {ERINYES}<LISPUSERS>KOTO>NSROUTINGHASH.;1)
(* Copyright (c) 1987, 1988, 1989 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT NSROUTINGHASHCOMS)
(RPAQQ NSROUTINGHASHCOMS ((FNS \AGE.ROUTING.TABLE.HASH \HANDLE.NS.ROUTING.INFO.NEW
\HANDLE.RAW.XIP.NEW \LOCATE.NSNET.NEW \FLUSHNDBS.NEW \MAP.ROUTING.TABLE.NEW \NSGATELISTENER.NEW
\NSROUTING.HASHBITSFN \NSROUTING.EQUIVFN PRINTROUTINGTABLE) (GLOBALVARS \NS.ROUTING.TABLE) (* *
LOADCOMP LLNS *before* loading this module so that this record declaration is in effect) (RECORDS
NSROUTINGINFO) (FNS INSTALL UNINSTALL) (* installation utilities) (COMS (* debugging tools) (FNS
ROUTINGPROBE)) (DECLARE: DONTEVAL@LOAD DOCOPY (P (UNINTERRUPTABLY (INSTALL (QUOTE \FLUSHNDBS)) (
INSTALL (QUOTE \MAP.ROUTING.TABLE)) (INSTALL (QUOTE \HANDLE.NS.ROUTING.INFO)) (INSTALL (QUOTE
\LOCATE.NSNET)) (INSTALL (QUOTE \HANDLE.RAW.XIP)) (INSTALL (QUOTE \NSGATELISTENER)) (RESTART.ETHER) (
\LOCATE.NSNET -1))))))
(DEFINEQ
(\AGE.ROUTING.TABLE.HASH
(LAMBDA (TABLE) (* ; "Edited 21-Jun-87 23:23 by BRIGGS") (MAPHASH TABLE (FUNCTION (LAMBDA (ENTRY KEY)
(if (if (AND (NEQ (fetch RTHOPCOUNT of ENTRY) 0) (TIMEREXPIRED? (fetch RTTIMER of ENTRY))) then (COND
((fetch RTRECENT of ENTRY) (* New entry, make it old) (replace RTRECENT of ENTRY with NIL) (SETUPTIMER
\RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY)) NIL) (T \RT.PURGEFLG))) then (PUTHASH KEY NIL TABLE))))
)))
(\HANDLE.NS.ROUTING.INFO.NEW
(LAMBDA (XIP) (* edited: "11-Jan-88 20:48") (* ; "Edited 21-Jun-87 23:11 by BRIGGS") (* Processes a
routing info XIP) (COND ((EQ (fetch XIPFIRSTDATAWORD of XIP) \XROUTINGINFO.OP.RESPONSE) (* Unless
we're a gateway, we only handle responses) (PROG ((HOST (fetch XIPSOURCEHOST of XIP)) (NDB (fetch
EPNETWORK of XIP)) (LENGTH (SUB1 (FOLDLO (IDIFFERENCE (fetch XIPLENGTH of XIP) \XIPOVLEN) BYTESPERWORD
))) (BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) ENTRY NET HOPS NETHASH) (COND ((NEQ (fetch NETTYPE
of NDB) 10) (OR (SETQ HOST (\TRANSLATE.10TO3 HOST NDB)) (RETURN)))) (SETQ \NSROUTER.PROBECOUNT 0) (
while (IGEQ LENGTH \NS.ROUTINGINFO.WORDS) do (SETQ HOPS (fetch (NSROUTINGINFO #HOPS) of BASE)) (COND (
(OR (SETQ ENTRY (GETHASH BASE \NS.ROUTING.TABLE)) (COND ((ILEQ HOPS \NS.ROUTING.TABLE.RADIUS) (SETQ
NET (fetch (NSROUTINGINFO NET#) of BASE)) (PUTHASH NET (SETQ ENTRY (create ROUTING RTNET# _ NET
RTTIMER _ (SETUPTIMER 0))) \NS.ROUTING.TABLE) T))) (* Update the entry if this entry not for directly
connected net and - current entry timed out, or - new gateway same as old, or - new route has fewer
hops than old) (COND ((AND (NEQ (fetch RTHOPCOUNT of ENTRY) 0) (OR (NOT (fetch RTRECENT of ENTRY)) (
AND (EQUAL HOST (fetch RTGATEWAY# of ENTRY)) (EQ NDB (fetch RTNDB of ENTRY))) (ILESSP HOPS (fetch
RTHOPCOUNT of ENTRY)))) (replace RTGATEWAY# of ENTRY with HOST) (replace RTNDB of ENTRY with NDB) (
replace RTHOPCOUNT of ENTRY with HOPS) (COND ((ILESSP HOPS \RT.INFINITY) (replace RTRECENT of ENTRY
with T) (SETUPTIMER \RT.TIMEOUTINTERVAL (fetch RTTIMER of ENTRY)))))))) (SETQ LENGTH (IDIFFERENCE
LENGTH \NS.ROUTINGINFO.WORDS)) (SETQ BASE (\ADDBASE BASE \NS.ROUTINGINFO.WORDS)))))) (
\RELEASE.ETHERPACKET XIP)))
(\HANDLE.RAW.XIP.NEW
(LAMBDA (XIP TYPE) (* edited: "11-Jan-88 20:47") (* N.H.Briggs "21-Jun-87 23:53") (* Handles the
arrival of a raw XIP. If it is destined for a local socket that has room for it, we queue it up, else
release it) (COND ((EQ TYPE \EPT.XIP) (PROG (NSOC CSUM NDB DESTNET MYNET) (COND ((NULL \NS.READY) (
RETURN (RELEASE.XIP XIP)))) (COND ((AND (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP)
\MY.NSHOSTNUMBER)) (NOT (EQNSHOSTNUMBER (fetch XIPDESTHOST of XIP) BROADCASTNSHOSTNUMBER))) (* Not for
us) (RETURN (\FORWARD.XIP XIP)))) (SETQ NDB (fetch EPNETWORK of XIP)) (COND ((AND (NOT (IEQP (SETQ
DESTNET (fetch XIPDESTNET of XIP)) (SETQ MYNET (fetch NDBNSNET# of NDB)))) (NEQ MYNET 0) (NEQ DESTNET
0)) (* explicitly for a net other than us) (RETURN (\FORWARD.XIP XIP)))) (COND ((NULL (SETQ NSOC (
\NSOCKET.FROM# (fetch XIPDESTSOCKET of XIP)))) (* Packets addressed to non-active sockets are just
ignored.) (COND (XIPTRACEFLG (PRIN1 (QUOTE '&) XIPTRACEFILE))) (PROG (XIPBASE) (COND ((AND (EQ (fetch
XIPTYPE of XIP) \XIPT.ECHO) (EQ (fetch XIPDESTSOCKET of XIP) \NS.WKS.Echo) (EQ (\GETBASE (SETQ XIPBASE
(fetch XIPCONTENTS of XIP)) 0) \XECHO.OP.REQUEST)) (* Play echo server) (COND ((AND (NEQ (SETQ CSUM (
fetch XIPCHECKSUM of XIP)) MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 (
FOLDHI (fetch XIPLENGTH of XIP) BYTESPERWORD))))) (\XIPERROR XIP \XIPE.CHECKSUM)) (T (\PUTBASE XIPBASE
0 \XECHO.OP.REPLY) (SWAPXIPADDRESSES XIP) (replace EPREQUEUE of XIP with (QUOTE FREE)) (SENDXIP NIL
XIP)))) (T (\XIPERROR XIP \XIPE.NOSOCKET))))) ((IGEQ (fetch (NSOCKET INQUEUELENGTH) of NSOC) (fetch (
NSOCKET NSOC#ALLOCATION) of NSOC)) (* Note that packets are just "dropped" when the queue overflows.)
(\XIPERROR XIP \XIPE.SOCKETFULL)) ((AND \NS.CHECKSUMFLG (NEQ (SETQ CSUM (fetch XIPCHECKSUM of XIP))
MASKWORD1'S) (NEQ CSUM (\CHECKSUM (fetch XIPCHECKSUMBASE of XIP) (SUB1 (FOLDHI (fetch XIPLENGTH of XIP
) BYTESPERWORD))))) (\XIPERROR XIP \XIPE.CHECKSUM)) (T (COND ((EQ DESTNET 0) (* Fill in unspecified
destination net (possibly redundantly with zero)) (replace XIPDESTNET of XIP with MYNET)) ((EQ MYNET 0
) (* Packet of specific destination net has arrived on a socket that we listen to. If we don't know
our own net number, assume sender is telling the truth) (replace NDBNSNET# of NDB with DESTNET) (
replace NSNET of \MY.NSADDRESS with (SETQ \MY.NSNETNUMBER DESTNET)) (PROG ((ENTRY (\LOCATE.NSNET
DESTNET T))) (OR ENTRY (PUTHASH DESTNET (SETQ ENTRY (create ROUTING RTNET# _ DESTNET))
\NS.ROUTING.TABLE)) (replace RTHOPCOUNT of ENTRY with 0) (replace RTGATEWAY# of ENTRY with NIL) (
replace RTNDB of ENTRY with NDB) (replace RTRECENT of ENTRY with T)))) (UNINTERRUPTABLY (\ENQUEUE (
fetch (NSOCKET INQUEUE) of NSOC) XIP) (add (fetch (NSOCKET INQUEUELENGTH) of NSOC) 1) (NOTIFY.EVENT (
fetch NSOCEVENT of NSOC)))))) T))))
(\LOCATE.NSNET.NEW
(LAMBDA (NET DONTPROBE) (* edited: "11-Jan-88 20:49") (* N.H.Briggs "21-Jun-87 23:54") (LET ((DATA (
GETHASH NET \NS.ROUTING.TABLE))) (if DATA then (AND (ILESSP (fetch RTHOPCOUNT of DATA) \RT.INFINITY)
DATA) elseif (NOT DONTPROBE) then (PUTHASH NET (create ROUTING RTNET# _ NET RTHOPCOUNT _ \RT.INFINITY
RTTIMER _ (SETUPTIMER 30000)) \NS.ROUTING.TABLE) (* Insert an entry for the net, to be purged in 30
sec if router process hasn't filled it by then) (SETQ \NSROUTER.PROBECOUNT 5) (SETQ
\NSROUTER.PROBETIMER (SETUPTIMER 0 \NSROUTER.PROBETIMER)) (WAKE.PROCESS (QUOTE \NSGATELISTENER)) (
BLOCK) (* ;; "return NIL in this case to indicate we didn't find it yet.") NIL))))
(\FLUSHNDBS.NEW
(LAMBDA (EVENT) (* edited: "11-Jan-88 21:20") (* bvm: " 4-AUG-83 22:51") (bind NDB QUEUE while (SETQ
NDB \LOCALNDBS) do (SETQ \LOCALNDBS (fetch NDBNEXT of NDB)) (replace NDBNEXT of NDB with NIL) (COND ((
EQ EVENT (QUOTE RESTART)) (APPLY* (fetch NDBETHERFLUSHER of NDB) NDB))) (DEL.PROCESS (fetch NDBWATCHER
of NDB)) (replace NDBWATCHER of NDB with (replace NDBTRANSLATIONS of NDB with NIL)) (COND ((SETQ
QUEUE (fetch NDBTQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT (QUOTE OUTPUT)) (* Don't do this just yet,
because of possible race in \PUPGATELISTENER - (replace NDBTQ of NDB with NIL)))) (COND ((SETQ QUEUE (
fetch NDBIQ of NDB)) (\FLUSH.NDB.QUEUE QUEUE EVENT (QUOTE INPUT)) (replace NDBIQ of NDB with NIL)))) (
SETQ \PUP.ROUTING.TABLE (CONS)) (SETQ \NS.ROUTING.TABLE (HASHARRAY 100 50 (FUNCTION
\NSROUTING.HASHBITSFN) (FUNCTION \NSROUTING.EQUIVFN)))))
(\MAP.ROUTING.TABLE.NEW
(LAMBDA (TABLE MAPFN) (* edited: "11-Jan-88 20:53") (* bvm: "22-SEP-83 14:21") (if (HARRAYP TABLE)
then (MAPHASH TABLE MAPFN) else (for ENTRY in (APPEND (CDR (OR TABLE \PUP.ROUTING.TABLE))) do (APPLY*
MAPFN ENTRY)))))
(\NSGATELISTENER.NEW
(LAMBDA NIL (* edited: "11-Jan-88 20:47") (* ; "Edited 16-Jun-87 15:32 by BRIGGS") (PROG ((NSOC (
OPENNSOCKET \NS.WKS.RoutingInformation T)) (TIMER (SETUPTIMER 0)) EVENT XIP BASE) (SETQ EVENT (fetch
NSOCEVENT of NSOC)) LP (COND ((SETQ XIP (GETXIP NSOC)) (\HANDLE.NS.ROUTING.INFO XIP) (BLOCK)) ((EQ (
AWAIT.EVENT EVENT (COND ((IGREATERP \NSROUTER.PROBECOUNT 0) \NSROUTER.PROBETIMER) (T TIMER)) T) EVENT)
(GO LP))) (COND ((TIMEREXPIRED? TIMER) (\AGE.ROUTING.TABLE.HASH \NS.ROUTING.TABLE) (SETUPTIMER
\RT.AGEINTERVAL TIMER))) (COND ((AND (IGREATERP \NSROUTER.PROBECOUNT 0) (TIMEREXPIRED?
\NSROUTER.PROBETIMER)) (* Routing info desired. Broadcast a routing request on each directly-connected
net) (SETQ XIP (\FILLINXIP \XIPT.ROUTINGINFO NSOC BROADCASTNSHOSTNUMBER \NS.WKS.RoutingInformation 0
(IPLUS \XIPOVLEN BYTESPERWORD (UNFOLD \NS.ROUTINGINFO.WORDS BYTESPERWORD)))) (replace XIPFIRSTDATAWORD
of XIP with \XROUTINGINFO.OP.REQUEST) (SETQ BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (replace (
NSROUTINGINFO NET#) of BASE with -1) (replace (NSROUTINGINFO #HOPS) of BASE with \RT.INFINITY) (
SENDXIP NSOC XIP) (SETUPTIMER \NSROUTER.PROBEINTERVAL \NSROUTER.PROBETIMER) (SETQ \NSROUTER.PROBECOUNT
(SUB1 \NSROUTER.PROBECOUNT)))) (GO LP))))
(\NSROUTING.HASHBITSFN
(LAMBDA (OBJECT) (* ; "Edited 21-Jun-87 23:08 by BRIGGS") (SELECTQ (TYPENAME OBJECT) (ETHERPACKET (* ;
"a piece of a routing table packet") (LOGXOR (fetch (NSROUTINGINFO NET#-HI) of OBJECT) (fetch (
NSROUTINGINFO NET#-LO) of OBJECT))) (SMALLP (* ; "a net as a small number") OBJECT) (FIXP (* ;
"a net as a number") (LOGXOR (\GETBASE OBJECT 0) (\GETBASE OBJECT 1))) (ERROR
"Illegal arg (neither FIXP, SMALLP, nor ETHERPACKET)" OBJECT))))
(\NSROUTING.EQUIVFN
(LAMBDA (X Y) (* N.H.Briggs "22-Jun-87 14:34") (SELECTQ (TYPENAME X) (ETHERPACKET (SELECTQ (TYPENAME Y
) (SMALLP (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) 0) (EQ (fetch (NSROUTINGINFO NET#-LO) of X) Y)
)) (FIXP (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) (\GETBASE Y 0)) (EQ (fetch (NSROUTINGINFO
NET#-LO) of X) (\GETBASE Y 1)))) (ETHERPACKET (AND (EQ (fetch (NSROUTINGINFO NET#-HI) of X) (fetch (
NSROUTINGINFO NET#-HI) of Y)) (EQ (fetch (NSROUTINGINFO NET#-LO) of X) (fetch (NSROUTINGINFO NET#-LO)
of Y)))) NIL)) (SMALLP (SELECTQ (TYPENAME Y) (SMALLP (EQ X Y)) (FIXP (EQUAL X Y)) (ETHERPACKET (AND (
EQ (fetch (NSROUTINGINFO NET#-HI) of Y) 0) (EQ (fetch (NSROUTINGINFO NET#-LO) of Y) X))) NIL)) (FIXP (
SELECTQ (TYPENAME Y) ((SMALLP FIXP) (EQUAL X Y)) (ETHERPACKET (AND (EQ (fetch (NSROUTINGINFO NET#-HI)
of Y) (\GETBASE X 0)) (EQ (fetch (NSROUTINGINFO NET#-LO) of Y) (\GETBASE X 1)))) NIL)) NIL)))
(PRINTROUTINGTABLE
(LAMBDA (TABLE SORT? FILE) (* edited: "11-Jan-88 21:25") (* N.H.Briggs "14-Dec-87 12:17") (PROG (
HASHENTRIES) (SELECTQ TABLE (NS (MAPHASH \NS.ROUTING.TABLE (FUNCTION (LAMBDA (X) (push HASHENTRIES X))
)) (SETQ TABLE (CONS NIL HASHENTRIES))) ((NIL PUP) (SETQ TABLE \PUP.ROUTING.TABLE)) NIL) (RESETFORM (
RADIX 8) (printout FILE " Net# Gateway #Hops Recent?" T) (for ENTRY in (COND (SORT? (
SORT (APPEND (CDR TABLE)) (if (EQ SORT? (QUOTE HOPS)) then (FUNCTION (LAMBDA (X Y) (ILESSP (fetch
RTHOPCOUNT of X) (fetch RTHOPCOUNT of Y)))) else T))) (T (CDR TABLE))) bind GATE do (printout FILE
.I6.8 (fetch RTNET# of ENTRY)) (COND ((NOT (SETQ GATE (fetch RTGATEWAY# of ENTRY))) (PRIN1
" --- " FILE)) ((FIXP GATE) (printout FILE .I9.8 GATE)) (T (SPACES 2 FILE) (PRINTNSHOSTNUMBER
GATE FILE))) (printout FILE 30 .I2 (fetch RTHOPCOUNT of ENTRY) (COND ((fetch RTRECENT of ENTRY)
" Yes") ((TIMEREXPIRED? (fetch RTTIMER of ENTRY)) " timed out") (T " No")) T)) (TERPRI FILE))
)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \NS.ROUTING.TABLE)
)
(* * LOADCOMP LLNS *before* loading this module so that this record declaration is in effect)
[DECLARE: EVAL@COMPILE
(BLOCKRECORD NSROUTINGINFO ((* Format of each entry in a routing info packet, the hashing code relys
on the fact that the net number comes first.) (NET#-HI WORD) (NET#-LO WORD) (#HOPS WORD)) (ACCESSFNS
((NET# (\GETBASEFIXP DATUM 0) (\PUTBASEFIXP DATUM 0 NEWVALUE)))))
]
(DEFINEQ
(INSTALL
(LAMBDA (FN) (* ; "Edited 21-Jun-87 22:08 by BRIGGS") (if (NOT (GETD (MKATOM (CONCAT FN ".OLD"))))
then (MOVD FN (MKATOM (CONCAT FN ".OLD")) NIL T)) (MOVD (MKATOM (CONCAT FN ".NEW")) FN NIL T)))
(UNINSTALL
(LAMBDA (FN) (* ; "Edited 21-Jun-87 22:08 by BRIGGS") (if (GETD (MKATOM (CONCAT FN ".OLD"))) then (
MOVD (MKATOM (CONCAT FN ".OLD")) FN NIL T))))
)
(* installation utilities)
(* debugging tools)
(DEFINEQ
(ROUTINGPROBE
(LAMBDA NIL (* ; "Edited 17-Jun-87 18:16 by BRIGGS") (LET ((NSOC (OPENNSOCKET
\NS.WKS.RoutingInformation T)) XIP BASE) (SETQ XIP (\FILLINXIP \XIPT.ROUTINGINFO NSOC
BROADCASTNSHOSTNUMBER \NS.WKS.RoutingInformation 0 (IPLUS \XIPOVLEN BYTESPERWORD (UNFOLD
\NS.ROUTINGINFO.WORDS BYTESPERWORD)))) (replace XIPFIRSTDATAWORD of XIP with \XROUTINGINFO.OP.REQUEST)
(SETQ BASE (\ADDBASE (fetch XIPCONTENTS of XIP) 1)) (replace (NSROUTINGINFO NET#) of BASE with -1) (
replace (NSROUTINGINFO #HOPS) of BASE with \RT.INFINITY) (SENDXIP NSOC XIP))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(UNINTERRUPTABLY (INSTALL (QUOTE \FLUSHNDBS)) (INSTALL (QUOTE \MAP.ROUTING.TABLE)) (INSTALL (QUOTE
\HANDLE.NS.ROUTING.INFO)) (INSTALL (QUOTE \LOCATE.NSNET)) (INSTALL (QUOTE \HANDLE.RAW.XIP)) (INSTALL (
QUOTE \NSGATELISTENER)) (RESTART.ETHER) (\LOCATE.NSNET -1))
)
(PUTPROPS NSROUTINGHASH COPYRIGHT ("Xerox Corporation" 1987 1988 1989))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1158 11765 (\AGE.ROUTING.TABLE.HASH 1168 . 1612) (\HANDLE.NS.ROUTING.INFO.NEW 1614 .
3371) (\HANDLE.RAW.XIP.NEW 3373 . 6241) (\LOCATE.NSNET.NEW 6243 . 6939) (\FLUSHNDBS.NEW 6941 . 7817) (
\MAP.ROUTING.TABLE.NEW 7819 . 8066) (\NSGATELISTENER.NEW 8068 . 9335) (\NSROUTING.HASHBITSFN 9337 .
9803) (\NSROUTING.EQUIVFN 9805 . 10738) (PRINTROUTINGTABLE 10740 . 11763)) (12235 12617 (INSTALL 12245
. 12453) (UNINSTALL 12455 . 12615)) (12681 13250 (ROUTINGPROBE 12691 . 13248)))))
STOP

319
lispusers/NSTALK
View File

@@ -1,319 +0,0 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "27-Jul-88 09:09:52" |{MCS:MCS:STANFORD}<LANE>NSTALK.;3| 16112
changes to%: (FNS DEFINE.GAP.SERVER)
previous date%: "16-Jun-88 17:33:04" |{MCS:MCS:STANFORD}<LANE>NSTALK.;1|)
(PRETTYCOMPRINT NSTALKCOMS)
(RPAQQ NSTALKCOMS ((* TALK NS (GAP)
Interface)
(LOCALVARS . T)
(FNS CH.USER.WORKSTATION TALK.NS.SERVER)
(FNS TALK.NS.USERNAME TALK.NS.CONNECT TALK.NS.EVENT TALK.NS.CREDENTIALS)
(* GAP Server)
(FNS GAP.SERVER DEFINE.GAP.SERVER)
(INITVARS GAP.SERVICETYPES [TALK.GAP.HANDLE '((0 0]
(TALK.GAP.UNKNOWN "(Viewpoint or XDE User)"))
(VARS TALK.GAP.PARAMETERS TALK.GAP.TRANSPORT)
(GLOBALVARS GAP.SERVICETYPES TALK.GAP.HANDLE TALK.GAP.UNKNOWN
TALK.GAP.PARAMETERS TALK.GAP.TRANSPORT)
(DECLARE%: DONTCOPY (RECORDS GAP.SERVICETYPE))
(* etc)
(FILES TALK COURIERSERVE)
(APPENDVARS (TALK.PROTOCOLTYPES (NS COERCE-TO-NSADDRESS TALK.NS.USERNAME
TALK.NS.CONNECT TALK.NS.EVENT
COURIER.START.SERVER)))
[DECLARE%: DOCOPY (COMS (DECLARE%: EVAL@LOADWHEN (NOT (HASDEF 'GAP
'COURIERPROGRAM))
(FILES NSTALKGAP]
(* DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE (FILES ETHERRECORDS SPPDECLS)
(* Also need to load EXPORTS.ALL))
(* COURIER.RESET.SOCKET used to be defined by TALK, now defined in
COURIERSERVE module)
(APPENDVARS (BEFORELOGOUTFORMS (COURIER.RESET.SOCKET)))
(P (DEFINE.GAP.SERVER)
(COURIER.START.SERVER))))
(* TALK NS (GAP) Interface)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(DEFINEQ
(CH.USER.WORKSTATION
[LAMBDA (USER WORKSTATION) (* ; "Edited 3-Jun-88 09:18 by cdl")
(if WORKSTATION
then (LET (NSADDRESS)
(if (SETQ NSADDRESS (COERCE-TO-NSADDRESS WORKSTATION (ZERO)))
then (CH.DELETE.PROPERTY USER 'ADDRESS.LIST)
(CH.ADD.ITEM.PROPERTY USER 'ADDRESS.LIST (SETQ NSADDRESS (CONS
NSADDRESS
))
'(SEQUENCE NSADDRESS))
(CONS USER NSADDRESS)
else (ERROR WORKSTATION "Address for host not found!")))
else (CH.DELETE.PROPERTY USER 'ADDRESS.LIST])
(TALK.NS.SERVER
[LAMBDA (INPUTSTREAM PROGRAM PROCEDURE PARAMETERS TRANSPORT WAITTIME CREDENTIALS VERIFIER)
(* ; "Edited 15-Jun-88 11:10 by cdl")
(* DECLARATIONS%: (ASSOCRECORD ALST
 (service)))
(LET ((USER (TALK.NS.CREDENTIALS CREDENTIALS))
(ADDRESS (create NSADDRESS
NSSOCKET _ (ZERO) using (SPP.DESTADDRESS INPUTSTREAM)))
SERVICETYPE)
(with GAP.SERVICETYPE [for SERVICETYPE in GAP.SERVICETYPES
thereis (for NUMBER
in (CAR (with ALST TRANSPORT service))
thereis (with GAP.SERVICETYPE
SERVICETYPE (EQP NUMBER
GAP.UNSPECIFIED
]
(if (OR TALK.GAG (NOT (TALK.ANSWER (OR USER TALK.GAP.UNKNOWN)
GAP.SERVICENAME
'NS ADDRESS)))
then (if (AND (EQ GAP.SERVICENAME 'TTY)
(NULL VERIFIER))
then
(* Should be noAnswerOrBusy, but that 915's XDE/Viewpoint so use VERIFIER to
 determine if called by Lisp, can't count on this for future)
'(ABORT serviceNotFound)
else '(ABORT noAnswerOrBusy))
else (COURIER.RETURN INPUTSTREAM PROGRAM PROCEDURE TALK.GAP.HANDLE)
(TALK.PROCESS INPUTSTREAM (SPPOUTPUTSTREAM INPUTSTREAM)
GAP.SERVICENAME
'NS
'SERVER USER])
)
(DEFINEQ
(TALK.NS.USERNAME
[LAMBDA (INPUTSTREAM OUTPUTSTREAM SERVICETYPE MODE USER)
(* ; "Edited 9-Jun-88 12:42 by cdl")
(LET (OBJECT NAME (SERVICE (with TALK.SERVICETYPE SERVICETYPE TALK.SERVICENAME)))
(DECLARE (GLOBALVARS LOCAL.CLEARINGHOUSE CH.NET.HINT))
(if (OR (EQ SERVICE 'TEdit)
(EQ MODE 'CLIENT))
then (if (STREQUAL (SETQ NAME (USERNAME))
(CONSTANT null))
then (SETQ NAME NIL)
elseif (OR LOCAL.CLEARINGHOUSE CH.NET.HINT)
then (if (SETQ OBJECT (CH.LOOKUP.OBJECT NAME))
then (SETQ NAME OBJECT)))
(PRINTOUT OUTPUTSTREAM NAME T)
(FORCEOUTPUT OUTPUTSTREAM))
(if (OR (EQ SERVICE 'TEdit)
(EQ MODE 'SERVER))
then (if (SETQ OBJECT (RATOM INPUTSTREAM TALK.READTABLE))
then (SETQ USER OBJECT)) (* Eat EOL)
(BIN INPUTSTREAM))
(SELECTQ SERVICE
(TTY (with SPPCON (with SPPSTREAM OUTPUTSTREAM SPP.CONNECTION)
(SETQ SPPEOMONFORCEOUT T)))
NIL)
USER])
(TALK.NS.CONNECT
[LAMBDA (HOST SERVICETYPES) (* ; "Edited 15-Jun-88 10:40 by cdl")
(* DECLARATIONS%: (RECORD
 AUTHENTICATOR (CREDENTIALS VERIFIER)))
(PROG (USER STREAM SERVICETYPE RESULT (CREDENTIALS (with AUTHENTICATOR (CH.GETAUTHENTICATOR
T)
CREDENTIALS))
(VERIFIER (with AUTHENTICATOR (CH.GETAUTHENTICATOR)
VERIFIER)))
(DECLARE (GLOBALVARS SPP.USER.TIMEOUT))
(if (SETQ STREAM (COURIER.OPEN HOST NIL T (PACK* 'TALK# HOST)))
then
(if
(SETQ SERVICETYPE
(for SERVICETYPE in SERVICETYPES
thereis
(SELECTQ [CAR
(SETQ RESULT
(COURIER.CALL
STREAM
'GAP
'Create TALK.GAP.PARAMETERS
`([service (,(with GAP.SERVICETYPE
[for TYPE in GAP.SERVICETYPES
thereis (with GAP.SERVICETYPE TYPE
(with TALK.SERVICETYPE
SERVICETYPE
(EQ GAP.SERVICENAME
TALK.SERVICENAME]
GAP.UNSPECIFIED]
,@TALK.GAP.TRANSPORT)
SPP.USER.TIMEOUT CREDENTIALS VERIFIER 'RETURNERRORS]
(ERROR (SELECTQ (CADR RESULT)
(noAnswerOrBusy (* User hung up or didn't answer,
 don't try another service)
(RETURN))
(serviceNotFound
(* Old Lisp TTY service returns this when it really means noAnswerOrBusy for
 compatibility with Tajo/Viewpoint.)
(if (with TALK.SERVICETYPE SERVICETYPE
(EQ TALK.SERVICENAME 'TTY))
then
(* Don't try services following TTY service for NS we don't know if remote
 service wasn't there or remote user refused connection so we may annoy the
 remote user, of course we may miss a possible connection)
(RETURN)))
NIL))
RESULT)))
then [RETURN (CONS SERVICETYPE (CONS STREAM (SPPOUTPUTSTREAM STREAM]
else (CLOSEF? STREAM)
(RETURN 'ANSWER))
else (RETURN 'CONNECT])
(TALK.NS.EVENT
[LAMBDA (INPUTSTREAM OUTPUTSTREAM) (* cdl "10-Jun-87 07:55")
(if (AND (OPENP INPUTSTREAM)
(OPENP OUTPUTSTREAM)
(NOT (READP INPUTSTREAM)))
then (AWAIT.EVENT (with SPPCON (with SPPSTREAM INPUTSTREAM SPP.CONNECTION)
SPPINPUTEVENT)))
(if (OPENP INPUTSTREAM)
then (SELECTQ (EOFP INPUTSTREAM)
(ATTENTION (SPP.CLEARATTENTION INPUTSTREAM)
(BIN INPUTSTREAM))
(EOM (SPP.CLEAREOM INPUTSTREAM))
(T (CLOSEF INPUTSTREAM))
NIL])
(TALK.NS.CREDENTIALS
[LAMBDA (CREDENTIALS) (* cdl " 6-May-87 15:58")
(if (AND CREDENTIALS (SETQ CREDENTIALS (CADR CREDENTIALS)))
then (SUBATOM (COURIER.READ.REP CREDENTIALS 'CLEARINGHOUSE 'NAME)
1 -2])
)
(* GAP Server)
(DEFINEQ
(GAP.SERVER
[LAMBDA (STREAM PROGRAM PROCEDURE PARAMETERS TRANSPORT WAITTIME CREDENTIALS VERIFIER)
(* ; "Edited 9-Jun-88 12:06 by cdl")
(* DECLARATIONS%: (ASSOCRECORD ALST
 (service)))
(LET (SERVICETYPE)
(if [OR [for NUMBER in (CAR (with ALST TRANSPORT service))
thereis (SETQ SERVICETYPE (for SERVICETYPE in GAP.SERVICETYPES
thereis (with GAP.SERVICETYPE
SERVICETYPE
(AND (EQP NUMBER
GAP.UNSPECIFIED
)
GAP.SERVERFN]
(AND (SETQ SERVICETYPE (ASSOC T GAP.SERVICETYPES))
(with GAP.SERVICETYPE SERVICETYPE
(* There was a server in place
 before TALK was loaded)
(FGETD GAP.SERVERFN]
then (APPLY* (with GAP.SERVICETYPE SERVICETYPE GAP.SERVERFN)
STREAM PROGRAM PROCEDURE PARAMETERS TRANSPORT WAITTIME CREDENTIALS
VERIFIER)
else '(ABORT serviceNotFound])
(DEFINE.GAP.SERVER
[LAMBDA NIL (* ; "Edited 27-Jul-88 09:08 by cdl")
(* DECLARATIONS%: (ASSOCRECORD
 PROCEDURES (Create))
 (PROPRECORD PROCEDURE
 (IMPLEMENTEDBY)))
(if (HASDEF 'GAP 'COURIERPROGRAM)
then (PROG [SERVERFN PROCEDURE (COURIERDEF (GETDEF 'GAP 'COURIERPROGRAM]
[with COURIERPGM COURIERDEF (SETQ PROCEDURE (with PROCEDURES
PROCEDURES Create))
[if (SETQ SERVERFN (with PROCEDURE PROCEDURE IMPLEMENTEDBY))
then (if (EQ SERVERFN 'GAP.SERVER)
then (RETURN))
(* Make the existing GAP server the
 default)
(if GAP.SERVICETYPES
then (PUTASSOC T `(DEFAULT ,SERVERFN)
GAP.SERVICETYPES)
else (push GAP.SERVICETYPES
`(T DEFAULT ,SERVERFN]
(with PROCEDURE PROCEDURE (SETQ IMPLEMENTEDBY 'GAP.SERVER]
(PUTDEF 'GAP 'COURIERPROGRAM COURIERDEF)
(UNMARKASCHANGED 'GAP 'COURIERPROGRAM))
else (ERROR "Courier program GAP not defined!"])
)
(RPAQ? GAP.SERVICETYPES NIL)
(RPAQ? TALK.GAP.HANDLE '((0 0)))
(RPAQ? TALK.GAP.UNKNOWN "(Viewpoint or XDE User)")
(RPAQQ TALK.GAP.PARAMETERS (ttyHost (seven even two 100 (none 0 0))))
(RPAQQ TALK.GAP.TRANSPORT ((teletype)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS GAP.SERVICETYPES TALK.GAP.HANDLE TALK.GAP.UNKNOWN TALK.GAP.PARAMETERS TALK.GAP.TRANSPORT)
)
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD GAP.SERVICETYPE (GAP.UNSPECIFIED GAP.SERVICENAME GAP.SERVERFN))
)
)
(* etc)
(FILESLOAD TALK COURIERSERVE)
(APPENDTOVAR TALK.PROTOCOLTYPES (NS COERCE-TO-NSADDRESS TALK.NS.USERNAME TALK.NS.CONNECT
TALK.NS.EVENT COURIER.START.SERVER))
(DECLARE%: DOCOPY
(DECLARE%: EVAL@LOADWHEN
(NOT (HASDEF 'GAP 'COURIERPROGRAM))
(FILESLOAD NSTALKGAP)
)
)
(* DECLARE%: DONTCOPY DONTEVAL@LOAD EVAL@COMPILE (FILES ETHERRECORDS SPPDECLS) (* Also need to load
EXPORTS.ALL))
(* COURIER.RESET.SOCKET used to be defined by TALK, now defined in COURIERSERVE module)
(APPENDTOVAR BEFORELOGOUTFORMS (COURIER.RESET.SOCKET))
(DEFINE.GAP.SERVER)
(COURIER.START.SERVER)
(DECLARE%: DONTCOPY
(FILEMAP (NIL (2304 5420 (CH.USER.WORKSTATION 2314 . 3215) (TALK.NS.SERVER 3217 . 5418)) (5421 11213 (
TALK.NS.USERNAME 5431 . 6816) (TALK.NS.CONNECT 6818 . 10218) (TALK.NS.EVENT 10220 . 10917) (
TALK.NS.CREDENTIALS 10919 . 11211)) (11237 14919 (GAP.SERVER 11247 . 13041) (DEFINE.GAP.SERVER 13043
. 14917)))))
STOP

23
lispusers/NSTALKGAP
View File

File diff suppressed because one or more lines are too long

256
lispusers/NSTHASIZE
View File

@@ -1,256 +0,0 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 3-Mar-89 18:17:39" {ERINYES}<LISPUSERS>MEDLEY>NSTHASIZE.;1 13450
changes to%: (FNS NSTHASIZE)
(VARS NSTHASIZECOMS)
previous date%: " 8-Apr-86 09:09:30" {DSK}/usr/local/koto/lispusers/nsthasize.;1)
(* "
Copyright (c) 1986, 1989 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT NSTHASIZECOMS)
(RPAQQ NSTHASIZECOMS ((INITVARS (GV.TO.NS.REG))
(FNS CONVERT.GV.TO.NS GV.READFORWARDING READ-GV-NS-MAPPING NSTHASIZE
\GETSTRING \GV.COLLECT.ENTRY \GV.COLLECT.ENTRY.1
\GV.COLLECT.ENTRY.LIST)
(FILES (LOADCOMP)
MAINTAIN)))
(RPAQ? GV.TO.NS.REG )
(DEFINEQ
(CONVERT.GV.TO.NS
[LAMBDA (X) (* lmm " 7-Apr-86 16:23")
(COND
((SETQ X (\CHECKNAME X))
(PROG ([REG (MKATOM (U-CASE (CDR X]
NSREG)
(RETURN (if (EQ REG 'NS)
then (OR (CH.LOOKUP.OBJECT (SUBSTRING (CAR X)
2 -2))
(PROGN (PRINTOUT T "[Unable to check " X
" in clearinghouse, assuming correct]")
(SUBSTRING (CAR X)
2 -2)))
else (OR (SETQ NSREG (ASSOC REG GV.TO.NS.REG))
(RETURN))
(LET (NAME)
(OR [CH.LOOKUP.OBJECT (SETQ NAME (CONCAT (CAR X)
":"
(CDR NSREG]
(PROGN (PRINTOUT T "[Unable to check " NAME
" in clearinghouse, assuming correct]")
NAME])
(GV.READFORWARDING
[LAMBDA (X) (* lmm "19-Nov-85 11:20")
(CDR (ASSOC 'Forwarding (GV.READENTRY X NIL '\GV.COLLECT.ENTRY])
(READ-GV-NS-MAPPING
[LAMBDA NIL (* lmm " 4-Apr-86 16:56")
(SETQ GV.TO.NS.REG
(RESETLST
(PROG ((STREAM (OPENSTREAM '{INDIGO}<REGISTRAR>GV>GV-NS-MAPPING.TXT 'INPUT 'OLD))
(RT (COPYREADTABLE 'ORIG))
LINES)
RESTART
(RESETSAVE NIL (LIST 'CLOSEF? STREAM))
(SETSEPR NIL NIL RT)
(SETBRK (CHARCODE (CR))
NIL RT)
(OR (FFILEPOS "GV-to-NS Mappings:" STREAM 0 NIL NIL T)
(ERROR "Couldn't find string GV-to-NS Mappings in " (FULLNAME STREAM)))
(FILEPOS " " STREAM)
[RETURN
(do (SELCHARQ (BIN STREAM)
(TAB)
(CR (RETURN LINES))
(%. [LET ((LINE (RSTRING STREAM RT)))
(PRINTOUT T LINE T)
(push LINES (LET ((POS (STRPOS " -> " LINE)))
(OR POS (GO BADFORMAT))
(CONS [MKATOM (U-CASE (SUBSTRING
LINE 1 (SUB1 POS]
(SUBSTRING LINE (PLUS POS 4)
-1]
(BIN STREAM))
(GO BADFORMAT]
BADFORMAT
(ERROR "bad format on {INDIGO}<Registrar>GV>GV-NS-MAPPING.TXT")))])
(NSTHASIZE
[LAMBDA (GVDL NSDL NODELETE) (* ; "Edited 3-Mar-89 18:16 by masinter")
(OR GV.TO.NS.REG (PROGN (PRIN1 "Reading gv to ns mapping ...")
(READ-GV-NS-MAPPING))) (* lmm " 8-Apr-86 09:03")
(SETQ GVDL (OR (\CHECKNAME GVDL)
(ERROR "Invalid grapevine group" GVDL)))
(SETQ NSDL (OR (CH.LOOKUP.OBJECT NSDL)
(ERROR "Invalid NS distribution list" NSDL)))
(LET
(FORWARDING NSADDRESS)
(for X in (CDR (GV.READMEMBERS GVDL))
do (if (OR (COND
((SETQ NSADDRESS (CONVERT.GV.TO.NS X))
(PRINTOUT T X)
T))
(AND (SETQ FORWARDING (GV.READFORWARDING X))
(PROGN (PRINTOUT T X " => " FORWARDING)
(if (CDR FORWARDING)
then (PRINTOUT T " -- more than one address." T)
NIL
else T))
(if [NOT (SETQ NSADDRESS (CONVERT.GV.TO.NS (CAR FORWARDING]
then (PRINTOUT T " not an NS equivalent address." T)
NIL
else T)))
then (PRINTOUT T " => " NSADDRESS "...")
(PROG (VALUE)
LP (if (OR (type? NSNAME (SETQ VALUE (CH.ADD.MEMBER NSDL
'MEMBERS NSADDRESS)))
(MATCH VALUE WITH (%'ERROR %'UPDATE.ERROR %'NoChange
--)))
then (if (AND NODELETE (OR (NEQ NODELETE 'FIRST)
(NLISTP VALUE)))
then (PRINTOUT T "ok." T)
else (PRINTOUT T "ok, delete: " (GV.REMOVEMEMBER
GVDL X)
T))
elseif (COND
((AND (EQ (CAR VALUE)
'ERROR)
(SELECTQ (CAR (CDR VALUE))
(CALL.ERROR (SELECTQ (CADDR VALUE)
(TooBusy (PRINTOUT T
" error:"
VALUE
" ... retrying"
" ..."))
(AccessRightsInsufficient
(PRINTOUT T " error:"
VALUE
" will not move..."
T)
(RETURN))
(HELP VALUE))
(GO LP))
(HELP VALUE)))
T))
then (TERPRI T)
NIL
else (HELP VALUE])
(\GETSTRING
[LAMBDA (STREAM LENGTH) (* lmm "19-Nov-85 10:21")
(COND
((IGREATERP LENGTH \MAXGVSTRING)
(ERROR "stream must be confused - string too long" LENGTH))
(T (LET ((STRING (ALLOCSTRING LENGTH)))
(AIN STRING 1 LENGTH STREAM)
(COND
((ODDP LENGTH)
(BIN STREAM)))
STRING])
(\GV.COLLECT.ENTRY
[LAMBDA (INSTREAM) (* lmm " 4-Apr-86 16:53")
(* * Called by GV.READENTRY to parse and display some of what Grapevine sends
 back as "the entire database entry" for NAME.
 The contents are different for groups, individuals, and dead folk)
(LET (NAMETYPE (RESULTS))
(\RECEIVESTAMP INSTREAM T) (* Skip stamp)
(BIN16 INSTREAM) (* Skip component count)
(* First component is the "prefix" %, which contains, among other things, the
 name's type and its "official" name)
(BIN16 INSTREAM) (* Length of this component)
(\RECEIVESTAMP INSTREAM T) (* Skip stamp)
(SETQ NAMETYPE (BIN16 INSTREAM))
(\RECEIVERNAME INSTREAM)
(SELECTC NAMETYPE
(\NAMETYPE.INDIVIDUAL
(\SKIPCOMPONENT INSTREAM) (* Skip password)
(SETQ RESULTS (\GV.COLLECT.ENTRY.1 INSTREAM 'ConnectSite RESULTS))
(SETQ RESULTS (\GV.COLLECT.ENTRY.LIST INSTREAM 'Forwarding RESULTS))
(SETQ RESULTS (\GV.COLLECT.ENTRY.LIST INSTREAM 'MailboxSites RESULTS)))
(\NAMETYPE.GROUP
(\GV.COLLECT.ENTRY.1 INSTREAM 'Remark RESULTS)
(\MT.SKIPSTRINGLIST INSTREAM)
(\SKIPCOMPONENT INSTREAM) (* Skip stamp list)
(\SKIPCOMPONENT INSTREAM) (* Skip DelMembers)
(\SKIPCOMPONENT INSTREAM) (* Skip stamp list)
(PROGN (* owners)
(\MT.SKIPSTRINGLIST INSTREAM)
(\SKIPCOMPONENT INSTREAM)
(\SKIPCOMPONENT INSTREAM)
(\SKIPCOMPONENT INSTREAM))
(PROGN (* friends)
(\MT.SKIPSTRINGLIST INSTREAM)
(\SKIPCOMPONENT INSTREAM)
(\SKIPCOMPONENT INSTREAM)
(\SKIPCOMPONENT INSTREAM))
'((GROUP . T)))
(\NAMETYPE.DEAD
'((DEAD . T)))
NIL])
(\GV.COLLECT.ENTRY.1
[LAMBDA (INSTREAM HEADING RESULTS) (* lmm " 2-Apr-86 12:51")
(COND
((EQ (BIN16 INSTREAM)
0)
RESULTS)
(T (CONS (CONS HEADING (LET [(STRLEN (PROGN (\RECEIVESTAMP INSTREAM T)
(* Skip stamp)
(BIN16 INSTREAM]
(LET ((STRING (ALLOCSTRING STRLEN)))
(AIN STRING 1 STRLEN INSTREAM)
(COND
((ODDP STRLEN)
(BIN INSTREAM)))
STRING)))
RESULTS])
(\GV.COLLECT.ENTRY.LIST
[LAMBDA (INSTREAM HEADING RESULTS) (* lmm " 2-Apr-86 12:52")
(* * return a component consisting of an RList, a stamp list, a "removal" RList
 (not interesting) and another stamp list)
(PROG1 (PROG ((CNT 0)
(NWORDS (BIN16 INSTREAM))
STRLEN RMAR VAL)
(COND
((EQ NWORDS 0)
(RETURN RESULTS)))
[do (add CNT 1)
(SETQ STRLEN (BIN16 INSTREAM))
(BIN16 INSTREAM) (* ignore maxLength)
(push VAL (\GETSTRING INSTREAM STRLEN))
(SETQ NWORDS (IDIFFERENCE NWORDS (IPLUS (QUOTIENT (ADD1 STRLEN)
2)
2)))
(COND
((ILEQ NWORDS 0)
(RETURN]
(RETURN (CONS (CONS HEADING VAL)
RESULTS)))
(\SKIPCOMPONENT INSTREAM)
(\SKIPCOMPONENT INSTREAM)
(\SKIPCOMPONENT INSTREAM))])
)
(FILESLOAD (LOADCOMP)
MAINTAIN)
(PUTPROPS NSTHASIZE COPYRIGHT ("Xerox Corporation" 1986 1989))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (830 13324 (CONVERT.GV.TO.NS 840 . 2194) (GV.READFORWARDING 2196 . 2378) (
READ-GV-NS-MAPPING 2380 . 4071) (NSTHASIZE 4073 . 8385) (\GETSTRING 8387 . 8814) (\GV.COLLECT.ENTRY
8816 . 11260) (\GV.COLLECT.ENTRY.1 11262 . 12058) (\GV.COLLECT.ENTRY.LIST 12060 . 13322)))))
STOP

31
lispusers/OSS-LYRIC-PATCHES
View File

@@ -1,31 +0,0 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(filecreated "24-Mar-88 18:01:18" {eris}<cutting>oss>lyric>oss-lyric-patches.\;1 2853
|changes| |to:| (vars oss-lyric-patchescoms)
|previous| |date:| "24-Mar-88 16:56:45" {eris}<cutting>oss>lyric>lyric-do-patch.\;1)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(prettycomprint oss-lyric-patchescoms)
(rpaqq oss-lyric-patchescoms ((* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.") (fns (* |;;| "from CMLSPECIALFORMS") \\do.translate) (functions (* |;;| "from CMLLIST") cl::%mapcar-multiple cl::%fill-slice-from-lists))
)
(* |;;| "Patches for some Lyric Common LISP bugs fixed in Medley.")
(defineq
(\\do.translate
(lambda (vars end-test body sequentialp env) (* \; "Edited 24-Mar-88 16:40 by drc:") (let ((vars-and-initial-values (mapcar vars (function (lambda (x) (cond ((nlistp x) (list x nil)) (t (list (car x) (cadr x)))))))) (subsequent-values (mapcar vars (function (lambda (x) (and (listp x) (cddr x) (list (car x) (caddr x))))))) (tag (gensym))) (and (setq subsequent-values (remove nil subsequent-values)) (setq subsequent-values (cons (cond (sequentialp (quote cl:setq)) (t (quote cl:psetq))) (apply (function append) subsequent-values)))) (cl:multiple-value-bind (body decls) (parse-body body env) (bquote ((\\\, (cond (sequentialp (quote prog*)) (t (quote prog)))) (\\\, vars-and-initial-values) (\\\,@ decls) (\\\, tag) (cond ((\\\, (car end-test)) (return (progn (\\\,@ (cdr end-test)))))) (\\\,@ body) (\\\, subsequent-values) (go (\\\, tag)))))))
)
)
(cl:defun cl::%mapcar-multiple (cl::fn cl::lists) (let ((cl::arg-slice (cl:make-list (length cl::lists)))) (cl:do ((cl::result nil) (cl::result-tail nil) (cl::current-slice cl::arg-slice) cl::element) ((null cl::current-slice) cl::result) (cl:setq cl::current-slice (cl::%fill-slice-from-lists cl::lists cl::arg-slice (car cl::arg-tail))) (cond (cl::current-slice (* \; "There is really more work to do.") (cl:setq cl::element (cl:apply cl::fn cl::current-slice)) (cl::%list-collect cl::result cl::result-tail (list cl::element)))))))
(defmacro cl::%fill-slice-from-lists (cl::lists cl::arg-slice cl::arg-tail-form) (bquote (cl:do ((cl::subslice (\\\, cl::arg-slice) (cdr cl::subslice)) (cl::sublist (\\\, cl::lists) (cdr cl::sublist)) (cl::some-list-empty nil) list) ((null cl::sublist) (cond (cl::some-list-empty (* \; "Ran out of entries in a list.") nil) (t (* \; "still work to do; return it.") (\\\, cl::arg-slice)))) (cl:setq list (car cl::sublist)) (cl:setq cl::some-list-empty (or cl::some-list-empty (null list))) (rplaca cl::subslice (prog1 (\\\, (cl:subst (quote list) (quote cl::arg-tail) cl::arg-tail-form)) (rplaca cl::sublist (cdr list)))))))
(putprops oss-lyric-patches copyright ("Xerox Corporation" 1988))
(declare\: dontcopy
(filemap (nil (723 1605 (\\do.translate 733 . 1603)))))
stop

24
lispusers/PACKED-STRUCTURE
View File

@@ -1,24 +0,0 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER")
(il:filecreated "19-Oct-87 14:53:33" il:{erinyes}<lispusers>lyric>packed-structure.\;1 4305
il:|changes| il:|to:| (il:setfs logbitp) (il:functions def-packed-structure signed-ldb)
il:|previous| il:|date:| "29-Sep-87 18:13:33"
il:|{IE:PARC:XEROX}<LISP>LYRIC>LISPUSERS>PACKED-STRUCTURE.;1|)
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:packed-structurecoms)
(il:rpaqq il:packed-structurecoms ((il:functions def-packed-structure signed-ldb) (il:setfs logbitp) (il:prop il:makefile-environment il:packed-structure))
)
(defdefiner def-packed-structure il:structures (name &rest slots) (let* ((*package* (symbol-package name)) (count 0) (max-count 0) (locations)) (labels ((slot-name (slot) (car slot)) (slot-type (slot) (let ((type (getf (cddr slot) (quote :type) t))) (cond ((subtypep type (quote (member nil t))) (quote :boolean)) (t (il:* il:\; " punt for now, this should really coerce other things into stuff that looks like signed or unsigned byte ") type)))) (infix (x y) (intern (format nil "~A-~A" (string x) (string y)))) (slot-location (slot) (cdr (assoc (slot-name slot) locations))) (slot-supplied-p (slot) (infix (slot-name slot) "SUPPLIED-P")) (slot-signed (slot) (and (listp (slot-type slot)) (eq (car (slot-type slot)) (quote signed-byte)))) (slot-size (slot) (let ((type (slot-type slot))) (case type (:boolean 1) (t (ecase (car type) ((unsigned-byte signed-byte) (second type)))))))) (mapc (function (lambda (slot) (when (getf (cddr slot) (quote :overlay)) (setq count 0)) (push (cons (slot-name slot) count) locations) (incf count (slot-size slot)) (setq max-count (max max-count count)))) slots) (il:bquote (progn (deftype (il:\\\, name) nil (quote (unsigned-byte (il:\\\, count)))) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (defmacro (il:\\\, (infix name (slot-name s))) (x) (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logbitp (il:\\\, (quote (il:\\\, (slot-location s)))) (il:\\\, x))))) (t (il:bquote (il:bquote ((il:\\\, (quote (il:\\\, (if (slot-signed s) (quote signed-ldb) (quote ldb))))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, x))))))))))) slots)) (defmacro (il:\\\, (infix "MAKE" name)) (&key (il:\\\,@ (mapcar (function (lambda (s) (list (slot-name s) (second s) (slot-supplied-p s)))) slots)) &aux (value 0)) (il:\\\,@ (mapcar (function (lambda (s) (il:bquote (when (il:\\\, (slot-supplied-p s)) (setq value (il:\\\, (cond ((eq (slot-type s) (quote :boolean)) (il:bquote (il:bquote (logior (if (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (ash 1 (slot-location s))))) 0) (il:\\\, value))))) ((slot-signed s) (il:bquote (il:bquote (dpb (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (byte (slot-size s) (slot-location s))))) (il:\\\, value))))) (t (il:bquote (il:bquote (logior (ash (il:\\\, (il:\\\, (slot-name s))) (il:\\\, (quote (il:\\\, (slot-location s))))) (il:\\\, value)))))))))))) slots)) value))))))
(defun signed-ldb (bytespec integer) (flet ((sign-extend (number position) (if (logbitp (1- position) number) (dpb number (byte position 0) -1) number))) (sign-extend (ldb bytespec integer) (byte-size bytespec))))
(define-setf-method logbitp (index integer) (multiple-value-bind (temps vals stores store-form access-form) (get-setf-method integer) (il:* il:\; "get SETF method for integer.") (let ((btemp (il:gensym)) (il:* il:\; "Temp var for index") (store (il:gensym)) (il:* il:\; "Temp var for new value") (stemp (first stores)) (il:* il:\; "Temp var for int to store.")) (values (cons btemp temps) (il:* il:\; "Temporary variables.") (cons index vals) (il:* il:\; "Value forms.") (list store) (il:* il:\; "Store variables.") (il:bquote (let (((il:\\\, stemp) (if (il:\\\, store) (logior (il:\\\, access-form) (ash 1 (il:\\\, btemp))) (logandc2 (il:\\\, access-form) (ash 1 (il:\\\, btemp)))))) (il:\\\, store-form) (il:\\\, store))) (il:* il:\; "Storing form") (il:bquote (logbitp (il:\\\, btemp) (il:\\\, access-form)))))))
(il:putprops il:packed-structure il:makefile-environment (:readtable "XCL" :package "XCL-USER"))
(il:putprops il:packed-structure il:copyright ("Xerox Corporation" 1987))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop

1
lispusers/PACKED-STRUCTURE.LCOM
View File

@@ -1 +0,0 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER")

111
lispusers/PATCH-LARGEIPBITMAP
View File

@@ -1,111 +0,0 @@
(FILECREATED "25-Aug-87 14:23:20" {ERINYES}<LISPUSERS>KOTO>PATCH-LARGEIPBITMAP.;1 5638
changes to: (VARS PATCH-LARGEIPBITMAPCOMS)
(FNS SHOWBITMAP1.IP))
(* Copyright (c) 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PATCH-LARGEIPBITMAPCOMS)
(RPAQQ PATCH-LARGEIPBITMAPCOMS ((* * Fix problem of SHOWBITMAP1.IP in Koto placing the parts of a
large bitmap in the wrong order)
(FNS SHOWBITMAP1.IP)))
(* * Fix problem of SHOWBITMAP1.IP in Koto placing the parts of a large bitmap in the wrong
order)
(DEFINEQ
(SHOWBITMAP1.IP
[LAMBDA (IPSTREAM BITMAP LEFT FIRSTROW XPIXELS YPIXELS SCALEFACTOR ROTATION HEIGHT XBYTES
REGIONBOTTOM) (* N.H.Briggs "25-Aug-87 14:06")
(* jds "13-Jan-86 18:13")
(* ;;
"Move a segment of bitmap to an INTERPRESS file.") (* ;; 

"FIRSTROW is the row count -- STARTING FROM THE TOP OF THE BITMAP AS ZERO -- for the first row to be displayed.")
(* ;; 

"By the time we get here, XBYTES should have been raised to the next multiple of 32-bits-worth, since that's the required width of packed pixel vectors."
)
(PROG [(TOTALBYTES (ITIMES XBYTES YPIXELS))
(SCRATCHBM (BITMAPCREATE (CEIL XPIXELS BITSPERCELL)
1))
(BMBASE (\ADDBASE (fetch (BITMAP BITMAPBASE) of BITMAP)
(ITIMES (IDIFFERENCE (IPLUS HEIGHT (OR REGIONBOTTOM 0))
(IPLUS FIRSTROW YPIXELS))
(fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP]
(APPENDOP.IP IPSTREAM DOSAVESIMPLEBODY)
(APPENDOP.IP IPSTREAM {) (* ; 

"Start the SIMPLEBODY for displaying this part of the bitmap.")
(TRANS.IP IPSTREAM) (* ; "Translate to the current position")
(APPENDNUMBER.IP IPSTREAM YPIXELS) (* ; 

"For the master, this is the number of pixels in the slow direction")
(APPENDNUMBER.IP IPSTREAM (CEIL XPIXELS BITSPERCELL))
(* ; "Number of pixels in the master's fast direction"
)
(APPENDINTEGER.IP IPSTREAM 1) (* ; "Reserved for future expansion")
(APPENDINTEGER.IP IPSTREAM 1)
(APPENDINTEGER.IP IPSTREAM 1)
(SELECTQ (IMOD (OR ROTATION 0)
360)
(0 (* ; 

"Bitmaps are really shown on their sides, hanging from the upper left corner (I think--JDS)")
(ROTATE.IP IPSTREAM -90)
(TRANSLATE.IP IPSTREAM 0 (IPLUS FIRSTROW YPIXELS))
(* ;; 

"Push this segment up to its 'true' height -- i.e., The first segment gets pushed up all the way (since it's the top of the bitmap), the next segment gets pushed up HEIGHT-#ofRowsIn1stSeg (to account for the first segment), and so on."
)
(CONCAT.IP IPSTREAM))
(90 (* ; "need nop")
(TRANSLATE.IP IPSTREAM (IDIFFERENCE HEIGHT (IPLUS FIRSTROW YPIXELS))
0) (* ;; 

"Push this segment up to its 'true' bottom -- i.e., The first segment gets pushed up to bitmapHeight-HeightOfSegment (since it's the top of the bitmap), the next segment gets pushed up HEIGHT-RowsIn1stSeg-RowsThisSeg (to account for the first segment), and so on."
)
)
(180 (* ;; 

"The translation for this hasn't been tested yet. It may well be the inverse of the rotation-0 correction")
(ROTATE.IP IPSTREAM 90)
(TRANSLATE.IP IPSTREAM 0 (IPLUS FIRSTROW YPIXELS))
(CONCAT.IP IPSTREAM))
(270 (* ;; 

"The translation for this hasn't been tested yet. It may well be the inverse of the rotation-90 correction")
(ROTATE.IP IPSTREAM 180)
(TRANSLATE.IP IPSTREAM (IDIFFERENCE HEIGHT (IPLUS FIRSTROW YPIXELS))
0)
(CONCAT.IP IPSTREAM))
(ERROR ROTATION
"rotation by other than multiples of 90 degrees not implemented"))
(SCALE.IP IPSTREAM SCALEFACTOR) (* ; "Scale the bitmap to its final size")
(CONCAT.IP IPSTREAM)
(APPENDSEQUENCEDESCRIPTOR.IP IPSTREAM SEQPACKEDPIXELVECTOR (IPLUS 4 TOTALBYTES))
(APPENDINT.IP IPSTREAM 1 2)
(APPENDINT.IP IPSTREAM (CEIL XPIXELS BITSPERCELL)
2) (* ;; 

"Now put put the bitmap -- each line must be a 32-bit multiple long")
(for Y (XWORDS _ (FOLDHI XBYTES BYTESPERWORD)) from 1 to YPIXELS
do (BITBLT BITMAP (OR LEFT 0)
(IDIFFERENCE (IPLUS (OR REGIONBOTTOM 0)
FIRSTROW YPIXELS)
Y)
SCRATCHBM 0 0 XPIXELS 1 (QUOTE INPUT)
(QUOTE REPLACE))
(\BOUTS IPSTREAM (fetch (BITMAP BITMAPBASE) of SCRATCHBM)
0
(CEIL XBYTES BYTESPERCELL)))
(APPENDOP.IP IPSTREAM MAKEPIXELARRAY)
(APPENDOP.IP IPSTREAM MASKPIXEL)
(APPENDOP.IP IPSTREAM }])
)
(PUTPROPS PATCH-LARGEIPBITMAP COPYRIGHT ("Xerox Corporation" 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (565 5548 (SHOWBITMAP1.IP 575 . 5546)))))
STOP

169
lispusers/PATCH-TWOSIDED
View File

@@ -1,169 +0,0 @@
(FILECREATED " 1-Sep-87 11:23:23" {ERINYES}<LISPUSERS>KOTO>PATCH-TWOSIDED.;1 6479
previous date: "15-Oct-86 12:20:47" {QV}<BRIGGS>LISP>PATCH-TWOSIDED.;1)
(* Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT PATCH-TWOSIDEDCOMS)
(RPAQQ PATCH-TWOSIDEDCOMS ((FNS \NSPRINT.INTERNAL)
(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY (FILES (LOADCOMP)
NSPRINT))))
(DEFINEQ
(\NSPRINT.INTERNAL
[LAMBDA (PRINTER OPTIONS TRANSFERFN) (* N.H.Briggs "27-Sep-86 16:31")
(* * Calls the PRINT program for PRINTER, interpreting OPTIONS as a plist of print options.
TRANSFERFN is a function applied to the transfer stream to actually send the Interpress master)
(PROG ((MEDIUM (OR (LISTGET OPTIONS (QUOTE MEDIUM))
NSPRINT.DEFAULT.MEDIUM))
(STAPLE? (LISTGET OPTIONS (QUOTE STAPLE?)))
(TWO.SIDED? (EQ 2 (OR (LISTGET OPTIONS (QUOTE #SIDES))
EMPRESS#SIDES)))
(SENDER.NAME (OR (LISTGET OPTIONS (QUOTE SENDER.NAME))
(USERNAME NIL NIL T)))
(DOCNAME (OR (LISTGET OPTIONS (QUOTE DOCUMENT.NAME))
"Document"))
PROPERTIES ATTRIBUTES COURIERSTREAM VALUE PRINTOPTIONS STATUS)
[SETQ ATTRIBUTES (BQUOTE ((PRINT.OBJECT.NAME , DOCNAME)
(PRINT.OBJECT.CREATE.DATE , (OR (LISTGET OPTIONS
(QUOTE
DOCUMENT.CREATION.DATE))
(IDATE)))
(SENDER.NAME , SENDER.NAME]
[SETQ PRINTOPTIONS (BQUOTE ((COPY.COUNT , (FIX (OR (LISTGET OPTIONS
(QUOTE #COPIES))
1]
(* This "option" seems to be required)
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE RECIPIENT.NAME)))
(push PRINTOPTIONS (LIST (QUOTE RECIPIENT.NAME)
(OR (STRINGP VALUE)
(MKSTRING VALUE]
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE PRIORITY)))
(push PRINTOPTIONS (LIST (QUOTE PRIORITY.HINT)
(SELECTQ VALUE
((HOLD LOW NORMAL HIGH)
VALUE)
(\ILLEGAL.ARG VALUE]
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE MESSAGE)))
(push PRINTOPTIONS (LIST (QUOTE MESSAGE)
(OR (STRINGP VALUE)
(MKSTRING VALUE]
[COND
((SETQ VALUE (LISTGET OPTIONS (QUOTE PAGES.TO.PRINT)))
(* A page range to print, (first# last#))
(COND
((AND (LISTP VALUE)
(LISTP (CDR VALUE))
(NULL (CDDR VALUE))
(SMALLPOSP (CAR VALUE))
(SMALLPOSP (CADR VALUE)))
(push PRINTOPTIONS (LIST (QUOTE PAGES.TO.PRINT)
VALUE)))
(T (\ILLEGAL.ARG VALUE]
RETRY
(COND
((NOT (SETQ COURIERSTREAM (\NSPRINT.COURIER.OPEN PRINTER)))
(printout PROMPTWINDOW .TAB0 0 "No response from printer " (fetch NSPRINTERNAME
of PRINTER))
(DISMISS 5000)
(GO RETRY)))
(RESETSAVE NIL (LIST (FUNCTION \SPP.RESETCLOSE)
COURIERSTREAM)) (* Check the status of the printer.)
(bind (LASTSTATUS _ 0)
do (SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
(QUOTE GET.PRINTER.STATUS)
(QUOTE RETURNERRORS)))
[COND
((EQ (CAR STATUS)
(QUOTE ERROR))
(COND
((NOT (EQUAL STATUS LASTSTATUS))
(printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME of PRINTER)
" Error: "
(SUBSTRING (CDR STATUS)
2 -2)
"; will retry]"))) (* Wait longer for this problem)
(DISMISS 30000))
((NEQ (SETQ STATUS (CADR (ASSOC (QUOTE SPOOLER)
STATUS)))
LASTSTATUS)
(SELECTQ STATUS
(Available (RETURN))
(Busy (printout PROMPTWINDOW T "[From " (fetch NSPRINTERNAME
of PRINTER)
" Status: Spooler busy; will retry]"))
(ERROR "Printer spooler" STATUS]
(SETQ LASTSTATUS STATUS)
(DISMISS 5000))
[COND
((OR MEDIUM STAPLE? TWO.SIDED?) (* Check that the printer supports these options.)
(SETQ PROPERTIES (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
(QUOTE GET.PRINTER.PROPERTIES)
(QUOTE RETURNERRORS)))
(COND
((EQ (CAR PROPERTIES)
(QUOTE ERROR))
(SETQ STATUS PROPERTIES)
(GO HANDLE.ERROR)))
[COND
(MEDIUM (COND
((SETQ VALUE (\NSPRINT.MEDIUM.CHECK MEDIUM
(CADR (ASSOC (QUOTE MEDIA)
PROPERTIES))
PRINTER))
(push PRINTOPTIONS (LIST (QUOTE MEDIUM.HINT)
VALUE))
(SETQ MEDIUM]
[COND
(STAPLE? (COND
((CADR (ASSOC (QUOTE STAPLE)
PROPERTIES))
(push PRINTOPTIONS (LIST (QUOTE STAPLE)
T))
(SETQ STAPLE?))
(T (printout PROMPTWINDOW .TAB0 0
"[Printer does not support stapled copies]"]
(COND
(TWO.SIDED? (COND
((CADR (ASSOC (QUOTE TWO.SIDED)
PROPERTIES))
(push PRINTOPTIONS (QUOTE (TWO.SIDED T)))
(SETQ TWO.SIDED?))
(T (printout PROMPTWINDOW .TAB0 0
"Printer does not support two-sided copies"]
(* * Finally, send the print document)
(SETQ STATUS (COURIER.CALL COURIERSTREAM (QUOTE PRINTING)
(QUOTE PRINT)
TRANSFERFN ATTRIBUTES PRINTOPTIONS (QUOTE RETURNERRORS)))
(COND
((NEQ (CAR STATUS)
(QUOTE ERROR))
(RETURN STATUS)))
HANDLE.ERROR
(ERROR (CONCAT "Unexpected error from " (fetch NSPRINTERNAME of PRINTER)
" attempting to print " DOCNAME "
RETURN to try again.")
(CDR STATUS))
(CLOSEF COURIERSTREAM)
(GO RETRY])
)
(DECLARE: EVAL@COMPILE DONTEVAL@LOAD DONTCOPY
(FILESLOAD (LOADCOMP)
NSPRINT)
)
(PUTPROPS PATCH-TWOSIDED COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (433 6305 (\NSPRINT.INTERNAL 443 . 6303)))))
STOP

76
lispusers/PS-RS232
View File

@@ -1,76 +0,0 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 2-Aug-89 13:35:49" {DSK}<LISPFILES>PS>PS-RS232.;1 2639
changes to%: (VARS PS-RS232COMS)
(PROPS (PS-RS232 MAKEFILE-ENVIRONMENT)
(PS-RS232 PRINTERTYPE)
(PS-RS232 SPOOLFILE))
(FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT))
(* "
Copyright (c) 1989 by Beckman Instruments, Inc. All rights reserved.
")
(PRETTYCOMPRINT PS-RS232COMS)
(RPAQQ PS-RS232COMS ((FILES POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS)
DLRS232C)
(INITVARS (PS-RS232-BAUD 9600)
(PS-RS232-DATABITS 8)
(PS-RS232-PARITY 'NONE)
(PS-RS232-STOPBITS 1)
(PS-RS232-FLOWCONTROL 'XOnXOff))
(FNS PS-RS232-AFTERLOGOUT PS-RS232-INIT)
(ADDVARS (DEFAULTPRINTINGHOST PS-RS232)
(AROUNDEXITFNS PS-RS232-AFTERLOGOUT))
(P (PS-RS232-INIT))
(PROP (MAKEFILE-ENVIRONMENT PRINTERTYPE SPOOLFILE)
PS-RS232)))
(FILESLOAD POSTSCRIPTSTREAM (SYSLOAD FROM LISPUSERS)
DLRS232C)
(RPAQ? PS-RS232-BAUD 9600)
(RPAQ? PS-RS232-DATABITS 8)
(RPAQ? PS-RS232-PARITY 'NONE)
(RPAQ? PS-RS232-STOPBITS 1)
(RPAQ? PS-RS232-FLOWCONTROL 'XOnXOff)
(DEFINEQ
(PS-RS232-AFTERLOGOUT
[LAMBDA (EVENT)
(if (EQ EVENT 'AFTERLOGOUT)
then (RS232C.INIT PS-RS232-BAUD PS-RS232-DATABITS PS-RS232-PARITY PS-RS232-STOPBITS
PS-RS232-FLOWCONTROL])
(PS-RS232-INIT
[LAMBDA NIL
[PUTPROP 'PS-RS232 'SPOOLOPTIONS `((BaudRate ,PS-RS232-BAUD)
(BitsPerSerialChar ,PS-RS232-DATABITS)
(Parity ,PS-RS232-PARITY)
(NoOfStopBits ,PS-RS232-STOPBITS)
(FlowControl ,PS-RS232-FLOWCONTROL]
(PS-RS232-AFTERLOGOUT 'AFTERLOGOUT) (* ; "Fake it")
NIL])
)
(ADDTOVAR DEFAULTPRINTINGHOST PS-RS232)
(ADDTOVAR AROUNDEXITFNS PS-RS232-AFTERLOGOUT)
(PS-RS232-INIT)
(PUTPROPS PS-RS232 MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
(PUTPROPS PS-RS232 PRINTERTYPE POSTSCRIPT)
(PUTPROPS PS-RS232 SPOOLFILE "{RS232}FOO.PS")
(PUTPROPS PS-RS232 COPYRIGHT ("Beckman Instruments, Inc" 1989))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1528 2244 (PS-RS232-AFTERLOGOUT 1538 . 1761) (PS-RS232-INIT 1763 . 2242)))))
STOP

BIN
lispusers/PS-RS232.TEDIT
View File

Binary file not shown.

BIN
lispusers/PS-patch.tedit
View File

Binary file not shown.

101
lispusers/REGISTER-MACHINE
View File

@@ -1,101 +0,0 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 1-Feb-2022 16:51:58" 
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGISTER-MACHINE.;2 4416
:CHANGES-TO (FNS Requst-NS-Registry)
:PREVIOUS-DATE " 8-Jan-88 18:02:00"
{DSK}<Users>kaplan>Local>medley3.5>my-medley>lispusers>REGISTER-MACHINE.;1)
(* ; "
Copyright (c) 1986-1988 by Xerox Corporation.
")
(PRETTYCOMPRINT REGISTER-MACHINECOMS)
(RPAQQ REGISTER-MACHINECOMS
(
(* ;;; "Add a Lafite form that will request that the current machine be registered with the local Clearinghouse")
(FNS Requst-NS-Registry AmIRegistered)
(ADDVARS (LAFITESPECIALFORMS ("Clearinghouse registry request" 'Requst-NS-Registry
"Make a form to request that the current machine be registered on the local Clearinghouse"
)))
(P (UNMARKASCHANGED 'LAFITESPECIALFORMS 'VARS)
(SETQ LAFITEFORMSMENU NIL))))
(* ;;;
"Add a Lafite form that will request that the current machine be registered with the local Clearinghouse"
)
(DEFINEQ
(Requst-NS-Registry
[LAMBDA NIL (* ; "Edited 1-Feb-2022 16:46 by rmk")
(* ; "Edited 8-Jan-88 18:00 by Masinter")
(* ;;;
"Format a nice note requsting that the current machine be registered on the local Clearinghouse.")
(LET ((*STANDARD-OUTPUT* (OPENTEXTSTREAM NIL NIL NIL NIL (LIST 'FONT LAFITEEDITORFONT)))
(netNumber (fetch NSNET \MY.NSADDRESS))
(me (FULLUSERNAME))
(CURRENTLY (AmIRegistered)))
(CL:FORMAT T "To: UserAdministration~A~A~&" (SELECTQ (LAFITEMODE)
(GV ".")
":")
CH.DEFAULT.DOMAIN)
(CL:FORMAT T "Cc: ~A~%%Reply-to: ~A~%%~%%" me me)
(if CURRENTLY
then (CL:FORMAT T ">>This machine is already registered as ~A <<~%%~%%" CURRENTLY))
(printout NIL "Primary User: " me T T)
(printout NIL "Name: %"" (OR (ETHERHOSTNAME)
">>Desired machine name<<")
"%"" T)
(CL:FORMAT T "Network Number: ~5,,'-:D~&" (fetch NSNET \MY.NSADDRESS))
(CL:FORMAT T "Processor Number: ~5,,'-:D~&" (+ (LSH (fetch NSHNM0 \MY.NSADDRESS)
32)
(LSH (fetch NSHNM1 \MY.NSADDRESS)
16)
(fetch NSHNM2 \MY.NSADDRESS)))
(printout NIL "Description: A " (L-CASE (MACHINETYPE)
T)
" (typically running Lisp)" T)
(printout NIL T T "Thank you." T T "-- " FIRSTNAME T)
(LET ((field (TEDIT.FIND *STANDARD-OUTPUT* ">>*<<" 1 NIL T)))
(if field
then (TEDIT.SETSEL *STANDARD-OUTPUT* (CAR field)
(ADD1 (DIFFERENCE (CADR field)
(CAR field)))
'LEFT T)))
*STANDARD-OUTPUT*])
(AmIRegistered
[LAMBDA NIL (* ; "Edited 8-Jan-88 18:00 by Masinter")
(CL:FLET [(OK (NAMES)
(for wsn in (CH.LIST.OBJECTS NAMES 'WORKSTATION) when (EQUALALL \MY.NSADDRESS
(LOOKUP.NS.SERVER
wsn))
do (RETURN (LIST wsn]
(OR (AND (ETHERHOSTNAME)
(OK (ETHERHOSTNAME)))
(OK "*"])
)
(ADDTOVAR LAFITESPECIALFORMS ("Clearinghouse registry request" 'Requst-NS-Registry
"Make a form to request that the current machine be registered on the local Clearinghouse"
))
(UNMARKASCHANGED 'LAFITESPECIALFORMS 'VARS)
(SETQ LAFITEFORMSMENU NIL)
(PUTPROPS REGISTER-MACHINE COPYRIGHT ("Xerox Corporation" 1986 1987 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1131 4015 (Requst-NS-Registry 1141 . 3416) (AmIRegistered 3418 . 4013)))))
STOP

1567
lispusers/mathserverplot
View File

File diff suppressed because it is too large Load Diff