github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-04-13 08:14:17 +00:00
Code Issues Projects Releases Wiki Activity

initial checkin for library

Browse Source
This commit is contained in:
Larry Masinter
2020-08-29 18:35:53 -07:00
parent d6580ff010
commit cb46b0b62b
113 changed files with 45947 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1645
library/BIGBITMAPS Normal file
View File

File diff suppressed because it is too large Load Diff

1
library/BINARYFILES Normal file
View File

File diff suppressed because one or more lines are too long

491
library/BROWSER Normal file
View File

@@ -0,0 +1,491 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "25-Mar-94 13:43:20" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>BROWSER.;4| 26296
changes to%: (FNS BROWSER.MIDDLEFN)
previous date%: "20-Jan-93 16:00:51" |{PELE:MV:ENVOS}<LISPCORE>LIBRARY>BROWSER.;3|)
(* ; "
Copyright (c) 1983, 1984, 1987, 1988, 1990, 1993, 1994 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT BROWSERCOMS)
(RPAQQ BROWSERCOMS
[(FILES MASTERSCOPE GRAPHER)
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
GRAPHER)
(CONSTANTS (CHANGEDSHADE 8840)))
(FNS NUMSPATHS BROWSER BROWSER.WHENFNSCHANGED BRPATHS1 BROWSER.LEFTFN GET.BROWSE.PP.WINDOW
GET.BROWSE.DESCRIBE.WINDOW BROWSEPP PPREPAINTFN PPRESHAPEFN DESCRIBEREPAINTFN
BROWSERDESCRIBE BROWSER.MIDDLEFN DEDITPROCESSRUNNINGP REDRAWBROWSEGRAPH STBROWSER)
(GLOBALRESOURCES BROWSEHASH)
(DECLARE%: DONTCOPY (RECORDS BROWSEWIN PATHSARGS))
[VARS (BROWSERBOXING)
(BROWSERFORMAT)
(BROWSERWINDOWS)
(NODESELECTIONWINDOW)
(PFWINDOW)
(BROWSER.DESCRIBE.WINDOW)
(BrowserPPWindowWidth 750)
(BROWSERFONT '(GACHA 8]
[P (MOVD? 'MSPATHS 'OLDMSPATHS)
(PROG [(WC (FILEPKGTYPE 'FNS 'WHENCHANGED]
(OR (MEMB 'BROWSER.WHENFNSCHANGED WC)
(FILEPKGTYPE 'FNS 'WHENCHANGED (CONS 'BROWSER.WHENFNSCHANGED WC]
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (SELECTQ (SYSTEMTYPE)
(D (BROWSER T))
NIL])
(FILESLOAD MASTERSCOPE GRAPHER)
(DECLARE%: EVAL@COMPILE DONTCOPY
(FILESLOAD (LOADCOMP)
GRAPHER)
(DECLARE%: EVAL@COMPILE
(RPAQQ CHANGEDSHADE 8840)
(CONSTANTS (CHANGEDSHADE 8840))
)
)
(DEFINEQ
(NUMSPATHS
[LAMBDA (FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING)
(* ; "Edited 11-Apr-88 11:08 by jrb:")
(COND
[(AND (WINDOWWORLD)
(EQ (OUTPUT)
T))
[OR AVOIDING (SETQ AVOIDING '(NIL (NIL NIL . FNS)
APPLY LAMBDA (X)
(GETPROP X 'AVOID]
(RESETVARS ((MSPRINTFLG))
(AND INVERTED (UPDATECHANGED))
(STBROWSER
[GLOBALRESOURCE
BROWSEHASH
(PROG [X NAMED TEM (UNDONE (MSLISTSET FROM T))
ROOTS GRAPHNODE.LIST (SEEN BROWSEHASH)
(CALLRELATION (PARSERELATION 'CALL]
(DECLARE (SPECVARS SEEN UNDONE))
(CLRHASH SEEN)
(for X in UNDONE do (PUTHASH X (COND
((AND NOTRACE
(MSMEMBSET X NOTRACE))
-1)
(T 0))
SEEN)
(OR INVERTED (UPDATEFN X NIL 0)))
[do (COND
(NAMED (PUTHASH (CAR NAMED)
0 SEEN)
[push ROOTS (fetch (GRAPHNODE NODEID)
of (BRPATHS1 (CAR NAMED]
(SETQ NAMED (CDR NAMED)))
(UNDONE [COND
([OR (NULL (SETQ TEM (GETHASH (CAR UNDONE)
SEEN)))
(EQ TEM 0)
(AND (LISTP TEM)
(NULL (CAR TEM]
(PUTHASH (CAR UNDONE)
(LIST NIL)
SEEN)
(SETQ NAMED (LIST (CAR UNDONE]
(SETQ UNDONE (CDR UNDONE)))
(T (RETURN]
(RETURN (LAYOUTFOREST GRAPHNODE.LIST ROOTS BROWSERFORMAT BROWSERBOXING]
(PROG1 (LIST FROM TO INVERTED AVOIDING SEPARATE NOTRACE)
(* ;
 "this LIST is actually an 'instance' of PATHSARGS")
]
(T (OLDMSPATHS FROM TO INVERTED AVOIDING SEPARATE NOTRACE MARKING])
(BROWSER
[LAMBDA (DISPLAYFLG) (* rmk%: "16-Dec-83 15:39")
(COND
(DISPLAYFLG (SETQ BROWSERFONT (FONTCREATE BROWSERFONT))
(MOVD 'NUMSPATHS 'MSPATHS))
(T (MOVD 'OLDMSPATHS 'MSPATHS])
(BROWSER.WHENFNSCHANGED
[LAMBDA (FNNAME TYPE REASON) (* DECLARATIONS%: (RECORDS BROWSEWIN))
(* ; "Edited 31-Mar-87 11:22 by jop")
(* ;; "called by system when FNNAME has changed If FNNAME is in a browser window, it reprints and redescribes it.")
(COND
((AND (ACTIVEWP PFWINDOW)
(EQ (WINDOWPROP PFWINDOW 'FNBROWSED)
FNNAME))
(BROWSEPP FNNAME PFWINDOW)))
(COND
((AND (ACTIVEWP BROWSER.DESCRIBE.WINDOW)
(EQ (WINDOWPROP BROWSER.DESCRIBE.WINDOW 'FNBROWSED)
FNNAME))
(BROWSERDESCRIBE FNNAME BROWSER.DESCRIBE.WINDOW)))
(for X in BROWSERWINDOWS do (COND
((find GRAPHNODE
in (fetch (GRAPH GRAPHNODES)
of (fetch (BROWSEWIN GRAPH)
of X))
suchthat (EQ (fetch (GRAPHNODE NODELABEL)
of GRAPHNODE)
FNNAME))
(COND
((fetch (BROWSEWIN GRAPH) of X)
(DSPFILL NIL CHANGEDSHADE 'PAINT
(fetch (BROWSEWIN WINDOW) of
X))
(WINDOWPROP (fetch (BROWSEWIN WINDOW)
of X)
'BUTTONEVENTFN
(FUNCTION REDRAWBROWSEGRAPH))
(replace (BROWSEWIN GRAPH) of X
with NIL])
(BRPATHS1
[LAMBDA (FROM) (* ; "Edited 11-Apr-88 11:27 by jrb:")
(DECLARE (GLOBALVARS BROWSERFONT))
(PROG (TEM)
(MSPATHS2 FROM)
(COND
((EQ (SETQ TEM (GETHASH FROM SEEN))
-1) (* ;
 "on NOPATHS list - create a node for it with no subs")
(SETQ TEM (create GRAPHNODE
NODEID _ FROM
NODELABEL _ FROM
NODEFONT _ BROWSERFONT
TONODES _ NIL))
(push GRAPHNODE.LIST TEM)
(PUTHASH FROM TEM SEEN)
(RETURN TEM))
((NEQ TEM 0) (* ; "already expanded into a list")
(RETURN TEM))
(T (RETURN (PROG ((ENTRY (create GRAPHNODE
NODEID _ FROM
NODELABEL _ FROM
NODEFONT _ BROWSERFONT)))
(push GRAPHNODE.LIST ENTRY)
(PUTHASH FROM ENTRY SEEN)
(replace (GRAPHNODE TONODES) of ENTRY
with (for X
in (for Y
in (COND
((NOT INVERTED)
(GETRELATION FROM CALLRELATION))
(T (GETRELATION FROM CALLRELATION T)
)) when (MSPATHS2 Y)
collect Y) when (SETQ X (BRPATHS1
X))
collect (fetch (GRAPHNODE NODEID) of X)))
(RETURN ENTRY])
(BROWSER.LEFTFN
[LAMBDA (NODE NWINDOW) (* ; "Edited 31-Mar-87 11:16 by jop")
(* ;
 "function that is applied upon selection of a node.")
(COND
((NULL NODE))
((EQ (fetch NODELABEL of NODE)
(WINDOWPROP (GET.BROWSE.PP.WINDOW)
'FNBROWSED))
(BROWSERDESCRIBE (fetch NODELABEL of NODE)
(GET.BROWSE.DESCRIBE.WINDOW)))
(T (* ;
 "if first time touched, pretty print it.")
(BROWSEPP (fetch NODELABEL of NODE)
(GET.BROWSE.PP.WINDOW])
(GET.BROWSE.PP.WINDOW
[LAMBDA NIL (* ; "Edited 31-Mar-87 11:23 by jop")
(* ;
 "returns the window for pretty printing from the browser.")
(COND
((WINDOWP PFWINDOW)
PFWINDOW)
(T (SETQ PFWINDOW (CREATEW NIL "Browser print out window"))
(WINDOWPROP PFWINDOW 'REPAINTFN 'PPREPAINTFN)
(WINDOWPROP PFWINDOW 'REPAINTFN 'PPREPAINTFN)
(WINDOWPROP PFWINDOW 'RESHAPEFN 'PPRESHAPEFN)
(WINDOWPROP PFWINDOW 'SCROLLFN 'SCROLLBYREPAINTFN)
PFWINDOW])
(GET.BROWSE.DESCRIBE.WINDOW
[LAMBDA NIL (* ; "Edited 31-Mar-87 11:23 by jop")
(* ;
 "returns the window for describe action from the browser.")
(COND
((WINDOWP BROWSER.DESCRIBE.WINDOW)
BROWSER.DESCRIBE.WINDOW)
(T (SETQ BROWSER.DESCRIBE.WINDOW (CREATEW NIL "Browser describe window"))
(WINDOWPROP BROWSER.DESCRIBE.WINDOW 'REPAINTFN 'DESCRIBEREPAINTFN)
(WINDOWPROP BROWSER.DESCRIBE.WINDOW 'RESHAPEFN 'DESCRIBEREPAINTFN)
(WINDOWPROP BROWSER.DESCRIBE.WINDOW 'SCROLLFN 'SCROLLBYREPAINTFN)
BROWSER.DESCRIBE.WINDOW])
(BROWSEPP
[LAMBDA (FN WINDOW) (* ; "Edited 31-Mar-87 11:16 by jop")
(DECLARE (GLOBALVARS BrowserPPWindowWidth))
(PROG (WIDTH BOTTOM)
(WINDOWPROP WINDOW 'FNBROWSED FN)
(CLEARW WINDOW)
(MOVETOUPPERLEFT WINDOW)
(WINDOWPROP WINDOW 'EXTENT NIL)
(SETQ WIDTH (PPREPAINTFN WINDOW)) (* ; "set the extent of the window.")
(WINDOWPROP WINDOW 'EXTENT (create REGION
LEFT _ 0
BOTTOM _ (SETQ BOTTOM (DSPYPOSITION NIL WINDOW))
WIDTH _ WIDTH
HEIGHT _ (IDIFFERENCE (WINDOWPROP WINDOW 'HEIGHT)
BOTTOM])
(PPREPAINTFN
[LAMBDA (WINDOW REGION RESHAPE) (* ; "Edited 11-Jun-90 14:11 by mitani")
(* ;; "repaints the browser pp window WINDOW. Returns the width of the image so that caller can set the EXTENT.")
(PROG ((FN (WINDOWPROP WINDOW 'FNBROWSED))
(EXTENT (WINDOWPROP WINDOW 'EXTENT))
DEF FNTYPE)
(RETURN (COND
(FN (printout WINDOW .FONT LAMBDAFONT)
(MOVETOUPPERLEFT WINDOW EXTENT)
(printout WINDOW .FONT DEFAULTFONT)
(COND
((for FPTYPE in MSFNTYPES
when (SETQ DEF (GETDEF FN (ffetch (MSANALYZABLE FILEPKGNAME)
of FPTYPE)
NIL
'NOERROR))
do (SETQ FNTYPE (ffetch (MSANALYZABLE FILEPKGNAME)
of FPTYPE))
(RETURN DEF) finally NIL)
(* ;
 "set up linelength characteristics.")
(RESETLST
(RESETSAVE (OUTPUT WINDOW))
(RESETSAVE (SETREADTABLE T))
(RESETSAVE **COMMENT**FLG)
(if (EQ FNTYPE 'FNS)
then (printout WINDOW "(" .FONT LAMBDAFONT |.P2| FN .FONT
DEFAULTFONT T))
(DSPRIGHTMARGIN (fetch (REGION RIGHT) of (DSPCLIPPINGREGION
NIL WINDOW))
WINDOW)
(PRINTDEF DEF (AND (EQ FNTYPE 'FNS)
2)
'FNS)
(if (EQ FNTYPE 'FNS)
then (PRIN1 ")" WINDOW)))
(fetch (REGION WIDTH) of (DSPCLIPPINGREGION NIL WINDOW)))
(T (* ;
 "set right margin out so wouldn't clip.")
(DSPRIGHTMARGIN 5000 WINDOW)
(APPLY* (FUNCTION PF*)
FN NIL (GETSTREAM WINDOW))
(DSPRIGHTMARGIN (fetch (REGION RIGHT) of (DSPCLIPPINGREGION
NIL WINDOW))
WINDOW)
BrowserPPWindowWidth)))
(T 0])
(PPRESHAPEFN
[LAMBDA (WINDOW) (* lmm "20-Jul-84 15:48")
(BROWSEPP (WINDOWPROP WINDOW 'FNBROWSED)
WINDOW])
(DESCRIBEREPAINTFN
[LAMBDA (WIN REG) (* ; "Edited 31-Mar-87 11:24 by jop")
(* ;
 "reprints the contents of a describe window.")
(PROG [(FN (WINDOWPROP WIN 'FNBROWSED))
(EXTENT (WINDOWPROP WIN 'EXTENT]
(COND
(FN (RESETLST (RESETSAVE MSPRINTFLG NIL)
(RESETSAVE (OUTPUT WIN))
(DSPSCROLL 'OFF WIN)
(COND
(EXTENT (MOVETOUPPERLEFT WIN EXTENT)))
(MSDESCRIBE FN])
(BROWSERDESCRIBE
[LAMBDA (FN WIN) (* ; "Edited 31-Mar-87 11:15 by jop")
(* ;; "puts the masterscope DESCRIBE information in the window DS. Keeps tracks of which fn so if it changes the window can be updated.")
(WINDOWPROP WIN 'FNBROWSED FN)
(CLEARW WIN)
(DESCRIBEREPAINTFN WIN)
(WINDOWPROP WIN 'EXTENT (create REGION
LEFT _ 0
BOTTOM _ (DSPYPOSITION NIL WIN)
WIDTH _ (WINDOWPROP WIN 'WIDTH)
HEIGHT _ (IDIFFERENCE (WINDOWPROP WIN 'HEIGHT)
(DSPYPOSITION NIL WIN])
(BROWSER.MIDDLEFN
[LAMBDA (NODE NWINDOW) (* ; "Edited 25-Mar-94 13:25 by jds")
(* ;
 "called when yellow selection from browser. Call display editor on the function.")
(COND
((NULL NODE))
[(THIS.PROCESS) (* ; "processes are running.")
(SELECTQ (EDITMODE)
(DEDIT [COND
((DEDITPROCESSRUNNINGP)
(printout PROMPTWINDOW T T "Dedit can't run in two processes at once, yet." T
"You can call Dedit in the same process by typing "
(fetch NODELABEL of NODE)
" " "into the Dedit " "window then selecting 'Edit'."))
(T (ADD.PROCESS `(ED ',(fetch NODELABEL of NODE])
((SEDIT SEDIT:SEDIT) (* ;
 "SEdit doesn't have to worry about this stuff")
(ED (fetch NODELABEL of NODE)
':DONTWAIT))
(ED (fetch NODELABEL of NODE]
(T (ED (fetch NODELABEL of NODE])
(DEDITPROCESSRUNNINGP
[LAMBDA NIL (* ; "Edited 31-Mar-87 11:27 by jop")
(* ;; "is there a dedit process running?")
(AND (EQ (EDITMODE)
'DEDIT)
\DEDITWINDOWS])
(REDRAWBROWSEGRAPH
[LAMBDA (WINDOW) (* DECLARATIONS%: (RECORDS BROWSEWIN))
(* ; "Edited 31-Mar-87 11:24 by jop")
(PROG [(WN (find X in BROWSERWINDOWS suchthat (EQ (fetch (BROWSEWIN WINDOW)
of X)
WINDOW]
(AND WN (APPLY 'NUMSPATHS (fetch (BROWSEWIN ARGS) of WN)))
(* ; "(OR WN (SHOULDNT))")
(WINDOWPROP WINDOW 'BUTTONEVENTFN (FUNCTION APPLYTOSELECTEDNODE))
(APPLYTOSELECTEDNODE WINDOW])
(STBROWSER
[LAMBDA (GRAPH ARGS) (* DECLARATIONS%: (RECORDS BROWSEWIN))
(* ; "Edited 31-Mar-87 11:18 by jop")
(* ;; "puts a browser graph for the args FROMFN in a window. If a similar graph is already a window, that window is reused; otherwise a new window is created.")
(WINDOWADDPROP (bind TMP for W in BROWSERWINDOWS
when (EQUAL (fetch (PATHSARGS DISCRIMINANT) of ARGS)
(fetch (PATHSARGS DISCRIMINANT) of (fetch
(BROWSEWIN ARGS)
of W)))
do (replace (BROWSEWIN ARGS) of W with ARGS)
(replace (BROWSEWIN GRAPH) of W with GRAPH)
(SHOWGRAPH GRAPH (SETQ W (fetch (BROWSEWIN WINDOW) of W))
(FUNCTION BROWSER.LEFTFN)
(FUNCTION BROWSER.MIDDLEFN))
(RETURN W)
finally (SETQ W (SHOWGRAPH GRAPH (CONCAT "PATHS"
(COND
((SETQ TMP (fetch
(PATHSARGS FROM)
of ARGS))
(* ;
 "CADDDR here gets the thing that looks like it might be a function name.")
(CONCAT (COND
((CADR (CADR TMP))
" FROM ")
(T " TO "))
(CADDDR TMP)))
(T ""))
(COND
((SETQ TMP (fetch
(PATHSARGS TO)
of ARGS))
(* ;
 "CADDDR here gets the thing that looks like it might be a function name.")
(CONCAT (COND
((CADR (CADR TMP))
" FROM ")
(T " TO "))
(CADDDR TMP)))
(T "")))
(FUNCTION BROWSER.LEFTFN)
(FUNCTION BROWSER.MIDDLEFN)))
(push BROWSERWINDOWS
(create BROWSEWIN
ARGS _ ARGS
GRAPH _ GRAPH
WINDOW _ W))
(RETURN W))
'CLOSEFN
(FUNCTION (LAMBDA (WINDOW) (* ;
 "The closing function for browser windows. removes it from BROWSERWINDOWS")
(SETQ BROWSERWINDOWS (DREMOVE (for X in BROWSERWINDOWS
when (EQ (fetch (BROWSEWIN WINDOW)
of X)
WINDOW)
do (RETURN X))
BROWSERWINDOWS])
)
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
[PUTDEF 'BROWSEHASH 'RESOURCES '(NEW (LIST (HARRAY 30]
)
)
(/SETTOPVAL '\BROWSEHASH.GLOBALRESOURCE NIL)
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD BROWSEWIN (ARGS GRAPH WINDOW))
(RECORD PATHSARGS (FROM TO . ETC)
[ACCESSFNS PATHSARGS ((DISCRIMINANT (CONS (fetch (PATHSARGS FROM)
of DATUM)
(fetch (PATHSARGS TO)
of DATUM])
)
)
(RPAQQ BROWSERBOXING NIL)
(RPAQQ BROWSERFORMAT NIL)
(RPAQQ BROWSERWINDOWS NIL)
(RPAQQ NODESELECTIONWINDOW NIL)
(RPAQQ PFWINDOW NIL)
(RPAQQ BROWSER.DESCRIBE.WINDOW NIL)
(RPAQQ BrowserPPWindowWidth 750)
(RPAQQ BROWSERFONT (GACHA 8))
(MOVD? 'MSPATHS 'OLDMSPATHS)
[PROG [(WC (FILEPKGTYPE 'FNS 'WHENCHANGED]
(OR (MEMB 'BROWSER.WHENFNSCHANGED WC)
(FILEPKGTYPE 'FNS 'WHENCHANGED (CONS 'BROWSER.WHENFNSCHANGED WC]
(DECLARE%: DONTEVAL@LOAD DOCOPY
(SELECTQ (SYSTEMTYPE)
(D (BROWSER T))
NIL)
)
(PUTPROPS BROWSER COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1987 1988 1990 1993 1994))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1952 24987 (NUMSPATHS 1962 . 5228) (BROWSER 5230 . 5493) (BROWSER.WHENFNSCHANGED 5495
. 7794) (BRPATHS1 7796 . 10062) (BROWSER.LEFTFN 10064 . 10922) (GET.BROWSE.PP.WINDOW 10924 . 11606) (
GET.BROWSE.DESCRIBE.WINDOW 11608 . 12356) (BROWSEPP 12358 . 13232) (PPREPAINTFN 13234 . 16368) (
PPRESHAPEFN 16370 . 16550) (DESCRIBEREPAINTFN 16552 . 17248) (BROWSERDESCRIBE 17250 . 18008) (
BROWSER.MIDDLEFN 18010 . 19317) (DEDITPROCESSRUNNINGP 19319 . 19590) (REDRAWBROWSEGRAPH 19592 . 20355)
(STBROWSER 20357 . 24985)))))
STOP

1
library/CASH-FILE Normal file
View File

File diff suppressed because one or more lines are too long

1
library/CHARCODETABLES Normal file
View File

File diff suppressed because one or more lines are too long

1
library/CHARDEVICE Normal file
View File

File diff suppressed because one or more lines are too long

1
library/CHAT Normal file
View File

File diff suppressed because one or more lines are too long

1
library/CHATDECLS Normal file
View File

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

BIN
library/CHATSERVER-EMACS Normal file
View File

Binary file not shown.

1
library/CHATTERMINAL Normal file
View File

File diff suppressed because one or more lines are too long

1
library/CLIPBOARD Normal file
View File

File diff suppressed because one or more lines are too long

1
library/COLOR Normal file
View File

File diff suppressed because one or more lines are too long

1
library/COPYFILES Normal file
View File

File diff suppressed because one or more lines are too long

1
library/DANDELIONKEYBOARDS Normal file
View File

File diff suppressed because one or more lines are too long

1
library/DATABASEFNS Normal file
View File

File diff suppressed because one or more lines are too long

1
library/DEDIT Normal file
View File

File diff suppressed because one or more lines are too long

1
library/DEDITPP Normal file
View File

File diff suppressed because one or more lines are too long

1
library/DES Normal file
View File

File diff suppressed because one or more lines are too long

1
library/DMCHAT Normal file
View File

File diff suppressed because one or more lines are too long

1
library/DORADOKEYBOARDS Normal file
View File

File diff suppressed because one or more lines are too long

53
library/DOSPRINT Normal file
View File

@@ -0,0 +1,53 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
(FILECREATED "20-Nov-95 11:34:56" {DSK}<MEDLEY>LIBRARY/DOSPRINT.\;1 2006
|changes| |to:| (VARS DOSPRINTCOMS)
|previous| |date:| "26-Jul-93 14:01:26" {DSK}<MEDLEY>LIBRARY/DOSPRINT.\;1)
; Copyright (c) 1995 by Xerox Corporation. All rights reserved.
(PRETTYCOMPRINT DOSPRINTCOMS)
(RPAQQ DOSPRINTCOMS ((FNS DOSPRINT)
(INITVARS (|DosPrinterName| NIL))
(DECLARE\: EVAL@COMPILE DONTCOPY (GLOBALVARS |DosPrinterName|))
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS
(NLAMA)
(NLAML)
(LAMA)))))
(DEFINEQ
(DOSPRINT
(LAMBDA (HOST FILE PRINTOPTIONS) (* \; "Edited 26-Jul-93 13:48 by ")
(LET* ((PRINTER (OR HOST |DosPrinterName|))
(COPIES (LISTGET PRINTOPTIONS '\#COPIES))
(NAME (LISTGET PRINTOPTIONS 'DOCUMENT.NAME))
(TYPE (PRINTERTYPE PRINTER)))
(CL:WITH-OPEN-STREAM (|out| (OPENSTREAM PRINTER 'OUTPUT))
(CL:WITH-OPEN-STREAM (|in| (OPENSTREAM FILE 'INPUT))
(CL:FORMAT PROMPTWINDOW "Spooling output to DOS printer \"~A\"..." PRINTER)
(COPYCHARS |in| |out|)
(CL:FORMAT PROMPTWINDOW "Done."))))))
)
(RPAQ? |DosPrinterName| NIL)
(DECLARE\: EVAL@COMPILE DONTCOPY
(DECLARE\: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS |DosPrinterName|)
)
)
(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA )
)
(PUTPROPS DOSPRINT COPYRIGHT ("Xerox Corporation" 1995))
(DECLARE\: DONTCOPY
(FILEMAP (NIL (958 1636 (DOSPRINT 970 . 1633)))))
STOP

1
library/DOVEKEYBOARDS Normal file
View File

File diff suppressed because one or more lines are too long

1
library/DOVERS232C Normal file
View File

File diff suppressed because one or more lines are too long

1
library/EDITBITMAP Normal file
View File

File diff suppressed because one or more lines are too long

1
library/ETHERRECORDS Normal file
View File

File diff suppressed because one or more lines are too long

1
library/EXPORTS.ALL Normal file
View File

File diff suppressed because one or more lines are too long

1
library/FILE-UPDATE Normal file
View File

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

226
library/FILEBROWSER Normal file
View File

File diff suppressed because one or more lines are too long

1
library/FONTSAMPLE Normal file
View File

File diff suppressed because one or more lines are too long

921
library/FOREIGN-FUNCTIONS Normal file
View File

@@ -0,0 +1,921 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "FOREIGN-FUNCTIONS" (USE "CL" "CONDITIONS") (
NICKNAMES "FF") (EXPORT "DEFFOREIGN" "DEF-C-STRUCT" "MALLOC" "C-FREE" "C-GETBASEBYTE" "GETBASEFLOAT"
"GETBASEINT" "GETBASEWORD" "GETBASEBYTE" "GETBASEBIT" "LINK-FILE" "UNLINK-FILE" "UNDEFINED-SYMBOLS"
"EXECUTABLE-P" "C-PUTBASEBYTE" "PUTBASEFLOAT" "PUTBASEINT" "PUTBASEWORD" "PUTBASEBYTE" "PUTBASEBIT"))
BASE 10)
(IL:FILECREATED "19-Jan-94 13:35:27" 
IL:|{DSK}<sparky>export>users>nilsson>foreign-functions>FOREIGN-FUNCTIONS.;16| 49773
IL:|changes| IL:|to:| (IL:VARS IL:FOREIGN-FUNCTIONSCOMS)
(IL:STRUCTURES FOREIGN-POINTER)
(IL:SETFS ERROR-FLAG)
(IL:VARIABLES *ALL-FOREIGN-FUNCTIONS* *ALL-FOREIGN-FILES* VALID-C-TYPES
*VALID-C-TYPES-MENU*)
(IL:FUNCTIONS C-FREE CHECK-FOREIGN-TYPE DEFFOREIGN DEF-C-STRUCT
EXECUTABLE-P FOREIGN-ERROR-CASE FOREIGN-FUNCTIONS-AROUNDEXITFN
GET-FUNCTION GET-SYMBOL IL-TO-UNIX-FILENAME LINK-FILE MALLOC
UNLINK-FILE UNDEFINED-SYMBOLS SMASHING-APPLY ERROR-FLAG
C-GETBASEBYTE GETBASEFLOAT GETBASEINT GETBASEWORD GETBASEBYTE
GETBASEBIT C-PUTBASEBYTE PUTBASEFLOAT PUTBASEINT PUTBASEWORD
PUTBASEBYTE PUTBASEBIT TRANSMOGRIFY-C-STRUCT)
IL:|previous| IL:|date:| "23-Dec-93 09:55:27"
IL:|{DSK}<sparky>export>users>nilsson>foreign-functions>FOREIGN-FUNCTIONS.;15|)
; Copyright (c) 1992, 1993, 1994 by Venue. All rights reserved.
(IL:PRETTYCOMPRINT IL:FOREIGN-FUNCTIONSCOMS)
(IL:RPAQQ IL:FOREIGN-FUNCTIONSCOMS
((IL:ALISTS (IL:\\INITSUBRS IL:CALL-C-FUNCTION IL:DLD-LINK IL:DLD-UNLINK-BY-FILE
IL:DLD-UNLINK-BY-SYMBOL IL:DLD-GET-SYMBOL IL:DLD-GET-FUNC
IL:DLD-FUNCTION-EXECUTABLE-P IL:DLD-LIST-UNDEFINED-SYMBOLS IL:C-MALLOC
IL:C-FREE IL:C-PUTBASEBYTE IL:C-GETBASEBYTE IL:CALL-SMASHING-FUNCTION))
(IL:VARIABLES *ALL-FOREIGN-FUNCTIONS* *ALL-FOREIGN-FILES* VALID-C-TYPES
*VALID-C-TYPES-MENU* *COFF-FILE-HEADER-SIZE* *AOUT-FILE-HEADER-SIZE*
*FOREIGN-SYMBOLS*)
(IL:VARS ENCLOSING-TYPES)
(IL:FUNCTIONS C-FREE CHECK-FOREIGN-TYPE DEFFOREIGN DEF-C-STRUCT EXECUTABLE-P
FOREIGN-ERROR-CASE FOREIGN-FUNCTIONS-AROUNDEXITFN GET-FUNCTION GET-SYMBOL
IL-TO-UNIX-FILENAME LINK-FILE MALLOC UNLINK-FILE UNDEFINED-SYMBOLS)
(IL:* IL:|;;| "Functions for Ron Kaplan's access mode.")
(IL:FUNCTIONS SMASHING-APPLY ERROR-FLAG)
(IL:SETFS ERROR-FLAG)
(IL:* IL:|;;| "Record defs.")
(IL:FUNCTIONS TRANSMOGRIFY-C-STRUCT)
(IL:ADDVARS (IL:CLISPRECORDTYPES C-STRUCT))
(IL:COMS (IL:* IL:\; "for handling datatype")
(IL:P (IL:MOVD 'IL:RECORD 'C-STRUCT)
(IL:PUTPROP 'C-STRUCT 'IL:USERRECORDTYPE 'TRANSMOGRIFY-C-STRUCT)))
(IL:STRUCTURES FOREIGN-POINTER)
(IL:* IL:|;;| "COFF stuff")
(IL:RECORDS COFF-HEADER COFF-OPTIONAL-HEADER COFF-SECTION-HEADER)
(IL:FUNCTIONS READ-COFF-FILE)
(IL:* IL:|;;| "AOUT stuff")
(IL:RECORDS AOUT-HEADER AOUT-FILE N_LIST FOREIGN-SYMBOL-ENTRY)
(IL:FUNCTIONS READ-AOUT-HEADER REGISTER-AOUT-SYMBOLS N_TXTOFF N_DATOFF N_TRELOFF N_DRELOFF
N_SYMOFF N_STROFF STRING-TABLE-SIZE GET-C-INTEGER GET-C-SHORT GET-C-BYTE
GET-C-ADRESS)
(IL:P (PUSH 'FOREIGN-FUNCTIONS-AROUNDEXITFN IL:AROUNDEXITFNS))
(IL:PROP IL:MAKEFILE-ENVIRONMENT IL:FOREIGN-FUNCTIONS)))
(IL:ADDTOVAR IL:\\INITSUBRS (IL:CALL-C-FUNCTION 167)
(IL:DLD-LINK 168)
(IL:DLD-UNLINK-BY-FILE 169)
(IL:DLD-UNLINK-BY-SYMBOL 170)
(IL:DLD-GET-SYMBOL 171)
(IL:DLD-GET-FUNC 172)
(IL:DLD-FUNCTION-EXECUTABLE-P 173)
(IL:DLD-LIST-UNDEFINED-SYMBOLS 174)
(IL:C-MALLOC 175)
(IL:C-FREE 176)
(IL:C-PUTBASEBYTE 177)
(IL:C-GETBASEBYTE 178)
(IL:CALL-SMASHING-FUNCTION 179))
(DEFVAR *ALL-FOREIGN-FUNCTIONS* NIL
"The list of all defined foreign functions on the form ({(<name string> . <address>)}*")
(DEFVAR *ALL-FOREIGN-FILES* NIL)
(DEFVAR VALID-C-TYPES)
(DEFVAR *VALID-C-TYPES-MENU* (IL:|create| IL:MENU
IL:TITLE IL:_ "C types"
IL:ITEMS IL:_ VALID-C-TYPES))
(DEFVAR *COFF-FILE-HEADER-SIZE* 20
"The size of the coff file header in bytes.")
(DEFVAR *AOUT-FILE-HEADER-SIZE* 32
"The size of the exec struct in bytes.")
(DEFVAR *FOREIGN-SYMBOLS* (MAKE-HASH-TABLE :TEST #'EQUAL)
"The global symbol table for the foreign symbols.")
(IL:RPAQQ ENCLOSING-TYPES (:CPOINTER :VECTOR :STRUCTURE))
(DEFUN C-FREE (POINTER SIZE)
(IL:SUBRCALL IL:C-FREE POINTER SIZE))
(DEFUN CHECK-FOREIGN-TYPE (TYPE &KEY VOID-ALLOWED-P)
(DECLARE (SPECIAL *VALID-C-TYPES-MENU*))
(LOOP (IF (IL:FMEMB TYPE VALID-C-TYPES)
(RETURN-FROM CHECK-FOREIGN-TYPE (CASE TYPE
(:VOID (IF VOID-ALLOWED-P
-1
(ERROR "Type :VOID is not allowed here."))
)
(:INT (IL:\\TYPENUMBERFROMNAME 'IL:FIXP))
(:LONG (IL:\\TYPENUMBERFROMNAME 'IL:FIXP))
(:SHORT (IL:\\TYPENUMBERFROMNAME 'IL:FIXP))
(:CHAR (IL:\\TYPENUMBERFROMNAME 'IL:CHARACTER))
(:BYTE (IL:\\TYPENUMBERFROMNAME 'IL:FIXP))
(:LISPPTR (IL:\\TYPENUMBERFROMNAME 'IL:FIXP))
(:CPOINTER (IL:\\TYPENUMBERFROMNAME 'IL:FIXP))
(:FLOAT (IL:\\TYPENUMBERFROMNAME 'IL:FLOATP))))
(RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING "Bogus type for foreign function: ~s."
:FORMAT-ARGUMENTS (LIST TYPE))
(CONTINUE (NEW-TYPE)
:REPORT "Try new type." :INTERACTIVE (LAMBDA NIL (LIST (IL:MENU
*VALID-C-TYPES-MENU*
)))
(SETQ TYPE NEW-TYPE))))))
(DEFMACRO DEFFOREIGN (FUNCTION (&REST ARGLIST)
&KEY RESULT-TYPE FOREIGN-NAME FUNCTION-DOCUMENTATION)
"Define a foreign function."
(SETQ FOREIGN-NAME (CTYPECASE FOREIGN-NAME (NULL (SYMBOL-NAME FUNCTION))
(STRING FOREIGN-NAME)))
(SETQ FUNCTION-DOCUMENTATION (AND (STRINGP FUNCTION-DOCUMENTATION)
FUNCTION-DOCUMENTATION))
(LET
((DESCRIPTOR-BLOCK (IL:\\ALLOCBLOCK (+ 5 (LENGTH ARGLIST))
NIL))
(IL:* IL:|;;| "The conversion block looks looks this:")
(IL:* IL:\; "1 function pointer.")
(IL:* IL:\; "2 RESULT-TYPE")
(IL:* IL:\; "3 ERRORFLAG")
(IL:* IL:\;
 "4 Number of args to the function.")
(IL:* IL:\; "5 0 If returnvalue on the stack else a pointer to a cell where the result should be stored. (This was ordered by Ron Kaplan /jarl)")
(IL:* IL:\;
 "6-... The argument types.")
(FUNCARGS (IL:|for| ARG IL:|in| ARGLIST IL:|as| I IL:|from| 1
IL:|collect| (INTERN (IL:CONCAT "Arg-" I)
(SYMBOL-PACKAGE FUNCTION))))
(FUNCTION-POINTER (IL:SUBRCALL IL:DLD-GET-FUNC FOREIGN-NAME)))
(BLOCK (IL:* IL:\; "If the function is on the *ALL-FOREIGN-FUNCTIONS* list then just stuff it there, else push the new def on the list.")
CHECK-FUNCS
(DOLIST (A *ALL-FOREIGN-FUNCTIONS*)
(WHEN (EQUAL (CAR A)
FOREIGN-NAME)
(RPLACD A DESCRIPTOR-BLOCK)
(RETURN-FROM CHECK-FUNCS)))
(PUSH (CONS FOREIGN-NAME DESCRIPTOR-BLOCK)
*ALL-FOREIGN-FUNCTIONS*))
(IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 0 (IL:* IL:\; "If the function is defined and executable we set the 0'th position in DESCRIPTOR-BLOCK to the address, else the address is set to 0.")
(IF (AND (< 16 FUNCTION-POINTER)
(EXECUTABLE-P FOREIGN-NAME))
FUNCTION-POINTER
0))
(IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 2 (IL:* IL:\; "Set the RESULT-TYPE")
(CHECK-FOREIGN-TYPE RESULT-TYPE :VOID-ALLOWED-P T))
(IL:* IL:|;;| "Leave a hole at 4 for the errorflag.")
(IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 4 0)
(IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 6 (IL:* IL:\;
 "Set the # of args that we pass.")
(LENGTH FUNCARGS)) (IL:* IL:\; "")
(IL:* IL:|;;|
 "Set smasher pointer to 0. That tells the emulator to return values instead of smashing them. ")
(IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK 8 0)
(DOTIMES (ARG# (LENGTH ARGLIST)) (IL:* IL:\; "Set the typevector.")
(IL:\\PUTBASEFIXP DESCRIPTOR-BLOCK (+ 10 (* 2 ARG#))
(CHECK-FOREIGN-TYPE (NTH ARG# ARGLIST)
:VOID-ALLOWED-P NIL)))
(SETF (GET FUNCTION 'FOREIGN-NAME)
FOREIGN-NAME) (IL:* IL:\;
 "Keep name and descriptorblock around.")
(SETF (GET FUNCTION 'DESCRIPTOR-BLOCK)
DESCRIPTOR-BLOCK)
(EVAL
`(DEFUN ,FUNCTION ,FUNCARGS
,@FUNCTION-DOCUMENTATION
(LET
((RESULT (IL:SUBRCALL IL:CALL-C-FUNCTION ,DESCRIPTOR-BLOCK ,@FUNCARGS))
(ERRNO (IL:\\GETBASEFIXP ,DESCRIPTOR-BLOCK 4)))
(CASE ERRNO
(0 T)
(-1 (ERROR "Foreign function ~s is not executable." ,FOREIGN-NAME))
(-2 (ERROR "Bogus return type."))
(T ,(WHEN FUNCARGS
`(ERROR "Type of argument# ~d (~s) is not ~s as declared." ERRNO
(TYPE-OF (NTH ERRNO (LIST ,@FUNCARGS)))
(IL:|fetch| IL:DTDNAME
IL:|of| (IL:\\GETDTD (IL:NTYPX (IL:\\GETBASEFIXP
,DESCRIPTOR-BLOCK
(+ 8 (* 2 ERRNO))))))))))
,(IF (EQUAL RESULT-TYPE :VOID)
'(VALUES) (IL:* IL:\;
 "If the result type is :VOID it is only fair that we return (VALUES)")
'RESULT (IL:* IL:\;
 "ELSE let the emulator take care of the type conversion.")
))))
(SETF (GET 'IL:\\GETBASEFIXP 'COMPILER::SIDE-EFFECTS-DATA)
NIL)
(COMPILE FUNCTION)
(SETF (GET 'IL:\\GETBASEFIXP 'COMPILER::SIDE-EFFECTS-DATA)
'(:NONE . :NONE))
(LIST 'QUOTE FUNCTION)))
(DEFMACRO DEF-C-STRUCT (FOOT)
42)
(DEFUN EXECUTABLE-P (NAME)
(DECLARE (TYPE (OR STRING SYMBOL)
NAME))
(LET* ((NAME (CTYPECASE NAME (SYMBOL (OR (IL:* IL:\;
 "See if we stored the name.")
(GET NAME 'FOREIGN-NAME)
(IL:* IL:\;
 "If not, try the symbol name.")
(SYMBOL-NAME NAME)))
(STRING NAME)))
(RESULT (IL:SUBRCALL IL:DLD-FUNCTION-EXECUTABLE-P NAME)))
(IF (ZEROP RESULT)
NIL
T)))
(DEFUN FOREIGN-ERROR-CASE (DLD-ERROR-NUMBER)
(CASE DLD-ERROR-NUMBER
(1 "Can't open foreign file ~s.")
(2 "Bad magic number in foreign file ~S")
(3 "Failiure reading header in foreign file ~s")
(4 "Premature EOF in text section of foreign file ~s")
(5 "Premature EOF in symbol section of foreign file ~s")
(6 "Bad string table in foreign file ~s")
(7 "Premature EOF in text relocation of foreign file ~s")
(8 "Premature EOF in data section in foreign file ~s")
(9 "Premature EOF in data relocation in foreign file ~s")
(10 "Multiple definitions of symbol in foreign file ~s")
(11 "Malformed library archive (foreign file ~s)")
(12 "Common block not supported (foreign file ~s)")
(13 "Malformed input file (foreign file ~s)")
(14 "Bad relocation info (foreign file ~s)")
(15 "Virtual memory exhausted while loading foreign file ~s.")
(16 "Undefined symbol in foreign file ~s.")
(T (CERROR "CONTINUE?" "BOGUS ERROR CODE IN DLD."))))
(DEFUN FOREIGN-FUNCTIONS-AROUNDEXITFN (EVENT)
(CASE EVENT
((IL:AFTERLOGOUT IL:AFTERMAKESYS IL:AFTERSAVEVM IL:AFTERSYSOUT)
(DOLIST (F *ALL-FOREIGN-FILES*) (IL:* IL:\;
 "Atempt to link the files we had in memory.")
(LINK-FILE F))
(DOLIST (A *ALL-FOREIGN-FUNCTIONS* (IL:* IL:\; "Redefine the functions.")
)
(LET ((FUNCTION-POINTER (IL:SUBRCALL IL:DLD-GET-FUNC (CAR A))))
(IL:\\PUTBASEFIXP (CDR A)
0
(IF (AND (< 16 FUNCTION-POINTER)
(EXECUTABLE-P (CAR A)))
FUNCTION-POINTER
0))))
(IL:PROMPTPRINT (FORMAT NIL "Foreign relink done.~&")))
((IL:BEFORELOGOUT IL:BEFOREMAKESYS IL:BEFORESYSOUT) (IL:* IL:\;
 "Invalidate all descriptors")
(DOLIST (A *ALL-FOREIGN-FUNCTIONS*)
(IL:\\PUTBASEFIXP (CDR A)
0 0)))))
(DEFUN GET-FUNCTION (SYMBOLNAME)
(DECLARE (TYPE (OR STRING SYMBOL)
SYMBOLNAME))
(DO* ((SYMBOLNAME (CTYPECASE SYMBOLNAME (SYMBOL (SYMBOL-NAME SYMBOLNAME))
(STRING SYMBOLNAME)))
(RESULT (IL:SUBRCALL IL:DLD-GET-FUNC SYMBOLNAME)
(IL:SUBRCALL IL:DLD-GET-FUNC SYMBOLNAME)))
((< 16 RESULT)
RESULT)
(RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING "Can't find foreign function ~s"
:FORMAT-ARGUMENTS (LIST SYMBOLNAME))
(CONTINUE (NEW-SYMBOLNAME)
:REPORT "Try another foreign function name." :INTERACTIVE
(LAMBDA NIL (LIST (IL:PROMPTFORWORD "New foreign function name:" SYMBOLNAME)))
(SETQ SYMBOLNAME NEW-SYMBOLNAME)))))
(DEFUN GET-SYMBOL (SYMBOLNAME)
(DECLARE (TYPE (OR STRING SYMBOL)
SYMBOLNAME))
(DO* ((SYMBOLNAME (CTYPECASE SYMBOLNAME (SYMBOL (SYMBOL-NAME SYMBOLNAME))
(STRING SYMBOLNAME)))
(RESULT (IL:SUBRCALL IL:DLD-GET-SYMBOL SYMBOLNAME)
(IL:SUBRCALL IL:DLD-GET-SYMBOL SYMBOLNAME)))
((< 16 RESULT)
RESULT)
(RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING "Can't find foreign symbol ~s"
:FORMAT-ARGUMENTS (LIST SYMBOLNAME))
(CONTINUE (NEW-SYMBOLNAME)
:REPORT "Try another foreign symbol." :INTERACTIVE (LAMBDA NIL
(LIST (IL:PROMPTFORWORD
"New foreign symbol name:"
SYMBOLNAME)))
(SETQ SYMBOLNAME NEW-SYMBOLNAME)))))
(DEFUN IL-TO-UNIX-FILENAME (FILENAME)
(IL:* IL:|;;| "Coerse a string that looks like \"{dsk}<foo>bar>...\" into /foo/bar/...")
(IF (FIND #\> FILENAME)
(LET* ((PATH (PARSE-NAMESTRING FILENAME))
(DIR (STRING-TRIM '(#\< #\>)
(DIRECTORY-NAMESTRING PATH)))
(NAME (PATHNAME-NAME PATH))
(TYPE (PATHNAME-TYPE PATH)))
(DOTIMES (A (LENGTH DIR))
(IF (EQL #\> (AREF DIR A))
(SETF (AREF DIR A)
#\/)))
(FORMAT NIL "/~A/~A~@[.~A~]" DIR NAME TYPE)) (IL:* IL:\; "No TYPE, no dot.")
FILENAME))
(DEFUN LINK-FILE (PATHNAME)
"Link foreign objectfile"
(DECLARE (TYPE (OR STRING PATHNAME)
PATHNAME))
(IL:* IL:|;;| "Make shure that we have a propper file.")
(PROG1 (BLOCK CHECK
(LOOP (LET* ((PATHNAME (IL-TO-UNIX-FILENAME
(SYMBOL-NAME (IL:FINDFILE (CTYPECASE PATHNAME
(SYMBOL (SYMBOL-NAME PATHNAME)
)
(STRING PATHNAME)
(PATHNAME (NAMESTRING PATHNAME
)))))))
(RESULT (IL:SUBRCALL IL:DLD-LINK PATHNAME)))
(IF (ZEROP RESULT)
(RETURN-FROM CHECK PATHNAME)
(RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING (FOREIGN-ERROR-CASE
RESULT)
:FORMAT-ARGUMENTS
(LIST PATHNAME))
(CONTINUE (NEW-PATHNAME)
:REPORT "Try another file." :INTERACTIVE
(LAMBDA NIL (LIST (IL:PROMPTFORWORD "New file name:"
(NAMESTRING PATHNAME))))
(SETQ PATHNAME NEW-PATHNAME)))))))
(IL:* IL:|;;|
 "Run down the list of defined functions and see if we can resolve any references.")
(PUSH PATHNAME *ALL-FOREIGN-FILES*) (IL:* IL:\;
 "Remember this file for later.")
(DOLIST (A *ALL-FOREIGN-FUNCTIONS* (IL:* IL:\;
 "car is the name cdr is the descriptor.")
)
(WHEN (ZEROP (IL:\\GETBASE (CDR A)
1))
(LET ((FUNCTION-POINTER (IL:SUBRCALL IL:DLD-GET-FUNC (CAR A))))
(IL:\\PUTBASEFIXP (CDR A)
0
(IF (AND (< 16 FUNCTION-POINTER)
(EXECUTABLE-P (CAR A)))
FUNCTION-POINTER
0)))))))
(DEFUN MALLOC (SIZE)
(IL:SUBRCALL IL:C-MALLOC SIZE))
(DEFUN UNLINK-FILE (NAME &KEY (SYMBOL-NAME-P NIL)
(FORCE-P NIL))
(IL:* IL:|;;| "Do the raw unlinking.")
(PROG1 (BLOCK GUARD
(LOOP (LET ((NAME (IL-TO-UNIX-FILENAME (SYMBOL-NAME
(IL:FINDFILE (CTYPECASE NAME
(SYMBOL (SYMBOL-NAME
NAME))
(STRING NAME)
(PATHNAME (NAMESTRING
NAME)))))))
(RESULT (IF SYMBOL-NAME-P
(IL:SUBRCALL IL:DLD-UNLINK-BY-SYMBOL NAME (IF FORCE-P
1
0))
(IL:SUBRCALL IL:DLD-UNLINK-BY-FILE NAME (IF FORCE-P
1
0)))))
(IF (ZEROP RESULT)
(RETURN-FROM GUARD NAME)
(RESTART-CASE (ERROR 'SIMPLE-ERROR :FORMAT-STRING (DLD-ERROR-CASE RESULT
)
:FORMAT-ARGUMENTS
(LIST NAME))
(CONTINUE (NEW-NAME)
:REPORT "Try another foreign symbol." :INTERACTIVE
(LAMBDA NIL (LIST (IL:PROMPTFORWORD "New foreign name:"
NAME)))
(SETQ NAME NEW-NAME)))))))
(SETQ *ALL-FOREIGN-FILES* (IL:* IL:\;
 "Forget that this file was loaded.")
(REMOVE NAME *ALL-FOREIGN-FILES*))
(IL:* IL:|;;| "Run down the list of defined functions and revalidate them.")
(DOLIST (A *ALL-FOREIGN-FUNCTIONS* (IL:* IL:\;
 "car is the name cdr is the descriptor.")
)
(WHEN (OR (< 16 (IL:SUBRCALL IL:DLD-GET-FUNC (CAR A)))
(NOT (EXECUTABLE-P (CAR A))))
(IL:\\PUTBASEFIXP (CDR A)
0 0)))))
(DEFUN UNDEFINED-SYMBOLS ()
(LET ((HEADPOINTER (IL:* IL:\;
 "This is a pointer to an array of pointers to a string")
(IL:SUBRCALL IL:DLD-LIST-UNDEFINED-SYMBOLS))
S)
(WHEN HEADPOINTER
(DOTIMES (OFFSET (C-GETBASEBYTE
(IL:* IL:|;;| "Number of undefined symbols.")
(GET-SYMBOL "dld_undefined_sym_count")
0 :INT))
(LET ((STRINGPOINTER (C-GETBASEBYTE HEADPOINTER OFFSET :INT)))
(DO* ((CHARPTR 1 (IL:* IL:\;
 "Start at index 1 to avoid leading #\\_ in the name")
(1+ CHARPTR))
(CHAR (CHARACTER (C-GETBASEBYTE STRINGPOINTER CHARPTR :BYTE))
(CHARACTER (C-GETBASEBYTE STRINGPOINTER CHARPTR :BYTE)))
(STRN (LIST CHAR)
(CONS CHAR STRN)))
((EQL CHAR #\Null)
(PUSH (MAP 'STRING #'IDENTITY (REVERSE
(IL:* IL:\; "STRN is in reverse order")
(CDR STRN)))
S (IL:* IL:\; "Get rid of the #\\Null")
))))))
S))
(IL:* IL:|;;| "Functions for Ron Kaplan's access mode.")
(DEFMACRO SMASHING-APPLY (DESCRIPTOR PLACE &REST ARGS)
`(IL:SUBRCALL IL:CALL-SMASHING-FUNCTION ,DESCRIPTOR ,PLACE ,@ARGS))
(DEFMACRO ERROR-FLAG (DESCRIPTOR)
`(IL:\\GETBASEFIXP ,DESCRIPTOR 4))
(DEFSETF ERROR-FLAG (DESCRIPTOR) (NEWVAL)
`(IL:\\PUTBASEFIXP ,DESCRIPTOR 4 ,NEWVAL))
(IL:* IL:|;;| "Record defs.")
(DEFUN TRANSMOGRIFY-C-STRUCT (STRUCTURE-DESCRIPTION)
(IL:* IL:|;;| "Test the description for discrepancies an build a description of the slots.")
(LET ((NAME (SECOND STRUCTURE-DESCRIPTION))
(BODY (THIRD STRUCTURE-DESCRIPTION))
(DESCRIPTOR NIL)
(BYTE-ADDR 0)
(LST NIL))
(IL:* IL:|;;| "The format of a field is (FIELDNAME TYPE <typemodifier>) where the modifier is either :POINTER :STRUCTURE or an integer denoting that it is an array.")
(MACROLET ((MAKE-ACCESSOR (D GET PUT OFFSET)
``(,(FIRST D)
(,GET 'IL:DATUM ,OFFSET)
(,PUT 'IL:DATUM ,OFFSET IL:NEWVALUE))))
(DOLIST (D BODY)
(LET ((BASE BYTE-ADDR))
(CASE (SECOND D)
(:BIT (INCF BYTE-ADDR))
(IL:* IL:|;;| "8 bit addrs. No address adjustment.")
(:CHAR
(PUSH (MAKE-ACCESSOR D GETBASEBYTE PUTBASEBYTE BYTE-ADDR)
LST)
(INCF BYTE-ADDR))
(:BYTE
(PUSH (MAKE-ACCESSOR D GETBASEBYTE PUTBASEBYTE BYTE-ADDR)
LST)
(INCF BYTE-ADDR))
(IL:* IL:|;;| "16 bit addrs. Adjust address to even boundries.")
(:SHORT
(WHEN (ODDP BYTE-ADDR)
(INCF BYTE-ADDR))
(PUSH (MAKE-ACCESSOR D GETBASEWORD PUTBASEWORD (ASH BYTE-ADDR -1))
LST)
(INCF BYTE-ADDR 2))
(IL:* IL:|;;| "32 bit addrs. Adjust address to 4 boundries.")
(:INT
(INCF BYTE-ADDR (MOD (- 4 (MOD BYTE-ADDR 4))
4))
(PUSH (MAKE-ACCESSOR D GETBASEINT PUTBASEINT (ASH BYTE-ADDR -2))
LST)
(INCF BYTE-ADDR 4))
(:LONG
(INCF BYTE-ADDR (MOD (- 4 (MOD BYTE-ADDR 4))
4))
(PUSH (MAKE-ACCESSOR D GETBASEINT PUTBASEINT (ASH BYTE-ADDR -2))
LST)
(INCF BYTE-ADDR 4))
(:FLOAT
(INCF BYTE-ADDR (MOD (- 4 (MOD BYTE-ADDR 4))
4))
(PUSH (MAKE-ACCESSOR D GETBASEFLOAT PUTBASEFLOAT (ASH BYTE-ADDR -2))
LST)
(INCF BYTE-ADDR 4))))))
`(IL:ACCESSFNS ,NAME ,(REVERSE LST)
(CREATE (IL:\\\\ALLOCBLOCK (ASH BYTE-ADDR -2))))))
(IL:ADDTOVAR IL:CLISPRECORDTYPES C-STRUCT)
(IL:* IL:\; "for handling datatype")
(IL:MOVD 'IL:RECORD 'C-STRUCT)
(IL:PUTPROP 'C-STRUCT 'IL:USERRECORDTYPE 'TRANSMOGRIFY-C-STRUCT)
(DEFSTRUCT FOREIGN-POINTER
"Pointer to a foreign object"
(DESTINATION-TYPE NIL)
(VALUE NIL))
(IL:* IL:|;;| "COFF stuff")
(IL:DECLARE\: IL:EVAL@COMPILE
(IL:BLOCKRECORD COFF-HEADER ((F_MAGIC
IL:BITS 16)
(F_NSCNS
IL:BITS 16)
(F_TIMDAT
IL:BITS 32)
(F_SYMPTR
IL:BITS 32)
(F_NSYMS
IL:BITS 32)
(F_OPTHEADER
IL:BITS 16)
(F_FLAGS
IL:BITS 16)))
(IL:BLOCKRECORD COFF-OPTIONAL-HEADER ((MAGIC IL:BITS 16)
(VSTAMP IL:BITS 16)
(TSIZE IL:BITS 32)
(DSIZE IL:BITS 32)
(BSIZE IL:BITS 32)
(ENTRY IL:BITS 32)
(TEXT_START
IL:BITS 32)
(DATA_START
IL:BITS 32)))
(IL:BLOCKRECORD COFF-SECTION-HEADER ((S_NAME1
IL:BITS 32)
(S_NAME2
IL:BITS 32)
(S_PADDR
IL:BITS 32)
(S_VADDR
IL:BITS 32)
(S_SIZE
IL:BITS 32)
(S_SCNPTR
IL:BITS 32)
(S_RELPTR
IL:BITS 32)
(S_LNNOPTR
IL:BITS 32)
(S_NRELOC
IL:BITS 16)
(S_NLNNO
IL:BITS 16)
(S_FLAGS
IL:BITS 32)))
)
(DEFUN READ-COFF-FILE (FILENAME)
(LET* ((FILEHEADER (MAKE-ARRAY *COFF-FILE-HEADER-SIZE* :ELEMENT-TYPE '(UNSIGNED-BYTE 8)
:ADJUSTABLE NIL))
(FILEHEADERBASE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| FILEHEADER))
(OPTIONALHEADER (MAKE-ARRAY '(100)
:ELEMENT-TYPE
'(UNSIGNED-BYTE 8)
:ADJUSTABLE NIL))
(OPTHEADERBASE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| OPTIONALHEADER)))
(WITH-OPEN-FILE (FILE FILENAME :IF-DOES-NOT-EXITS :ERROR :ELEMENT-TYPE '(UNSIGNED-BYTE
8)
:DIRECTION :INPUT)
(DOTIMES (INDEX *COFF-FILE-HEADER-SIZE*)
(SETF (AREF FILEHEADER INDEX)
(READ-BYTE FILE :EOF-ERROR-P T)))
(FORMAT T "optheader size: ~d~&" (IL:|fetch| (COFF-HEADER F_OPTHEADER)
IL:|of| FILEHEADERBASE))
(IL:|if| (PLUSP (IL:|fetch| (COFF-HEADER F_OPTHEADER) IL:|of|
FILEHEADERBASE))
IL:|then| (DOTIMES (INDEX (IL:|fetch| (COFF-HEADER F_OPTHEADER)
IL:|of| FILEHEADERBASE))
(SETF (AREF OPTIONALHEADER INDEX)
(READ-BYTE FILE :EOF-ERROR-P T)))
(FORMAT T "Magic: ~o~&" (IL:|fetch| (COFF-OPTIONAL-HEADER MAGIC)
IL:|of| OPTHEADERBASE))
(FORMAT T "Text size: ~d~&" (IL:|fetch| (COFF-OPTIONAL-HEADER TSIZE)
IL:|of| OPTHEADERBASE))
(FORMAT T "data size: ~d~&" (IL:|fetch| (COFF-OPTIONAL-HEADER DSIZE)
IL:|of| OPTHEADERBASE))
(FORMAT T "uninit data size: ~d~&" (IL:|fetch| (COFF-OPTIONAL-HEADER
BSIZE) IL:|of|
OPTHEADERBASE)))
(FORMAT T "Number of symtab entries: ~b~&" (IL:|fetch| (COFF-HEADER F_NSYMS)
IL:|of| FILEHEADERBASE)))))
(IL:* IL:|;;| "AOUT stuff")
(IL:DECLARE\: IL:EVAL@COMPILE
(IL:BLOCKRECORD AOUT-HEADER ((A_MAGIC
IL:BITS 32)
(A_TEXT
IL:BITS 32)
(A_DATA
IL:BITS 32)
(A_BSS
IL:BITS 32)
(A_SYMS
IL:BITS 32)
(A_ENTRY
IL:BITS 32)
(A_TRSIZE
IL:BITS 32)
(A_DRSIZE
IL:BITS 32)))
(IL:DATATYPE AOUT-FILE (NAME HEADER TEXT DATA TEXT-RELOC DATA-RELOC SYMBOL-TABLE STRING-TABLE))
(IL:BLOCKRECORD N_LIST ((N_NAME
IL:BITS 32)
(N_MISC
IL:BITS 32)
(N_VALUE
IL:BITS 32)))
(IL:DATATYPE FOREIGN-SYMBOL-ENTRY (NAME TYPE EXTERNAL-P VALUE-INDEX OBJECTFILE)
(IL:ACCESSFNS
(VALUE (IL:|with| FOREIGN-SYMBOL-ENTRY IL:DATUM
(CASE TYPE
(:UNDEFINED :UNDEFINED)
(:ABSOLUTE )
(:TEXT )
(:DATA (GET-C-INTEGER (IL:|fetch|
(AOUT-FILE HEADER)
IL:|of|
OBJECTFILE)
VALUE-INDEX))
(:BSS )
(:COMMON )
(:FILE-NAME ))))))
)
(IL:/DECLAREDATATYPE 'AOUT-FILE '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER
IL:POINTER IL:POINTER)
'((AOUT-FILE 0 IL:POINTER)
(AOUT-FILE 2 IL:POINTER)
(AOUT-FILE 4 IL:POINTER)
(AOUT-FILE 6 IL:POINTER)
(AOUT-FILE 8 IL:POINTER)
(AOUT-FILE 10 IL:POINTER)
(AOUT-FILE 12 IL:POINTER)
(AOUT-FILE 14 IL:POINTER))
'16)
(IL:/DECLAREDATATYPE 'FOREIGN-SYMBOL-ENTRY '(IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)
'((FOREIGN-SYMBOL-ENTRY 0 IL:POINTER)
(FOREIGN-SYMBOL-ENTRY 2 IL:POINTER)
(FOREIGN-SYMBOL-ENTRY 4 IL:POINTER)
(FOREIGN-SYMBOL-ENTRY 6 IL:POINTER)
(FOREIGN-SYMBOL-ENTRY 8 IL:POINTER))
'10)
(DEFUN READ-AOUT-HEADER (FILENAME)
(WITH-OPEN-FILE (FILE FILENAME :IF-DOES-NOT-EXITS :ERROR :ELEMENT-TYPE '(UNSIGNED-BYTE 8)
:DIRECTION :INPUT)
(LET* ((OBJECTARRAY (MAKE-ARRAY (FILE-LENGTH FILE)
:ELEMENT-TYPE
'(UNSIGNED-BYTE 8)
:ADJUSTABLE NIL))
(OBJECTBASE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| OBJECTARRAY))
(AOUTSTRUCTURE NIL))
(DOTIMES (INDEX (FILE-LENGTH FILE))
(SETF (AREF OBJECTARRAY INDEX)
(READ-BYTE FILE :EOF-ERROR-P T)))
(SETQ AOUTSTRUCTURE (IL:|create| AOUT-FILE
NAME IL:_ FILENAME
(IL:* IL:|;;| "Header is the start of the whole array,")
HEADER IL:_ OBJECTARRAY
(IL:* IL:|;;| "Text is the start of the code array")
TEXT IL:_ (MAKE-ARRAY (LIST (IL:|fetch| (AOUT-HEADER
A_TEXT)
IL:|of| OBJECTBASE))
:ELEMENT-TYPE
'(UNSIGNED-BYTE 8)
:DISPLACED-TO OBJECTARRAY
:DISPLACED-INDEX-OFFSET (N_TXTOFF
OBJECTARRAY))
(IL:* IL:|;;| "DATA start = aout-end-index + textsize")
DATA IL:_ (MAKE-ARRAY (LIST (IL:|fetch| (AOUT-HEADER
A_DATA)
IL:|of| OBJECTBASE))
:ELEMENT-TYPE
'(UNSIGNED-BYTE 8)
:DISPLACED-TO OBJECTARRAY
:DISPLACED-INDEX-OFFSET (N_DATOFF
OBJECTARRAY))
TEXT-RELOC IL:_ (MAKE-ARRAY (IL:|fetch| (AOUT-HEADER
A_TRSIZE)
IL:|of| OBJECTBASE)
:ELEMENT-TYPE
'(UNSIGNED-BYTE 8)
:DISPLACED-TO OBJECTARRAY
:DISPLACED-INDEX-OFFSET
(N_TRELOFF
OBJECTARRAY))
DATA-RELOC IL:_ (MAKE-ARRAY (IL:|fetch| (AOUT-HEADER
A_DRSIZE)
IL:|of| OBJECTBASE)
:ELEMENT-TYPE
'(UNSIGNED-BYTE 8)
:DISPLACED-TO OBJECTARRAY
:DISPLACED-INDEX-OFFSET
(N_DRELOFF
OBJECTARRAY))
SYMBOL-TABLE IL:_ (MAKE-ARRAY (LIST (IL:|fetch|
(AOUT-HEADER A_SYMS)
IL:|of|
OBJECTBASE))
:ELEMENT-TYPE
'(UNSIGNED-BYTE 8)
:DISPLACED-TO OBJECTARRAY
:DISPLACED-INDEX-OFFSET
(N_SYMOFF
OBJECTARRAY))
STRING-TABLE IL:_ (MAKE-ARRAY (LIST (STRING-TABLE-SIZE
OBJECTARRAY))
:ELEMENT-TYPE
'(UNSIGNED-BYTE 8)
:DISPLACED-TO OBJECTARRAY
:DISPLACED-INDEX-OFFSET
(N_STROFF
OBJECTARRAY))))
(IL:* IL:|;;| "Make Medley believe that this is an array of string-char instead. This is ugly but it works. /Jarl.")
(IL:|replace| (IL:ONED-ARRAY IL:TYPE-NUMBER) IL:|of| (IL:|fetch|
(AOUT-FILE STRING-TABLE
) IL:|of|
AOUTSTRUCTURE)
IL:|with| 67)
AOUTSTRUCTURE)))
(DEFUN REGISTER-AOUT-SYMBOLS (AOUFILERECORD)
(LET ((SYMBOL-TABLE (IL:|fetch| (AOUT-FILE SYMBOL-TABLE) IL:|of| AOUFILERECORD))
(STRING-TABLE (IL:|fetch| (AOUT-FILE STRING-TABLE) IL:|of| AOUFILERECORD)))
(DO ((RECORDINDEX 0 (+ RECORDINDEX 12)))
((>= RECORDINDEX (LENGTH SYMBOL-TABLE)))
(LET* ((STRINGTAB-INDEX (GET-C-INTEGER SYMBOL-TABLE RECORDINDEX))
(TYPE-ENTRY (GET-C-BYTE SYMBOL-TABLE (+ 4 RECORDINDEX)))
(OTHER-ENTRY (GET-C-BYTE SYMBOL-TABLE (+ 5 RECORDINDEX)))
(DESCRIPTION (GET-C-SHORT SYMBOL-TABLE (+ 6 RECORDINDEX)))
(VALUE-INDEX (GET-C-INTEGER SYMBOL-TABLE (+ 8 RECORDINDEX)))
(NAME (STRING (SUBSEQ STRING-TABLE STRINGTAB-INDEX (POSITION #\Null STRING-TABLE
:START STRINGTAB-INDEX))))
(REC (IL:|create| FOREIGN-SYMBOL-ENTRY
NAME IL:_ NAME
OBJECTFILE IL:_ AOUFILERECORD
EXTERNAL-P IL:_ (ODDP TYPE-ENTRY)
TYPE IL:_ (CASE (LOGAND TYPE-ENTRY 30)
(0 :UNDEFINED)
(2 :ABSOLUTE)
(4 :TEXT)
(6 :DATA)
(8 :BSS)
(18 :COMMON)
(30 :FILE-NAME)))))
(SETF (GETHASH NAME *FOREIGN-SYMBOLS*)
REC)
(CASE (IL:|fetch| (FOREIGN-SYMBOL-ENTRY TYPE) IL:|of| REC)
(:UNDEFINED )
(:ABSOLUTE )
(:TEXT )
(:DATA (IL:|replace| (FOREIGN-SYMBOL-ENTRY VALUE-INDEX) IL:|of| REC
IL:|with| (+ VALUE-INDEX *AOUT-FILE-HEADER-SIZE*)))
(:BSS )
(:COMMON )
(:FILE-NAME ))
REC))))
(DEFUN N_TXTOFF (OBJECT)
*AOUT-FILE-HEADER-SIZE*)
(DEFUN N_DATOFF (OBJECTARRAY)
(+ (N_TXTOFF
OBJECTARRAY)
(IL:|fetch| (AOUT-HEADER A_TEXT) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE)
IL:|of| OBJECTARRAY))))
(DEFUN N_TRELOFF (OBJECTARRAY)
(+ (N_DATOFF
OBJECTARRAY)
(IL:|fetch| (AOUT-HEADER A_DATA) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE)
IL:|of| OBJECTARRAY))))
(DEFUN N_DRELOFF (OBJECTARRAY)
(+ (N_TRELOFF
OBJECTARRAY)
(IL:|fetch| (AOUT-HEADER A_TRSIZE) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE)
IL:|of| OBJECTARRAY))))
(DEFUN N_SYMOFF (OBJECTARRAY)
(+ (N_DRELOFF
OBJECTARRAY)
(IL:|fetch| (AOUT-HEADER A_DRSIZE) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE)
IL:|of| OBJECTARRAY))))
(DEFUN N_STROFF (OBJECTARRAY)
(+ (N_SYMOFF
OBJECTARRAY)
(IL:|fetch| (AOUT-HEADER A_SYMS) IL:|of| (IL:|fetch| (IL:ONED-ARRAY IL:BASE)
IL:|of| OBJECTARRAY))))
(DEFUN STRING-TABLE-SIZE (OBJECTARRAY)
(LET* ((INDEX (N_STROFF
OBJECTARRAY))
(RESULT (IL:\\GETBASEBYTE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| OBJECTARRAY)
INDEX)))
(DOTIMES (A 3)
(SETQ RESULT (+ (IL:LSH RESULT 8)
(IL:\\GETBASEBYTE (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of|
OBJECTARRAY)
(INCF INDEX)))))
RESULT))
(DEFUN GET-C-INTEGER (ARRAY INDEX)
(+ (IL:LSH (AREF ARRAY INDEX)
24)
(IL:LSH (AREF ARRAY (+ INDEX 1))
16)
(IL:LSH (AREF ARRAY (+ INDEX 2))
8)
(AREF ARRAY (+ INDEX 3))))
(DEFUN GET-C-SHORT (ARRAY INDEX)
(+ (IL:LSH (AREF ARRAY INDEX)
8)
(AREF ARRAY (+ INDEX 1))))
(DEFUN GET-C-BYTE (ARRAY INDEX)
(AREF ARRAY INDEX))
(DEFUN GET-C-ADRESS ()
(ERROR "NOT YET!"))
(PUSH 'FOREIGN-FUNCTIONS-AROUNDEXITFN IL:AROUNDEXITFNS)
(IL:PUTPROPS IL:FOREIGN-FUNCTIONS IL:MAKEFILE-ENVIRONMENT
(:READTABLE "XCL" :PACKAGE
(XCL:DEFPACKAGE "FOREIGN-FUNCTIONS" (:USE "CL" "CONDITIONS")
(:NICKNAMES "FF")
(:EXPORT "DEFFOREIGN" "DEF-C-STRUCT" "MALLOC" "C-FREE" "C-GETBASEBYTE"
"GETBASEFLOAT" "GETBASEINT" "GETBASEWORD" "GETBASEBYTE"
"GETBASEBIT" "LINK-FILE" "UNLINK-FILE" "UNDEFINED-SYMBOLS"
"EXECUTABLE-P" "C-PUTBASEBYTE" "PUTBASEFLOAT" "PUTBASEINT"
"PUTBASEWORD" "PUTBASEBYTE" "PUTBASEBIT"))
:BASE 10))
(IL:PUTPROPS IL:FOREIGN-FUNCTIONS IL:COPYRIGHT ("Venue" 1992 1993 1994))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL)))
IL:STOP

1
library/FX-80DRIVER Normal file
View File

File diff suppressed because one or more lines are too long

387
library/GCHAX Normal file
View File

File diff suppressed because one or more lines are too long

3199
library/GRAPHER Normal file
View File

File diff suppressed because one or more lines are too long

1
library/GRAPHZOOM Normal file
View File

File diff suppressed because one or more lines are too long

1
library/HASH Normal file
View File

File diff suppressed because one or more lines are too long

1
library/HASH-FILE Normal file
View File

File diff suppressed because one or more lines are too long

1
library/HRULE Normal file
View File

File diff suppressed because one or more lines are too long

542
library/IMAGEOBJ Normal file
View File

@@ -0,0 +1,542 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED " 7-Dec-95 13:21:56" {DSK}<MEDLEY>LIBRARY/IMAGEOBJ.;1 35602
changes to%: (FNS BMOBJ.DISPLAYFN BMOBJ.IMAGEBOXFN)
previous date%: " 6-Dec-95 15:18:32" {DSK}<MEDLEY>LIBRARY/IMAGEOBJ.;1)
(* ; "
Copyright (c) 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1995 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT IMAGEOBJCOMS)
(RPAQQ IMAGEOBJCOMS
((COMS
(* ;; "Bit-map image objects")
(FNS BITMAPTEDITOBJ COERCETOBITMAP WINDOWTITLEFONT \PRINTBINARYBITMAP \READBINARYBITMAP
)
(* ;; "fns for the bitmap tedit object.")
(FNS BMOBJ.BUTTONEVENTINFN BMOBJ.COPYFN BMOBJ.DISPLAYFN BMOBJ.IMAGEBOXFN BMOBJ.PUTFN
BMOBJ.INIT BMOBJ.GETFN5 BMOBJ.CREATE.MENU)
(INITVARS (*SMALLSCREEN* (ILESSP SCREENWIDTH 700))
(*SMALLSCREENFACTOR* 0.5))
(FNS SCALED.BITMAP.GETFN BMOBJ.GETFN BMOBJ.GETFN2 BMOBJ.GETFN3 BMOBJ.GETFN4)
(* ;
 "GETFNs for backward compatibility with older objects.")
(RECORDS BITMAPOBJ)
[INITVARS (DEFAULT.BITMAP.SCALE '(0.75 (DISPLAY 1]
(* ;; "make ^O be a character that inserts an object read from the user.")
(GLOBALVARS (BITMAP.OBJ.MENU))
(ADDVARS (BackgroundCopyMenuCommands (SNAP (FUNCTION (BITMAPOBJ.SNAPW))
"prompts for an area of the screen to insert."
)
("Snap 50%%" (FUNCTION (BITMAPOBJ.SNAPW 0.5))
"prompts for an area of the screen to insert, scaled down by 50%%."
)
("Snap 50%% & Save" (FUNCTION (BITMAPOBJ.SNAPW 0.5 T))
"prompts for an area of the screen to save in *INSERT-BITMAP*, scaled down by 50."
)
("Insert saved" (FUNCTION (COPYINSERT *INSERT-BITMAP*))
"Inserts *INSERT-BITMAP* in a document"))
(IMAGEOBJGETFNS (BMOBJ.GETFN))
(IMAGEOBJGETFNS (BMOBJ.GETFN2))
(IMAGEOBJGETFNS (BMOBJ.GETFN3))
(IMAGEOBJGETFNS (BMOBJ.GETFN4))
(IMAGEOBJGETFNS (BMOBJ.GETFN5))
(IMAGEOBJGETFNS (SCALED.BITMAP.GETFN)))
(VARS (BackgroundCopyMenu))
(FNS GET.OBJ.FROM.USER BITMAPOBJ.SNAPW PROMPTFOREVALED)
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (BMOBJ.INIT)))
(FILES EDITBITMAP))))
(* ;; "Bit-map image objects")
(DEFINEQ
(BITMAPTEDITOBJ
[LAMBDA (BITMAP SCALEFACTOR ROTATION DESCENT) (* ; "Edited 13-Aug-93 17:17 by rmk:")
(* ; "Edited 6-Jan-89 16:34 by jds")
(* ;;
 "returns the IMAGEOBJ which gives the functional information for a bitmap object in a tedit file.")
(IMAGEOBJCREATE (CREATE BITMAPOBJ
BITMAP _ BITMAP
BMOBJSCALEFACTOR _ (OR SCALEFACTOR 1)
BMOBJROTATION _ (OR ROTATION 0)
BMOBJDESCENT _ (OR DESCENT 0))
BITMAPIMAGEFNS])
(COERCETOBITMAP
[LAMBDA (BMSPEC) (* ; "Edited 11-Jun-90 16:28 by mitani")
(* tries to interpret X as a spec
 for a bitmap.)
(PROG (BM CR)
(RETURN (COND
((BITMAPP BMSPEC)
BMSPEC)
[(LITATOM BMSPEC) (* use value.)
(COND
((BITMAPP (EVALV BMSPEC 'COERCETOBITMAP]
((REGIONP BMSPEC) (* if BMSPEC is a region, treat it
 as a region of the screen.)
[SETQ BM (BITMAPCREATE (fetch (REGION WIDTH) of BMSPEC)
(fetch (REGION HEIGHT) of BMSPEC)
(BITSPERPIXEL (SCREENBITMAP]
(BITBLT (SCREENBITMAP)
(fetch (REGION LEFT) of BMSPEC)
(fetch (REGION BOTTOM) of BMSPEC)
BM 0 0 NIL NIL 'INPUT 'REPLACE)
BM)
((WINDOWP BMSPEC)
[SETQ BM (BITMAPCREATE (WINDOWPROP BMSPEC 'WIDTH)
(WINDOWPROP BMSPEC 'HEIGHT]
(* open the window and bring it to
 the top.)
(TOTOPW BMSPEC)
(SETQ CR (DSPCLIPPINGREGION NIL BMSPEC))
(BITBLT BMSPEC (fetch (REGION LEFT) of CR)
(fetch (REGION BOTTOM) of CR)
BM 0 0 (fetch (REGION WIDTH) of CR)
(fetch (REGION HEIGHT) of CR))
BM])
(WINDOWTITLEFONT
(LAMBDA (FONT) (* rrb " 1-Feb-84 15:26")
(* reset type of function that changes
 the title font)
(DSPFONT FONT WindowTitleDisplayStream)))
(\PRINTBINARYBITMAP
(LAMBDA (BITMAP STREAM) (* rrb "23-Jul-84 15:16")
(* * prints the representation of a bitmap onto STREAM in a form that can be
 read back by \READBINARYBITMAP.)
(PROG ((STREAM (GETSTREAM STREAM 'OUTPUT))
BMH)
(OR (BITMAPP BITMAP)
(\ILLEGAL.ARG BITMAP))
(\WOUT STREAM (BITMAPWIDTH BITMAP))
(\WOUT STREAM (SETQ BMH (BITMAPHEIGHT BITMAP)))
(\WOUT STREAM (BITSPERPIXEL BITMAP))
(\BOUTS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP)
0
(ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)
BMH BYTESPERWORD))
(RETURN BITMAP))))
(\READBINARYBITMAP
(LAMBDA (STREAM) (* rrb "23-Jul-84 15:17")
(* * reads a bitmap printed on STREAM by \PRINTBINARYBITMAP.)
(SETQ STREAM (GETSTREAM STREAM 'INPUT))
(PROG ((BMW (\WIN STREAM))
(BMH (\WIN STREAM))
(BPP (\WIN STREAM))
BITMAP)
(SETQ BITMAP (BITMAPCREATE BMW BMH BPP))
(\BINS STREAM (fetch (BITMAP BITMAPBASE) of BITMAP)
0
(ITIMES (fetch (BITMAP BITMAPRASTERWIDTH) of BITMAP)
BMH BYTESPERWORD))
(RETURN BITMAP))))
)
(* ;; "fns for the bitmap tedit object.")
(DEFINEQ
(BMOBJ.BUTTONEVENTINFN
[LAMBDA (IMAGEOBJ WINDOW SELECTION X Y SELWINDOW TEXTSTREAM BUTTON OPERATION)
(* ; "Edited 14-Aug-93 19:44 by rmk:")
(* ; "Edited 13-Jan-89 17:41 by jds")
(* ;;; "the user has pressed a button inside the bitmap object IMAGEOBJ. Bring up a menu of bitmap edit operations.")
(PROG* ((OBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))
(OLDSCALE (FETCH (BITMAPOBJ BMOBJSCALEFACTOR) OF OBJ))
NEW.BITMAP COMMAND.MENU COMMAND PREVIOUS.BITMAP NAME TEMP X Y)
(COND
([OR (EQ BUTTON 'RIGHT)
(AND OPERATION (NEQ OPERATION 'NORMAL] (* ; " If he's extending a selection, or is selecting for move/copy/delete, DON'T bring up the bitmap editing menu!")
(RETURN)))
(SETQ PREVIOUS.BITMAP (BITMAPCOPY (FETCH (BITMAPOBJ BITMAP) OF OBJ)))
(SETQ NEW.BITMAP
(SELECTQ [MENU (COND
((TYPE? MENU BITMAP.OBJ.MENU)
BITMAP.OBJ.MENU)
(T (SETQ BITMAP.OBJ.MENU (BMOBJ.CREATE.MENU]
(CHANGE.SCALE
(* ;; "Change the scale on the bitmap. Since scale can be a list, might be better to use list-reading instead of string-reading functions, but...")
(LET [(NEWSCALE (COND
((TEDITWINDOWP WINDOW)
(TEDIT.GETINPUT (TEXTOBJ WINDOW)
"Scale Factor: " OLDSCALE))
(T (PROMPTFORWORD "Scale Factor: " OLDSCALE NIL
PROMPTWINDOW]
(IF [AND NEWSCALE [NLSETQ (SETQ NEWSCALE
(READ (OPENSTRINGSTREAM
NEWSCALE
'INPUT]
(NOT (EQUAL NEWSCALE OLDSCALE))
(OR (NUMBERP NEWSCALE)
(AND (NUMBERP (CAR (LISTP NEWSCALE)))
(FOR X IN (CDR NEWSCALE)
ALWAYS (NUMBERP (CADR X]
THEN (REPLACE (BITMAPOBJ BMOBJSCALEFACTOR)
OF OBJ WITH NEWSCALE)
(* ;
 "Return the prevous bitmap, so we don't change the bits.")
PREVIOUS.BITMAP
ELSE (RETURN NIL))))
(HAND.EDIT (EDITBM PREVIOUS.BITMAP))
(TRIM (TRIM.BITMAP PREVIOUS.BITMAP))
(INVERT.HORIZONTALLY
(INVERT.BITMAP.HORIZONTALLY PREVIOUS.BITMAP))
(INVERT.VERTICALLY
(INVERT.BITMAP.VERTICALLY PREVIOUS.BITMAP))
(INVERT.DIAGONALLY
(INVERT.BITMAP.DIAGONALLY PREVIOUS.BITMAP))
(ROTATE.BITMAP.LEFT
(ROTATE.BITMAP.LEFT PREVIOUS.BITMAP))
(ROTATE.BITMAP.RIGHT
(ROTATE.BITMAP.RIGHT PREVIOUS.BITMAP))
(SHIFT.LEFT (INTERACT&SHIFT.BITMAP.LEFT PREVIOUS.BITMAP))
(SHIFT.RIGHT (INTERACT&SHIFT.BITMAP.RIGHT PREVIOUS.BITMAP))
(SHIFT.DOWN (INTERACT&SHIFT.BITMAP.DOWN PREVIOUS.BITMAP))
(SHIFT.UP (INTERACT&SHIFT.BITMAP.UP PREVIOUS.BITMAP))
(INTERCHANGE.BLACK/WHITE
(INVERT.BITMAP.B/W PREVIOUS.BITMAP))
(ADD.BORDER (INTERACT&ADD.BORDER.TO.BITMAP PREVIOUS.BITMAP))
(RETURN NIL)))
(REPLACE (BITMAPOBJ BITMAP) OF OBJ WITH NEW.BITMAP)
(IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP NIL) (* ;
 "And clear any cached shrunk bitmaps so the display looks reasonable.")
(RETURN 'CHANGED])
(BMOBJ.COPYFN
[LAMBDA (IMAGEOBJ) (* ; "Edited 13-Aug-93 17:13 by rmk:")
(* ; "Edited 6-Jan-89 16:19 by jds")
(* ;; "makes a copy of a bitmap image object.")
(LET [(BMOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]
(BITMAPTEDITOBJ (BITMAPCOPY (FETCH (BITMAPOBJ BITMAP) OF BMOBJ))
(FETCH (BITMAPOBJ BMOBJSCALEFACTOR) OF BMOBJ)
(FETCH (BITMAPOBJ BMOBJROTATION) OF BMOBJ)
(FETCH (BITMAPOBJ BMOBJDESCENT) OF BMOBJ])
(BMOBJ.DISPLAYFN
[LAMBDA (IMAGEOBJ IMAGE.STREAM) (* ; "Edited 7-Dec-95 13:20 by ")
(* ; "Edited 13-Aug-93 17:49 by rmk:")
(* ; "Edited 29-Mar-89 18:38 by snow")
(* ;; "Display a bitmap IMAGEOBJ on IMAGE.STREAM. Scales and rotates it if appropriate, and moves it down by DESCENT.")
(DECLARE (GLOBALVARS *SMALLSCREEN* *SMALLSCREENFACTOR*))
(PROG ([FACTOR (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of (IMAGEOBJPROP IMAGEOBJ
'OBJECTDATUM]
[BITMAP (fetch (BITMAPOBJ BITMAP) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]
(CACHE (IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP))
[DESCENT (fetch (BITMAPOBJ BMOBJDESCENT) of (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM]
(STREAM-SCALE (DSPSCALE NIL IMAGE.STREAM))
(STREAMTYPE (IMAGESTREAMTYPE IMAGE.STREAM))
SHRUNK.BITMAP)
(RELMOVETO 0 [IMINUS (FIXR (FTIMES STREAM-SCALE (OR DESCENT 0]
IMAGE.STREAM)
[IF (NUMBERP FACTOR)
ELSEIF (LISTP FACTOR)
THEN (SETQ FACTOR (OR (CADR (ASSOC STREAMTYPE (CDR FACTOR)))
(CAR FACTOR]
(IF (AND *SMALLSCREEN* *SMALLSCREENFACTOR* (GREATERP FACTOR 0.5)
(LEQ FACTOR 1.0)
(EQ 'DISPLAY STREAMTYPE))
THEN
(* ;;
 "Shrink images on small screens, unless they are already small or specified to be big")
(SETQ FACTOR *SMALLSCREENFACTOR*))
(SELECTQ STREAMTYPE
((DISPLAY PRESS)
(* ;; "PRESS and DISPLAY prints the junky shrunk bitmap. This is strange: this presumably should be handled in the device's bitblt method.")
(COND
((NOT (SETQ SHRUNK.BITMAP CACHE))
[COND
[(LEQ FACTOR 1.0) (* ;
 "We're shrinking the bitmap. Create a shrunk image for display")
(SETQ SHRUNK.BITMAP (SHRINKBITMAP BITMAP (FQUOTIENT 1.0 FACTOR)
(FQUOTIENT 1.0 FACTOR]
(T (* ;
 "We're expanding it. Create a bigger one.")
(SETQ SHRUNK.BITMAP (EXPANDBITMAP BITMAP FACTOR FACTOR]
(IMAGEOBJPROP IMAGEOBJ 'CACHED.BITMAP SHRUNK.BITMAP)))
[BITBLT SHRUNK.BITMAP NIL NIL IMAGE.STREAM (DSPXPOSITION NIL IMAGE.STREAM)
(DSPYPOSITION NIL IMAGE.STREAM)
(FIXR (FTIMES FACTOR (BITMAPWIDTH BITMAP)))
(FIXR (FTIMES FACTOR (BITMAPHEIGHT BITMAP])
(PROGN
(* ;; "This is the default case--Call SCALEDBITBLT")
(* ;; "changed OPERATION from PAINT to REPLACE as PAINT doesn't work for all devices. --was. From rmk: if a device can't implement PAINT properly, then IT should coerce to REPLACE. Why is that done here?")
(SCALEDBITBLT BITMAP 0 0 IMAGE.STREAM NIL NIL (BITMAPWIDTH BITMAP)
(BITMAPHEIGHT BITMAP)
'INPUT
'REPLACE NIL NIL FACTOR])
(BMOBJ.IMAGEBOXFN
[LAMBDA (IMAGEOBJ IMAGE.STREAM CURRENT.X RIGHT.MARGIN) (* ; "Edited 7-Dec-95 13:20 by ")
(* ; "Edited 6-Dec-95 15:17 by ")
(* ; "Edited 4-Dec-95 13:35 by ")
(* ; "Edited 4-Dec-95 13:29 by ")
(* ; "Edited 13-Aug-93 17:48 by rmk:")
(* ; "Edited 6-Jan-89 16:35 by jds")
(* ;; "returns an imagebox describing the size of the scaled bitmap")
(DECLARE (GLOBALVARS *SMALLSCREEN* *SMALLSCREENFACTOR*))
(LET* ((BITMAPOBJ (IMAGEOBJPROP IMAGEOBJ 'OBJECTDATUM))
(FACTOR (FETCH (BITMAPOBJ BMOBJSCALEFACTOR) OF BITMAPOBJ))
(BITMAP (FETCH (BITMAPOBJ BITMAP) OF BITMAPOBJ))
(DESCENT (FETCH (BITMAPOBJ BMOBJDESCENT) OF BITMAPOBJ))
(SCALE (DSPSCALE NIL IMAGE.STREAM))
(STREAMTYPE (IMAGESTREAMTYPE IMAGE.STREAM))
WIDTH HEIGHT)
[COND
((EQ BITMAP 'NoneCached)
(SETQ WIDTH (SETQ HEIGHT 5)))
(T [IF (NUMBERP FACTOR)
ELSEIF (LISTP FACTOR)
THEN (SETQ FACTOR (OR (CADR (ASSOC STREAMTYPE (CDR FACTOR)))
(CAR FACTOR]
(IF (AND *SMALLSCREEN* *SMALLSCREENFACTOR* (GREATERP FACTOR 0.5)
(LEQ FACTOR 1.0)
(EQ 'DISPLAY STREAMTYPE))
THEN
(* ;;
 "Shrink images on small screens, unless they are already small or specified to be big")
(SETQ FACTOR *SMALLSCREENFACTOR*))
[SETQ WIDTH (FIXR (FTIMES SCALE (TIMES (BITMAPWIDTH BITMAP)
FACTOR]
(SETQ HEIGHT (FIXR (FTIMES SCALE (TIMES (BITMAPHEIGHT BITMAP)
FACTOR]
(CREATE IMAGEBOX
XSIZE _ WIDTH
YSIZE _ HEIGHT
YDESC _ (OR DESCENT 0)
XKERN _ 0])
(BMOBJ.PUTFN
[LAMBDA (BMOBJ STREAM) (* ; "Edited 13-Aug-93 15:41 by rmk:")
(* ; "Edited 11-Jan-89 17:00 by jds")
(* ;; "Put a description of a bitmap object into the file, including all fields as s-expressions. To be read by BMOBJ.GETFN5")
(LET* [(BITMAPOBJ (IMAGEOBJPROP BMOBJ 'OBJECTDATUM]
(\PRINTBINARYBITMAP (fetch (BITMAPOBJ BITMAP) of BITMAPOBJ)
STREAM)
(PRIN2 (fetch (BITMAPOBJ BMOBJSCALEFACTOR) of BITMAPOBJ)
STREAM FILERDTBL)
(SPACES 1 STREAM)
(PRIN2 (fetch (BITMAPOBJ BMOBJROTATION) of BITMAPOBJ)
STREAM FILERDTBL)
(SPACES 1 STREAM)
(PRIN2 (fetch (BITMAPOBJ BMOBJDESCENT) of BITMAPOBJ)
STREAM FILERDTBL)
(SPACES 1 STREAM])
(BMOBJ.INIT
[LAMBDA NIL (* ; "Edited 13-Aug-93 14:27 by rmk:")
(* ; "Edited 11-Jan-89 17:01 by jds")
(* ;;
 "returns the function vector which gives the functional information for a bitmap image object.")
(SETQ BITMAPIMAGEFNS (IMAGEFNSCREATE (FUNCTION BMOBJ.DISPLAYFN)
(FUNCTION BMOBJ.IMAGEBOXFN)
(FUNCTION BMOBJ.PUTFN)
(FUNCTION BMOBJ.GETFN5)
(FUNCTION BMOBJ.COPYFN)
(FUNCTION BMOBJ.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL])
(BMOBJ.GETFN5
[LAMBDA (INPUT.STREAM TEXTSTREAM) (* ; "Edited 13-Aug-93 15:40 by rmk:")
(* jds "30-Oct-85 11:29")
(* ; "reads in a scaled bitmap object with readbitmap and read. Gets scale, rotation, and descent as arbitrary s-expressions")
(BITMAPTEDITOBJ (\READBINARYBITMAP INPUT.STREAM)
(READ INPUT.STREAM FILERDTBL)
(READ INPUT.STREAM FILERDTBL)
(READ INPUT.STREAM FILERDTBL])
(BMOBJ.CREATE.MENU
[LAMBDA NIL (* ; "Edited 30-Jul-87 19:19 by jds")
(* ;; "Creates the menu that comes up when you button in a bitmap image object.")
(create MENU
TITLE _ "Operations on bitmaps"
ITEMS _ '((Change% Scale 'CHANGE.SCALE "Changes the scale factor used at output time.")
(Hand% Edit 'HAND.EDIT "Starts the bitmap editor on this bitmap.")
(Trim 'TRIM "removes the white space from the edges of the bitmap.")
(Reflect% Left-to-right 'INVERT.HORIZONTALLY
"inverts the bitmap about the vertical midline.")
(Reflect% Top-to-bottom 'INVERT.VERTICALLY
"inverts the bitmap about the horizontal midline.")
(Reflect% Diagonally 'INVERT.DIAGONALLY
"inverts the bitmap about the lower left to upper right diagonal.")
(Rotate% Left 'ROTATE.BITMAP.LEFT
"rotates the bitmap 90 degrees counter-clockwise.")
(Rotate% Right 'ROTATE.BITMAP.RIGHT "rotates the bitmap 90 degrees clockwise.")
(|Expand on Right| 'SHIFT.LEFT
"prompts for a number of bits to add on the right.")
(|Expand on Left| 'SHIFT.RIGHT
"prompts for a number of bits to add on the left.")
(|Expand on Bottom| 'SHIFT.UP "prompts for a number of bits to add on the top.")
(|Expand on Top| 'SHIFT.DOWN
"prompts for a number of bits to add on the bottom.")
(|Switch Black & White| 'INTERCHANGE.BLACK/WHITE
"changes all black bits to white and all white bits to black.")
(Add% Border 'ADD.BORDER "adds an arbitrary border in an arbitrary shade."))
CENTERFLG _ T
CHANGEOFFSETFLG _ 'Y
MENUOFFSET _ (create POSITION
XCOORD _ -1
YCOORD _ 0])
)
(RPAQ? *SMALLSCREEN* (ILESSP SCREENWIDTH 700))
(RPAQ? *SMALLSCREENFACTOR* 0.5)
(DEFINEQ
(SCALED.BITMAP.GETFN
(LAMBDA (INPUT.STREAM TEXTSTREAM) (* jds "30-Oct-85 11:29")
(* reads in a scaled bitmap object with readbitmap and read)
(PROG (FACTOR BITMAP)
(SETQ BITMAP (READBITMAP INPUT.STREAM))
(SETQ FACTOR (READ INPUT.STREAM))
(RETURN (BITMAPTEDITOBJ BITMAP (FQUOTIENT 1.0 FACTOR)
0)))))
(BMOBJ.GETFN
(LAMBDA (STREAM) (* rrb "17-Jul-84 11:46")
(* this is an old version of the get function for bitmap image objects.
 It is left around so old tedit documents will still work.
 |17/7/84|)
(RESETFORM (INPUT STREAM)
(PROG ((FIELDS (READ STREAM))
(BITMAP (READBITMAP)))
(RETURN (BITMAPTEDITOBJ BITMAP (CAR FIELDS)
(CADR FIELDS)))))))
(BMOBJ.GETFN2
(LAMBDA (STREAM) (* rrb "17-Jul-84 11:29")
(* * reads a bitmap image object from a file.
 This version stores the binary data rather than the character representation
 used by READBITMAP.)
(PROG ((SCALE (\WIN STREAM))
(ROT (\WIN STREAM)))
(RETURN (BITMAPTEDITOBJ (\READBINARYBITMAP STREAM)
SCALE ROT)))))
(BMOBJ.GETFN3
[LAMBDA (STREAM) (* ; "Edited 11-Jan-89 17:03 by jds")
(* ;;; "reads a bitmap image object from a file. This version stores the binary data rather than the character representation used by READBITMAP.")
(COND
((IEQP (\PEEKBIN STREAM)
(CHARCODE CR)) (* ;
 "This is an old-format sketch with bitmap included. Skip the interfering CR.")
(BIN STREAM)))
(PROG ((SCALE (FPLUS (\WIN STREAM)
(FQUOTIENT (\WIN STREAM)
32768)))
(DESC (\WIN STREAM)))
(RETURN (BITMAPTEDITOBJ (\READBINARYBITMAP STREAM)
SCALE 0 DESC])
(BMOBJ.GETFN4
[LAMBDA (STREAM) (* ; "Edited 6-Jan-89 16:33 by jds")
(* ;;; "reads a bitmap image object from a file. This version stores the binary data rather than the character representation used by READBITMAP.")
(COND
((IEQP (\PEEKBIN STREAM)
(CHARCODE CR)) (* ;
 "This is an old-format sketch with bitmap included. Skip the interfering CR.")
(BIN STREAM)))
(LET ((SCALE (FPLUS (\WIN STREAM)
(FQUOTIENT (\WIN STREAM)
32768)))
(ROT (\WIN STREAM))
(DESCENT (\WIN STREAM)))
(* ;; "Dummy words for later expansion:")
(\WIN STREAM)
(\WIN STREAM)
(\WIN STREAM)
(\WIN STREAM)
(* ;; "Now read the bitmap itself and construct the object:")
(BITMAPTEDITOBJ (\READBINARYBITMAP STREAM)
SCALE ROT DESCENT])
)
(* ; "GETFNs for backward compatibility with older objects.")
(DECLARE%: EVAL@COMPILE
(RECORD BITMAPOBJ (
(* ;; "Describes a bitmap imageobj")
BITMAP (* ; "The bitmap itself")
BMOBJSCALEFACTOR (* ;
 "The factor to scale it by when displaying")
BMOBJROTATION (* ;
 "A rotation to apply when displaying")
BMOBJDESCENT (* ;
 "How far below the base line to display it. NIL => 0.")
))
)
(RPAQ? DEFAULT.BITMAP.SCALE '(0.75 (DISPLAY 1)))

1
library/INIT.MAIKO Normal file
View File

@@ -0,0 +1 @@
;; Copyright (c) 1988, 1989 Envos & Fuji Xerox

1
library/INIT.NONET Normal file
View File

@@ -0,0 +1 @@
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")

1
library/INIT.SAMPLE Normal file
View File

@@ -0,0 +1 @@
(DEFINE-FILE-INFO §READTABLE "INTERLISP" §PACKAGE "INTERLISP")

1
library/KEYBOARDCONFIGS Normal file
View File

File diff suppressed because one or more lines are too long

438
library/KEYBOARDEDITOR Normal file
View File

File diff suppressed because one or more lines are too long

1
library/LLCOLOR Normal file
View File

File diff suppressed because one or more lines are too long

1
library/MAIKOCOLOR Normal file
View File

File diff suppressed because one or more lines are too long

1
library/MAIKOKEYBOARDS Normal file
View File

File diff suppressed because one or more lines are too long

1
library/MASTERSCOPE Normal file
View File

File diff suppressed because one or more lines are too long

1
library/MATCH Normal file
View File

File diff suppressed because one or more lines are too long

1
library/MATMULT Normal file
View File

File diff suppressed because one or more lines are too long

1
library/MINISERVE Normal file
View File

File diff suppressed because one or more lines are too long

1
library/MSANALYZE Normal file
View File

File diff suppressed because one or more lines are too long

1
library/MSCOMMON Normal file
View File

File diff suppressed because one or more lines are too long

1
library/MSPARSE Normal file
View File

File diff suppressed because one or more lines are too long

1
library/NSCHAT Normal file
View File

File diff suppressed because one or more lines are too long

366
library/NSMAINTAIN Normal file
View File

@@ -0,0 +1,366 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 8-Jan-92 10:57:28" "{piglet/n}<piglet>vanmelle>lispusers>NSMAINTAIN.;32" 69479
changes to%: (FNS \NSMT.DESCRIBE.OBJECT) (VARS NSMAINTAINCOMS)
previous date%: "17-Sep-91 14:31:41" "{piglet/n}<piglet>vanmelle>lispusers>NSMAINTAIN.;30")
(* ; "
Copyright (c) 1985, 1986, 1987, 1989, 1990, 1991, 1992 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT NSMAINTAINCOMS)
(RPAQQ NSMAINTAINCOMS ((COMS (* ; "Main entry and utility fns") (FNS NSMAINTAIN \NSMT.INITIAL.LOGIN \NSMT.HELP \NSMT.READFNAME \NSMT.LOOKUP \NSMT.LOOKUP1 \NSMT.CHECK.DOMAIN \NSMT.DOMAIN.MAY.EXIST \NSMT.FOREIGN.DOMAINP \NSMT.COLLECT.NAMES \NSMT.GET.REMARK \NSMT.GET.PASSWORD \NSMT.LOGIN \NSMT.GETAUTHENTICATOR \NSMT.CHANGE.DOMAIN \NSMT.PRINT.LIST \NSMT.PRINT.OBJECTS \NSMT.PROCESS.LIST \NSMT.READ.COMMA.LIST \NSMT.SHOW.RESULT \NSMT.CHOOSE \NSMT.COURIER.OPEN \NSMT.CLEAR.CACHE EQUAL.NSADDRESS)) (COMS (* ; "Ordinary user commands") (FNS \NSMT.CHANGE.PASSWORD \NSMT.DESCRIBE.ACL \NSMT.DESCRIBE.OBJECT \NSMT.DESCRIPTIVE.PROPS \NSMT.DESCRIBE.PROPERTY \NSMT.PRETTY.PROPERTY \NSMT.LIST.OBJECTS \NSMT.LIST.CLEARINGHOUSES \NSMT.LIST.SERVERS \NSMT.SHOW.DETAILS \NSMT.GROUP.FILTER \NSMT.LIST.ADMINISTRATORS \NSMT.FETCH.ADMINISTRATORS \NSMT.FETCH.ADMINISTRATORS1 \NSMT.LIST.DOMAINS \NSMT.TYPE.ENTRY \NSMT.TYPE.MEMBERS \NSMT.UNCACHE \NSMT.CLEAR.NAME.CACHE)) (COMS (* ; "Administrator commands") (FNS \NSMT.ADD.ALIAS \NSMT.ADD.GROUP \NSMT.SET.INITIAL.ACL \NSMT.ADD.USER \NSMT.ADD.OBJECT \NSMT.CREATE.OBJECT \NSMT.ADD.OBJECT.GENERIC \NSMT.CHANGE.ADDRESS \NSMT.CHANGE.ADMINISTRATORS \NSMT.CHANGE.FORWARDING \NSMT.CHANGE.GROUP.COMPONENT \NSMT.CHANGE.REMARK \NSMT.GET.OBJECT.TYPE \NSMT.REMOVE.ALIAS \NSMT.REMOVE.OBJECT \NSMT.REMOVE.USER)) (FILES (SYSLOAD) DES AUTHENTICATION) (COMS (* ; "Patch to clearinghouse") (FNS CH.FINDSERVER)) (VARS *NSMAINTAIN-COMMANDS* *NSMAINTAIN-ABORT-ITEM*) (ADDVARS (CH.PROPERTIES (ALIAS 1) (BOOT.SERVICE 10026)) (*NSMAINTAIN-DESCRIPTIVE-PROPERTIES* 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10026) (*NSMAINTAIN-IGNORE-PROPERTIES* 6 7 10027 20003 20002 20101) (*NSMAINTAIN-PROPERTY-FORMATS* (4 CLEARINGHOUSE . NETWORK.ADDRESS.LIST) (8 RECORD (SIMPLE BOOLEAN) (STRONG BOOLEAN)) (30 . NSNAME) (31 CLEARINGHOUSE . MAILBOX.VALUES) (10000 . STRING) (10001 . STRING) (10002 . STRING) (10003 . STRING) (10004 . STRING) (10005 . STRING) (10006 . STRING) (10007 . STRING) (10008 . STRING) (10009 . STRING) (10010 . STRING) (10011 . STRING) (10012 . STRING) (10013 . STRING) (10014 . STRING) (10015 . STRING) (10016 . STRING) (10017 . STRING) (10018 . STRING) (10019 . STRING) (10020 . STRING) (10021 . STRING) (10022 . STRING) (10023 . STRING) (10024 . STRING) (10026 . STRING) (10029 . STRING) (10030 . STRING) (10032 . STRING) (10034 . STRING) (10035 . STRING) (15002 . STRING) (20000 CLEARINGHOUSE . USERDATA.VALUE) (20001 GAP . RS232CData) (20006 SEQUENCE NSNAME) (20007 . NSNAME) (20102 GAP . RS232CBack) (29965 . STRING) (30005 . NSNAME)) (*NSMAINTAIN-MEMBER-PROPERTIES* 3 20006)) (INITVARS (*NSMAINTAIN-MEMBER-THRESHOLD* 3) (*NSMAINTAIN-SHOW-GROUP-ACCESS*)) (DECLARE%: EVAL@COMPILE (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *NSMAINTAIN-MEMBER-THRESHOLD* *NSMAINTAIN-SHOW-GROUP-ACCESS*))) (CL:PROCLAIM (QUOTE (GLOBAL *NSMAINTAIN-MEMBER-PROPERTIES* *NSMAINTAIN-PROPERTY-FORMATS* *NSMAINTAIN-IGNORE-PROPERTIES* *NSMAINTAIN-DESCRIPTIVE-PROPERTIES*)))) DONTCOPY (FUNCTIONS WITH-CHS) (FILES (LOADCOMP) CLEARINGHOUSE) (* ; "Get optimizer for CH.PROPERTY") (CONSTANTS \CH.BROADCAST.SOCKET) (GLOBALVARS *NSMAINTAIN-COMMANDS* *NSMAINTAIN-ABORT-ITEM* CH.PROPERTIES) (P (CL:PROCLAIM (QUOTE (CL:SPECIAL *USER* *LASTDOMAIN* *LASTNAME* *LASTGROUP* *LASTLIST* *LASTSTRING* *LAST-MEMBERSHIP* *SERVERTYPES* *ALLTYPES* *OBJECTTYPES* *DEFAULTDOMAIN* *REAL-NAME-CACHE* *DOMAIN*)))) (LOCALVARS . T) (* ;; "For masterscope") (VARS (*NSMT-MENU-FNS* (CL:REMOVE-DUPLICATES (FOR ENTRY IN *NSMAINTAIN-COMMANDS* WHEN (LISTP (SETQ ENTRY (CADR (MEMB (QUOTE RETURN) ENTRY)))) COLLECT (IF (EQ (CAR ENTRY) (QUOTE FUNCTION)) THEN (CADR ENTRY) ELSEIF (EQ (CAR ENTRY) (QUOTE QUOTE)) THEN (CAR (LISTP (CADR ENTRY)))))))))))
(* ; "Main entry and utility fns")
(DEFINEQ
(NSMAINTAIN
(LAMBDA NIL (* ; "Edited 21-Nov-90 12:38 by bvm") (PROG ((*STANDARD-OUTPUT* (PROGN (* ; "Make sure T for FORMAT and PRINTOUT are the same (yecch).") (\GETSTREAM T (QUOTE OUTPUT)))) (*REAL-NAME-CACHE* (HASHARRAY 10 NIL (FUNCTION (LAMBDA (OBJECT) (* ; "Use first part of name to produce hash bits") (STRING-EQUAL-HASHBITS (fetch NSOBJECT of OBJECT)))) (FUNCTION EQUAL.CH.NAMES))) *USER* *LASTNAME* *DEFAULTDOMAIN* *LASTDOMAIN* *LASTGROUP* *LASTSTRING* *LASTLIST* *LAST-MEMBERSHIP* *SERVERTYPES* *ALLTYPES* *OBJECTTYPES* ORIG-USER PASS) (* ;; "*REAL-NAME-CACHE* entries are of several possible forms:") (* ;; "1) Ordinary ns name. Value is distinguished name, or :NONE if no such object.") (* ;; "2) org:*:*. Value :OK => org is legal. :NONE => no such org") (* ;; "3) domain:org:*. Same as 2, plus value :FOREIGN => domain:org is a known gatewayed domain.") (* ;; "4) *:domain:org. Value is list of domain administrators.") (\NSMT.INITIAL.LOGIN) (SETQ ORIG-USER *USER*) (do (TERPRI T) repeatwhile (NULL (ERSETQ (bind CMD while (SETQ CMD (ASKUSER NIL NIL "CH: " *NSMAINTAIN-COMMANDS* T NIL (QUOTE (AUTOCOMPLETEFLG T)))) do (COND ((LISTP CMD) (APPLY (CAR CMD) (CDR CMD))) (T (CL:FUNCALL CMD))) (TERPRI T))))) (if (AND (NOT (EQUAL.CH.NAMES *USER* ORIG-USER)) (CL:Y-OR-N-P "Note: ~A is currently logged in. Restore login to ~A? " *USER* ORIG-USER)) then (SETPASSWORD (QUOTE |NS::|) (NSNAME.TO.STRING ORIG-USER T) (PROMPTFORWORD "Password: " NIL NIL T (QUOTE *))))))
)
(\NSMT.INITIAL.LOGIN
(LAMBDA NIL (* ; "Edited 14-Nov-90 17:12 by bvm") (* ;; "Get user to log in if necessary, and set *USER*, *LASTNAME*, *LASTDOMAIN*, *DEFAULTDOMAIN* appropriately") (LET* ((CREDS (\INTERNAL/GETPASSWORD (QUOTE |NS::|))) (FULLNAME (\NSMT.LOOKUP1 (SETQ *USER* (PARSE.NSNAME (CAR CREDS))))) (BADP (CASE FULLNAME (:NONE (SETQ FULLNAME NIL) "not a valid name") ((NIL) "no verification from Clearinghouse") (T NIL)))) (CL:FORMAT T "[Default login: ~A~@[ (~A)~];~%% Default domain: ~A]~%%" (NSNAME.TO.STRING (OR FULLNAME *USER*) T) BADP (NSNAME.TO.STRING (SETQ *LASTDOMAIN* (SETQ *DEFAULTDOMAIN* (create NSNAME NSDOMAIN _ CH.DEFAULT.DOMAIN NSORGANIZATION _ CH.DEFAULT.ORGANIZATION))) T)) (if (AND (SETQ *LASTNAME* FULLNAME) (NOT (EQUAL.CH.NAMES *USER* FULLNAME))) then (* ; "Canonical name different from current login, so be helpful and canonize") (RPLACA CREDS (NSNAME.TO.STRING (SETQ *LASTNAME* (SETQ *USER* FULLNAME)) T)))))
)
(\NSMT.HELP
(LAMBDA NIL (* ; "Edited 21-Aug-89 18:14 by bvm") (* ;; "Give more compact help than ASKUSER's default") (PRINTOUT T T T " You need type only the initial letters of most command words.
Use Control-E to abort a command." T T) (LET ((LINELEN (LINELENGTH NIL T)) *LASTSTRING* LASTN EXPLAINSTRING UNPRINTED CMD LEN TAB) (for ITEM in *NSMAINTAIN-COMMANDS* unless (EQ (CHCON1 (SETQ CMD (CAR ITEM))) (CHARCODE ?)) do (* ; "Handle all commands but ?") (if (AND (NOT (SETQ EXPLAINSTRING (LISTGET ITEM (QUOTE EXPLAINSTRING)))) *LASTSTRING* (> (SETQ LEN (NCHARS CMD)) LASTN) (STRING-EQUAL *LASTSTRING* CMD :END1 LASTN :END2 LASTN)) then (* ; "This command has same prefix as previous one") (if UNPRINTED then (PRINTOUT T (SUBSTRING *LASTSTRING* 1 LASTN) "{" (SUBSTRING *LASTSTRING* (ADD1 LASTN))) (SETQ UNPRINTED NIL) (SETQ TAB (ADD1 (POSITION T))) (* ; "An aesthetically pleasing tab stop puts command directly under next command")) (PRIN1 "," T) (if (> (+ (POSITION T) (- LEN LASTN) 3) LINELEN) then (* ; "No room left on this line, so tab to reasonable place.") (TERPRI T) (TAB TAB NIL T)) (PRIN1 (SUBSTRING CMD LASTN) T) else (* ; "New prefix.") (if *LASTSTRING* then (* ; "Clean up previous command") (PRINTOUT T (if UNPRINTED then *LASTSTRING* else "}") T)) (if EXPLAINSTRING then (* ; "Explicit thing here for ?") (PRINTOUT T EXPLAINSTRING T) (SETQ *LASTSTRING* NIL) elseif (SETQ LASTN (STRPOS " " CMD)) then (SETQ *LASTSTRING* CMD) (SETQ UNPRINTED T) else (PRINTOUT T CMD T) (SETQ *LASTSTRING* NIL)))) (if *LASTSTRING* then (* ; "Take care of the last line") (PRINTOUT T (if UNPRINTED then *LASTSTRING* else "}") T))))
)
(\NSMT.READFNAME
(LAMBDA (PROMPT DEFAULT DOMAINFLG ...FLG CHECK *OK) (* ; "Edited 14-Nov-90 17:09 by bvm") (* ;; "Prompt for a name with PROMPT, offering DEFAULT. If DOMAINFLG is true, we expect a domain (2-part name), else a 3-part name. If ...FLG is true, print ... after successfully reading name.") (* ;; "CHECK controls whether we verify the name: NIL=don't; :OK=do, but happily accept anything; :CONFIRM=require confirmation if bad name; :FOREIGN=accept names in foreign domains, otherwise like :CONFIRM; T=must be valid name.") (* ;; "*OK controls whether * is ok in any component: NIL=no; T=ok in first component only; :ANY=yes.") (PROG ((COLON ":") NAME COLPOS FULLNAME REALNAME) RETRY (if (NULL (SETQ NAME (PROMPTFORWORD PROMPT (COND ((AND DEFAULT (TYPENAMEP DEFAULT (QUOTE NSNAME))) (* ; "Make it fully qualified") (NSNAME.TO.STRING DEFAULT T)) (T DEFAULT)) NIL T NIL NIL (CHARCODE (EOL))))) then (printout T " xxx" T) (* ; "aborted") (RETURN NIL)) (SETQ FULLNAME (if (AND (SETQ COLPOS (STRPOS COLON NAME)) (NEQ COLPOS (NCHARS NAME))) then (SETQ COLPOS (STRPOS COLON NAME (ADD1 COLPOS))) (* ; "Find second colon") (if DOMAINFLG then (* ; "Wants domain name--a 2-part name") (if COLPOS then (* ; "too many colons") (PRINTOUT T " Invalid domain" T) (RETURN NIL) else (PARSE.NSNAME NAME 2 *DEFAULTDOMAIN*)) else (if (NOT COLPOS) then (* ; "Org defaulted") (printout T COLON (fetch NSORGANIZATION of *DEFAULTDOMAIN*)) elseif (EQ COLPOS (NCHARS NAME)) then (* ; "Trailing colon after domain") (printout T (fetch NSORGANIZATION of *DEFAULTDOMAIN*))) (PARSE.NSNAME NAME 3 *DEFAULTDOMAIN*)) else (* ; "Completely unqualified (or only a trailing colon)") (if COLPOS then (* ; "User typed, e.g., %"Fred:%"") (SETQ NAME (SUBSTRING NAME 1 -2)) else (PRIN1 COLON T)) (if DOMAINFLG then (printout T (fetch NSORGANIZATION of *DEFAULTDOMAIN*)) (create NSNAME using *DEFAULTDOMAIN* NSDOMAIN _ NAME) else (printout T (fetch NSDOMAIN of *DEFAULTDOMAIN*) COLON (fetch NSORGANIZATION of *DEFAULTDOMAIN*)) (create NSNAME using *DEFAULTDOMAIN* NSOBJECT _ NAME)))) (if (STRPOS "*" NAME) then (if (CASE *OK (:ANY (* ; "Any old * is ok") NIL) ((NIL) (* ; "No * is ok") T) (T (* ; "* permitted in first part only") (OR (STRPOS "*" (fetch NSORGANIZATION of FULLNAME)) (AND (NOT DOMAINFLG) (STRPOS "*" (fetch NSDOMAIN of FULLNAME)))))) then (PRINTOUT T " ... Invalid use of *" T) (SETQ DEFAULT FULLNAME) (GO RETRY)) elseif CHECK then (* ; "Canonicalize the name") (SETQ REALNAME (\NSMT.LOOKUP FULLNAME (EQ CHECK :FOREIGN))) (if (NULL REALNAME) then (if (NOT (CASE CHECK (:OK (* ; "Accept it regardless") T) ((:FOREIGN :CONFIRM) (* ; "Accept with confirmation") (CL:Y-OR-N-P " Use it anyway? ")) (T (* ; "Must be valid name") (TERPRI T) NIL))) then (SETQ DEFAULT FULLNAME) (GO RETRY)) else (SETQ FULLNAME REALNAME))) (COND (...FLG (PRIN1 " ... " T))) (RETURN FULLNAME)))
)
(\NSMT.LOOKUP
(LAMBDA (NAME FOREIGNOK) (* ; "Edited 14-Nov-90 17:20 by bvm") (* ;; "Like CH.LOOKUP.OBJECT but caches results (well, at least the positive ones). Also prints out message if it couldn't find name or name was an alias") (OR (TYPEP NAME (QUOTE NSNAME)) (SETQ NAME (PARSE.NSNAME NAME))) (PROG ((CACHE (GETHASH NAME *REAL-NAME-CACHE*)) FULLNAME) (if CACHE then (SETQ FULLNAME CACHE) else (CASE (\NSMT.CHECK.DOMAIN NAME) ((:OK NIL) (if (SETQ FULLNAME (\NSMT.LOOKUP1 NAME)) then (PUTHASH NAME FULLNAME *REAL-NAME-CACHE*))) (:NONE (RETURN NIL)) (:FOREIGN (RETURN (AND FOREIGNOK NAME))))) (if (NULL FULLNAME) then (PRINTOUT T " (couldn't verify name)") elseif (EQ FULLNAME :NONE) then (PRINTOUT T " (non-existent name)") (SETQ FULLNAME NIL) elseif (NOT (EQUAL.CH.NAMES FULLNAME NAME)) then (printout T " = " (NSNAME.TO.STRING FULLNAME T))) (RETURN FULLNAME)))
)
(\NSMT.LOOKUP1
(LAMBDA (NAME) (* ; "Edited 14-Nov-90 16:34 by bvm") (* ;;; "Returns the canonical name of the specified object, :none if it doesn't exist, nil if we couldn't figure it out (because of chs problem)") (LET ((ADDRESS (CH.FINDSERVER NAME T)) RESULT) (if (NOT ADDRESS) then NIL elseif (NLISTP (SETQ RESULT (COURIER.EXPEDITED.CALL ADDRESS \CH.BROADCAST.SOCKET (QUOTE CLEARINGHOUSE) (QUOTE LOOKUP.OBJECT) NAME (CH.GETAUTHENTICATOR) (QUOTE RETURNERRORS)))) then RESULT elseif (EQ (CADDR (LISTP RESULT)) (QUOTE NoSuchObject)) then :NONE else NIL)))
)
(\NSMT.CHECK.DOMAIN
(LAMBDA (NAME) (* ; "Edited 14-Nov-90 17:44 by bvm") (* ;; "See whether name is in a valid domain. Returns :ok, :none, :foreign, or nil if it can't figure out right now. We do all this because the Lisp chs interface doesn't let us find out in any detail why an operation failed. Also, it's silly to keep getting prompt messages about a non-existent domain, when we can certainly cache the answers.") (PROG* ((ORG (fetch NSORGANIZATION of NAME)) (TEST (create NSNAME NSOBJECT _ ORG NSDOMAIN _ "*" NSORGANIZATION _ "*")) (RESULT (GETHASH TEST *REAL-NAME-CACHE*)) ORGCACHE) (if (NOT RESULT) then (* ;; "See if the org exists. First check the chs cache, which is faster than asking a chs.") (CASE (OR (SETQ ORGCACHE (\CH.FIND.ORG.SERVER ORG T T)) (SETQ RESULT (\NSMT.LOOKUP1 (create NSNAME using TEST NSDOMAIN _ "CHServers" NSORGANIZATION _ "CHServers")))) (:NONE) ((NIL) (* ; "punt") (RETURN NIL)) (T (SETQ RESULT :OK))) (* ; "And cache the result, copying the test object (which is ordinarily smashed further below)") (PUTHASH (create NSNAME using TEST) RESULT *REAL-NAME-CACHE*)) (if (NEQ RESULT :OK) then (printout T " (no such organization)") (RETURN RESULT)) (* ;; "Ok, the org exists, shift right one") (replace NSDOMAIN of TEST with (fetch NSOBJECT of TEST)) (replace NSOBJECT of TEST with (fetch NSDOMAIN of NAME)) (SETQ RESULT (GETHASH TEST *REAL-NAME-CACHE*)) (if (NOT RESULT) then (* ;; "See if the domain exists") (CASE (OR (AND (OR ORGCACHE (\CH.FIND.ORG.SERVER ORG T T)) (CL:ASSOC (fetch NSDOMAIN of NAME) (CDDR ORGCACHE) :TEST (QUOTE STRING-EQUAL))) (SETQ RESULT (\NSMT.LOOKUP1 (create NSNAME using TEST NSORGANIZATION _ "CHServers")))) (:NONE (if (NOT (SETQ RESULT (\NSMT.FOREIGN.DOMAINP NAME))) then (* ; "punt") (RETURN NIL))) ((NIL) (* ; "punt") (RETURN NIL)) (T (SETQ RESULT :OK))) (* ; "And cache the result") (PUTHASH TEST RESULT *REAL-NAME-CACHE*)) (if (NEQ RESULT :OK) then (printout T " (" (if (EQ RESULT :FOREIGN) then "foreign" else "no such") " domain)")) (RETURN RESULT)))
)
(\NSMT.DOMAIN.MAY.EXIST
(LAMBDA (DOMAIN) (* ; "Edited 14-Nov-90 18:03 by bvm") (CASE (\NSMT.CHECK.DOMAIN DOMAIN) ((NIL :OK) T)))
)
(\NSMT.FOREIGN.DOMAINP
(LAMBDA (NAME) (* ; "Edited 14-Nov-90 16:51 by bvm") (* ;; "Returns :foreign, :none, nil depending on whether name specifies a foreign domain, simply nonexistent domain, or we couldn't find out") (LET* ((OBJ (create NSNAME NSOBJECT _ (CONCAT (fetch NSDOMAIN of NAME) (fetch NSORGANIZATION of NAME)) NSDOMAIN _ "..." NSORGANIZATION _ "...")) (RESULT (\NSMT.LOOKUP1 OBJ))) (CASE RESULT ((:NONE NIL) RESULT) (T (* ;; "The object domainorganization:...:... exists. Now retrieve the property that verifies that it's this domain and org, rather than some other concatenation.") (LET ((ADDRESS (CH.FINDSERVER RESULT T)) VALUE) (if (AND ADDRESS (LISTP (SETQ VALUE (COURIER.EXPEDITED.CALL ADDRESS \CH.BROADCAST.SOCKET (QUOTE CLEARINGHOUSE) (QUOTE RETRIEVE.ITEM) RESULT (CH.PROPERTY (QUOTE FOREIGNMAILSYSTEMNAME)) (CH.GETAUTHENTICATOR) (QUOTE RETURNERRORS))))) then (if (NEQ (CAR VALUE) (QUOTE ERROR)) then (SETQ VALUE (COURIER.READ.REP (CADR VALUE) (QUOTE CLEARINGHOUSE) (QUOTE NSNAME))) (if (AND (STRING-EQUAL (fetch NSDOMAIN of NAME) (fetch NSDOMAIN of VALUE)) (STRING-EQUAL (fetch NSORGANIZATION of NAME) (fetch NSORGANIZATION of VALUE))) then :FOREIGN else :NONE) elseif (EQ (CADDR VALUE) (QUOTE Missing)) then :NONE)))))))
)
(\NSMT.COLLECT.NAMES
(LAMBDA (PROMPT CHECK *OK) (* ; "Edited 14-Aug-87 15:14 by bvm:") (* ;; "Prompt for an arbitrary number of names. CHECK and *OK are the corresponding args to \nsmt.readfname.") (bind NAME while (SETQ NAME (PROGN (TERPRI T) (\NSMT.READFNAME PROMPT NIL NIL NIL CHECK *OK))) collect NAME))
)
(\NSMT.GET.REMARK
(LAMBDA (DEFAULT) (* ; "Edited 11-Aug-87 12:24 by bvm:") (* ;; "Prompt for a remark (an arbitrary string used to describe an object). DEFAULT if any is usually the previous remark.") (PROMPTFORWORD "Remark (terminate with CR):" DEFAULT NIL T NIL NIL (CHARCODE (CR))))
)
(\NSMT.GET.PASSWORD
(LAMBDA (PROMPT) (* ; "Edited 11-Aug-87 13:39 by bvm:") (* ;; "Read a password, prompting with PROMPT. Ask user to retry password to verify that it was typed correctly. Loop if the retype mismatches the original. Return NIL if user declines to enter a password in the first place.") (PROG (PASS) LP (COND ((NULL (SETQ PASS (PROMPTFORWORD PROMPT NIL NIL T (QUOTE *)))) (RETURN NIL)) ((STREQUAL PASS (PROMPTFORWORD " (retype password)" NIL NIL T (QUOTE *))) (RETURN PASS)) (T (PRINTOUT T T "Mismatch. Try again." T) (SETQ PROMPT "Password:") (GO LP)))))
)
(\NSMT.LOGIN
(LAMBDA NIL (* ; "Edited 14-Nov-90 17:13 by bvm") (bind LOGINFO FULLNAME until (OR (NULL (SETQ LOGINFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|) T))) (COND ((AND (SETQ FULLNAME (\NSMT.LOOKUP1 (SETQ *USER* (PARSE.NSNAME (CAR LOGINFO) 3 *DEFAULTDOMAIN*)))) (NEQ FULLNAME :NONE)) (RPLACA LOGINFO (NSNAME.TO.STRING (SETQ *USER* FULLNAME) T)) (* ; "Make login canonical") (\NSMT.SHOW.RESULT (NS.AUTHENTICATE (NS.MAKE.SIMPLE.CREDENTIALS LOGINFO)))) (T (CL:FORMAT T " Invalid name ~A~%%" (NSNAME.TO.STRING *USER* T)) NIL)))))
)
(\NSMT.GETAUTHENTICATOR
(LAMBDA NIL (* ; "Edited 14-Nov-90 11:57 by bvm") (LET ((INFO (\INTERNAL/GETPASSWORD (QUOTE |NS::|)))) (COND (INFO (* ; "Make sure we use the canonical user name here, not an alias") (COURIER.CREATE (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS _ (COURIER.CREATE (AUTHENTICATION . CREDENTIALS) TYPE _ (QUOTE SIMPLE) VALUE _ (COURIER.WRITE.REP *USER* (QUOTE AUTHENTICATION) (QUOTE SIMPLE.CREDENTIALS))) VERIFIER _ (COURIER.WRITE.REP (HASH.PASSWORD (CDR INFO)) (QUOTE AUTHENTICATION) (QUOTE SIMPLE.VERIFIER)))) (T (ERROR!)))))
)
(\NSMT.CHANGE.DOMAIN
(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET ((DOMAIN (\NSMT.READFNAME " (for name entry) to be:" *DEFAULTDOMAIN* T))) (COND (DOMAIN (TERPRI T) (COND ((CL:Y-OR-N-P "Set this default globally as well (i.e. for use outside Maintain)? ") (SETQ CH.DEFAULT.DOMAIN (fetch NSDOMAIN of DOMAIN)) (SETQ CH.DEFAULT.ORGANIZATION (fetch NSORGANIZATION of DOMAIN)))) (SETQ *LASTDOMAIN* (SETQ *DEFAULTDOMAIN* DOMAIN))))))
)
(\NSMT.PRINT.LIST
(LAMBDA (LST PREFIX) (* ; "Edited 21-Nov-90 12:38 by bvm") (if PREFIX then (PRINTOUT T .FONT BOLDFONT PREFIX .FONT DEFAULTFONT)) (if (EQ (CAR LST) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT LST) else (if (NULL LST) then (PRINTOUT T "(none)") else (MAPRINT LST T NIL NIL ", ")) (TERPRI T)))
)
(\NSMT.PRINT.OBJECTS
(LAMBDA (OBJECTS) (* ; "Edited 15-Nov-90 18:04 by bvm") (for OBJ in OBJECTS bind LASTDOMAIN LASTORG do (COND ((AND LASTDOMAIN (STRING-EQUAL (fetch NSDOMAIN of OBJ) LASTDOMAIN) (STRING-EQUAL (fetch NSORGANIZATION of OBJ) LASTORG)) (PRINTOUT T ", ")) (T (PRINTOUT T T "[In " .FONT BOLDFONT (SETQ LASTDOMAIN (fetch NSDOMAIN of OBJ)) ":" (SETQ LASTORG (fetch NSORGANIZATION of OBJ)) .FONT DEFAULTFONT "] "))) (PRIN1 (fetch NSOBJECT of OBJ) T)) (TERPRI T))
)
(\NSMT.PROCESS.LIST
(LAMBDA (ITEMS *DOMAIN* LISTFN) (* ; "Edited 26-Sep-90 17:26 by bvm") (DECLARE (SPECVARS *DOMAIN*)) (* ; "Usable by LISTFN") (* ;; "Display a list of Clearinghouse objects. OBJECTS is the result of some sort of listing call. If the result is a list of strings, DOMAIN is supplied so that future %"Show Details%" commands can use it. LISTFN is a function to call to print the list; it returns a possibly new list of objects to be saved for later.") (COND ((EQ (CAR ITEMS) (QUOTE ERROR)) (\NSMT.SHOW.RESULT ITEMS)) (T (COND (LISTFN (SETQ ITEMS (CL:FUNCALL LISTFN ITEMS))) (T (\NSMT.PRINT.LIST ITEMS))) (COND (ITEMS (* ; "Save list for Show Details command.") (SETQ *LASTLIST* (CONS (AND *DOMAIN* (SETQ *LASTDOMAIN* (create NSNAME using *DOMAIN* NSOBJECT _ NIL))) ITEMS)))))))
)
(\NSMT.READ.COMMA.LIST
(LAMBDA (PROMPT DEFAULT) (* ; "Edited 19-Nov-90 15:17 by bvm") (* ;; "Read a list of strings separated by commas. Return a list (or NIL) of the stuff between commas, with white space trimmed. DEFAULT is the old list, offered as initial type in") (LET ((VALUE (TTYIN PROMPT NIL NIL (QUOTE (STRING NORAISE)) NIL NIL (AND DEFAULT (if (CDR DEFAULT) then (CONCATLIST (CDR (for PIECE in DEFAULT join (LIST ", " (MKSTRING PIECE))))) else (MKSTRING (CAR DEFAULT))))))) (AND VALUE (bind (START _ 1) COMMA PIECE when (> (NCHARS (SETQ PIECE (CL:STRING-TRIM (QUOTE (#\Space #\Tab)) (SUBSTRING VALUE START (AND (SETQ COMMA (STRPOS "," VALUE START)) (SUB1 COMMA)))))) 0) collect (* ; "Parse stuff out from between the commas") PIECE repeatwhile (AND COMMA (SETQ START (ADD1 COMMA)))))))
)
(\NSMT.SHOW.RESULT
(LAMBDA (RESULT PART FIRST SECOND) (* ; "Edited 21-Aug-89 17:14 by bvm") (* ;; "Used to show the outcome of a typical clearinghouse operation. If RESULT is T or NIL, it succeeded, otherwise we print an error code. FIRST and SECOND, if non-NIL, are the actual names we used in the call, in case error has a FIRST or SECOND identification.") (COND ((OR (EQ RESULT T) (NULL RESULT)) (printout T " done" T) (* ; "Return T for success") T) (T (COND (PART (PRINTOUT T " " PART))) (PRINTOUT T " failed: ") (if (EQ (CAR (LISTP RESULT)) (QUOTE ERROR)) then (PRINTOUT T (CADDR RESULT)) (LET ((CULPRIT (CASE (CADDDR RESULT) (FIRST FIRST) (SECOND SECOND)))) (if CULPRIT then (PRINTOUT T " " CULPRIT))) else (PRINTOUT T RESULT)) (TERPRI T) NIL)))
)
(\NSMT.CHOOSE
(LAMBDA (PROMPT ALTERNATIVES) (* ; "Edited 19-Nov-90 14:50 by bvm") (* ;; "Prompt for one of alternatives. <cr> aborts.") (ASKUSER NIL NIL PROMPT (CONS *NSMAINTAIN-ABORT-ITEM* ALTERNATIVES) T))
)
(\NSMT.COURIER.OPEN
(LAMBDA (DOMAIN) (* ; "Edited 14-Nov-90 19:11 by bvm") (* ;; "Open a courier connection to a server for this domain. Caller is responsible for closing it.") (PROG (SERVER STREAM LOOPED) (if (NOT (TYPENAMEP DOMAIN (QUOTE NSNAME))) then (SETQ DOMAIN (PARSE.NSNAME DOMAIN 2))) (if (AND (CL:HASH-TABLE-P *REAL-NAME-CACHE*) (NOT (\NSMT.DOMAIN.MAY.EXIST DOMAIN))) then (* ;; "Check up front whether domain is ok, rather than letting Lisp chs stuff go wild") (RETURN NIL)) TOP (if (SETQ SERVER (CH.FINDSERVER DOMAIN T)) then (if (SETQ STREAM (COURIER.OPEN SERVER NIL T)) then (* ; "Ah, success") (RETURN STREAM)) (if (NOT LOOPED) then (* ; "Maybe time to refresh the cache") (\NSMT.CLEAR.CACHE DOMAIN) (SETQ LOOPED T) (GO TOP))) (PRINTOUT T "[Couldn't " (if SERVER then "contact" else "locate") " server for " (fetch NSDOMAIN of DOMAIN) ":" (fetch NSORGANIZATION of DOMAIN) "] ") (RETURN NIL)))
)
(\NSMT.CLEAR.CACHE
(LAMBDA (DOMAIN) (* ; "Edited 2-Nov-90 14:51 by bvm") (* ;; "Clear the clearinghouse cache of servers for this domain. NIL means everyone. Domain can be *:org to clear all servers for a given org. Returns T if it did anything.") (if (NULL DOMAIN) then (SETQ \CH.CACHE (SETQ LOCAL.CLEARINGHOUSE NIL)) (GETCLEARINGHOUSE) T else (SETQ DOMAIN (PARSE.NSNAME DOMAIN 2)) (LET* ((ORG (fetch NSORGANIZATION of DOMAIN)) (ORGINFO (CL:ASSOC ORG \CH.CACHE :TEST (QUOTE STRING-EQUAL))) DOM DOMINFO) (if (NULL ORGINFO) then NIL elseif (OR (STRING-EQUAL (SETQ DOM (fetch NSDOMAIN of DOMAIN)) "*") (STRING-EQUAL ORG "...") (STRING-EQUAL ORG "CHServers")) then (SETQ \CH.CACHE (DREMOVE ORGINFO \CH.CACHE)) (* ; "Get rid of them all") (if (AND LOCAL.CLEARINGHOUSE (EQUAL.NSADDRESS LOCAL.CLEARINGHOUSE (CAAADR ORGINFO))) then (* ; "It was our primary server, so go get another.") (SETQ LOCAL.CLEARINGHOUSE NIL) (GETCLEARINGHOUSE)) T elseif (SETQ DOMINFO (CL:ASSOC DOM (CDDR ORGINFO) :TEST (QUOTE STRING-EQUAL))) then (if (NULL (RPLACD (CDR ORGINFO) (DREMOVE DOMINFO (CDDR ORGINFO)))) then (* ; "Get rid of org altogether if this was the only server cached") (SETQ \CH.CACHE (DREMOVE ORGINFO \CH.CACHE))) T))))
)
(EQUAL.NSADDRESS
(LAMBDA (A1 A2) (* ; "Edited 2-Nov-90 14:50 by bvm") (AND (EQ (ffetch NSHNM2 of (\DTEST A1 (QUOTE NSADDRESS))) (ffetch NSHNM2 of (\DTEST A2 (QUOTE NSADDRESS)))) (EQ (ffetch NSHNM1 of A1) (ffetch NSHNM1 of A2)) (EQ (ffetch NSHNM0 of A1) (ffetch NSHNM0 of A2)) (EQ (ffetch NSNETLO of A1) (ffetch NSNETLO of A2)) (EQ (ffetch NSNETHI of A1) (ffetch NSNETHI of A2)) (EQ (ffetch NSSOCKET of A1) (ffetch NSSOCKET of A2))))
)
)
(* ; "Ordinary user commands")
(DEFINEQ
(\NSMT.CHANGE.PASSWORD
(LAMBDA NIL (* ; "Edited 14-Nov-90 17:16 by bvm") (LET ((NAME (\NSMT.READFNAME " for user:" (NSNAME.TO.STRING *USER* T) NIL NIL T)) PASS) (COND ((NULL NAME) NIL) ((NULL (SETQ PASS (\NSMT.GET.PASSWORD " to be:"))) (printout T " xxx" T)) (T (PRIN1 "..." T) (COND ((AND NAME (EQUAL.CH.NAMES *USER* (SETQ *LASTNAME* (SETQ *LASTSTRING* NAME)))) (* ; "Changing own password") (COND ((\NSMT.SHOW.RESULT (AS.CHANGE.OWN.PASSWORDS (\ENCRYPT.PWD (CONCAT PASS)))) (\INTERNAL/SETPASSWORD (QUOTE |NS::|) (CONS (NSNAME.TO.STRING NAME T) PASS))))) (T (* ; "Changing someone else's password. Only way to do this is to delete the old keys and create new ones.") (\NSMT.SHOW.RESULT (AS.REPLACE.PASSWORDS NAME (\ENCRYPT.PWD (CONCAT PASS))))))))))
)
(\NSMT.DESCRIBE.ACL
(LAMBDA (NAME WHICH.LIST AUTH S PROPERTY) (* ; "Edited 21-Nov-90 12:01 by bvm") (* ;; "Fetch and display the access control list WHICH.LIST for NAME. PROPERTY is the property under control, defaulting to MEMBERS") (LET ((MEMBERS (COURIER.CALL S (QUOTE CHACCESSCONTROL) (QUOTE RETRIEVE.PROPERTY.ACL) NAME (OR PROPERTY (CH.PROPERTY (QUOTE MEMBERS))) WHICH.LIST (QUOTE (CHACCESSCONTROL . ELEMENT.NAME)) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS))) ADMIN) (PRINTOUT T .FONT BOLDFONT (CASE WHICH.LIST (Administrators "Owners: ") (selfControllers "Friends: ")) .FONT DEFAULTFONT) (if (AND (CDDDDR (LISTP MEMBERS)) (SETQ ADMIN (\NSMT.FETCH.ADMINISTRATORS NAME T S)) (EQ (LENGTH MEMBERS) (LENGTH ADMIN)) (CL:EVERY (FUNCTION EQUAL.CH.NAMES) MEMBERS ADMIN)) then (* ;; "It's equal to the list of domain administrators, so guess that that's what it is. It's really stupid that this interface doesn't let us tell the difference between the acl being defaulted or not.") (CL:FORMAT T "(Administrators of ~A:~A)~%%" (fetch NSDOMAIN of NAME) (fetch NSORGANIZATION of NAME)) else (\NSMT.PRINT.LIST MEMBERS))))
)
(\NSMT.DESCRIBE.OBJECT
(LAMBDA (NAME BRIEFLY) (* ; "Edited 8-Jan-92 10:57 by bvm") (* ;; "Identify name by type and show its interesting properties. Return distinguished name if it exists, else NIL.") (WITH-CHS (S NAME) (PROG* ((SIMPLE.AUTH (CH.GETAUTHENTICATOR)) (NAME&PROPS (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE LIST.PROPERTIES) NAME SIMPLE.AUTH (QUOTE RETURNERRORS))) (PROP.MEMBERS (CH.PROPERTY (QUOTE MEMBERS))) MAINPROPS PROPS ALIASES DESCR GOTSOME FORWARD GROUPP USERP USERGROUPP) (if (EQ (CAR NAME&PROPS) (QUOTE ERROR)) then (RETURN (\NSMT.SHOW.RESULT NAME&PROPS)) else (* ; "Pull out distinguished name") (SETQ NAME (CAR NAME&PROPS))) (FRESHLINE T) (printout T T .FONT BOLDFONT (NSNAME.TO.STRING NAME T) .FONT DEFAULTFONT) (SETQ PROPS (CL:NSET-DIFFERENCE (CADR NAME&PROPS) *NSMAINTAIN-IGNORE-PROPERTIES*)) (SETQ MAINPROPS (\NSMT.DESCRIPTIVE.PROPS PROPS)) (SETQ GROUPP (CL:MEMBER PROP.MEMBERS PROPS)) (for P in MAINPROPS do (if (EQ P (CH.PROPERTY (QUOTE USER))) then (* ; "Note this for subsequent kludge") (SETQ USERP T)) (if (AND (EQ P (CH.PROPERTY (QUOTE USERGROUP))) (PROGN (SETQ USERGROUPP T) USERP) GROUPP) then (* ;; "Both USER and group? This is kludge to get NS mail forwarding, so don't mention USERGROUP (the prop %"describes%" the forwarding, but is pretty uninteresting). We depend on server returning props in order, which means we got to USER before USERGROUP.") else (CL:FORMAT T " ~A a ~A~@[ (~A)~]" (if GOTSOME then (* ; "Multiple identities") (TERPRI T) " and" else (* ; "First prop") (SETQ GOTSOME T) "is") (\NSMT.PRETTY.PROPERTY P) (LET ((DESCR (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE RETRIEVE.ITEM) NAME P SIMPLE.AUTH (QUOTE NOERROR)))) (* ;; "Description of object is stored as string on this descriptive property. Sometimes the value is null, which is why we are careful about trying to interpret the result.") (AND DESCR (COURIER.READ.REP (CADR DESCR) NIL (QUOTE STRING)))))) (SETQ PROPS (CL:DELETE P PROPS))) (if GROUPP then (if USERP then (SETQ FORWARD T) (SETQ GROUPP NIL) else (if (NOT USERGROUPP) then (COND (GOTSOME (PRINTOUT T T " and")) (T (PRINTOUT T " is"))) (PRINTOUT T " a group")) (SETQ PROPS (CL:DELETE PROP.MEMBERS PROPS)))) (SETQ *LASTSTRING* (if GROUPP then (SETQ *LASTGROUP* NAME) else (SETQ *LASTNAME* NAME))) (if (NOT BRIEFLY) then (TERPRI T) (if (SETQ ALIASES (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE LIST.ALIASES.OF) NAME (QUOTE (CLEARINGHOUSE . OBJECT.NAME)) SIMPLE.AUTH (QUOTE NOERROR))) then (\NSMT.PRINT.LIST ALIASES "Aliases: ")) (for P in PROPS do (\NSMT.DESCRIBE.PROPERTY NAME P S (AND FORWARD (EQ P PROP.MEMBERS) "Forwarding"))) (if (OR GROUPP (AND FORWARD (EQ *NSMAINTAIN-SHOW-GROUP-ACCESS* :ALWAYS))) then (* ; "Show owners and friends") (\NSMT.DESCRIBE.ACL NAME (QUOTE Administrators) SIMPLE.AUTH S) (\NSMT.DESCRIBE.ACL NAME (QUOTE selfControllers) SIMPLE.AUTH S) (if (AND GROUPP (> *NSMAINTAIN-MEMBER-THRESHOLD* 0)) then (* ; "Look at membership") (PRINTOUT T .FONT BOLDFONT "Members: " .FONT DEFAULTFONT) (LET ((MEMBERS (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE RETRIEVE.MEMBERS) NAME PROP.MEMBERS (QUOTE (CLEARINGHOUSE . OBJECT.NAME)) SIMPLE.AUTH (QUOTE RETURNERRORS)))) (*PRINT-CASE* 10) N) (if (EQ (CAR MEMBERS) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT MEMBERS) else (if MEMBERS then (* ; "Save for Type Members") (SETQ *LAST-MEMBERSHIP* (CONS NAME MEMBERS))) (if (< (SETQ N (LENGTH MEMBERS)) *NSMAINTAIN-MEMBER-THRESHOLD*) then (* ; "If there are few enough members, just show them") (\NSMT.PRINT.LIST MEMBERS) else (PRINT N T))))))) (RETURN NAME))))
)
(\NSMT.DESCRIPTIVE.PROPS
(LAMBDA (PROPS) (* ; "Edited 20-Nov-90 13:01 by bvm") (* ;; "PROPS is a list of property numbers. Return the subset that are %"descriptive%" properties, i.e., whose value is a remark string.") (* ;; "If we fail on the documented props, see if any props are in the 10000 range, which is conventionally allocated for descriptions") (OR (CL:INTERSECTION PROPS *NSMAINTAIN-DESCRIPTIVE-PROPERTIES*) (for P in PROPS collect P when (AND (>= P 10000) (<= P 20000)))))
)
(\NSMT.DESCRIBE.PROPERTY
(LAMBDA (FNAME CHP S PROPNAME) (* ; "Edited 20-Nov-90 14:47 by bvm") (* ;; "Called by \NSMT.TYPE.ENTRY to show one particular property.") (LET* ((GROUPP (MEMB CHP *NSMAINTAIN-MEMBER-PROPERTIES*)) (VAL (COND (GROUPP (* ; "This is a group property, so get its value differently") (CH.RETRIEVE.MEMBERS FNAME CHP S)) (T (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE RETRIEVE.ITEM) FNAME CHP (CH.GETAUTHENTICATOR) (QUOTE RETURNERRORS)))))) (PRINTOUT T .FONT BOLDFONT (OR PROPNAME (\NSMT.PRETTY.PROPERTY CHP T)) ": " .FONT DEFAULTFONT) (if (EQ (CAR VAL) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT VAL) elseif GROUPP then (* ; "Group property, print members as list") (\NSMT.PRINT.LIST VAL) elseif (NULL (SETQ VAL (CADR VAL))) then (* ; "note that RETRIEVE.ITEM produced (name value)") (PRINTOUT T "(null)" T) elseif (IGNORE-ERRORS (LET ((HOW (CDR (ASSOC CHP *NSMAINTAIN-PROPERTY-FORMATS*))) PGM) (while (AND (LISTP HOW) (LITATOM (CDR HOW)) (CDR HOW)) do (* ; "Reduce to a less qualified name, to see if it gets down to a record decl") (SETQ HOW (\GET.COURIER.TYPE (SETQ PGM (CAR HOW)) (CDR HOW)))) (* ;; "Ok, now try to interpret the value") (SETQ VAL (COURIER.READ.REP VAL PGM HOW)) (if (EQ (CAR (LISTP HOW)) (QUOTE RECORD)) then (* ; "make records humanly intelligible") (for PAIR in (CDR HOW) as V in VAL bind (PREFIX _ "[") do (PRIN1 PREFIX T) (PRINTOUT T (CL:STRING-CAPITALIZE (STRING (CAR PAIR))) ": " (SELECTQ (CADR PAIR) (BOOLEAN (CL:IF V "true" "false")) (TIME (GDATE V)) V)) (SETQ PREFIX "; ") finally (PRINTOUT T "]" T)) T))) else (* ; "just print what we've got") (PRINTOUT T VAL T))))
)
(\NSMT.PRETTY.PROPERTY
(LAMBDA (P VERBOSE) (* ; "Edited 20-Nov-90 14:27 by bvm") (LET ((NAME (CH.NUMBER.TO.PROPERTY P))) (if NAME then (CL:STRING-CAPITALIZE NAME) else (CL:FORMAT NIL "#~D" P))))
)
(\NSMT.LIST.OBJECTS
(LAMBDA (PROP LISTFN) (* ; "Edited 14-Nov-90 18:04 by bvm") (* ;;; "given a clearinghouse property, lookup all objects with a user-specified pattern that have that property. Default pattern is * in recent domain.") (LET (PATTERN) (COND ((AND (OR PROP (SETQ PROP (ASKUSER NIL NIL " having property " (OR *ALLTYPES* (SETQ *ALLTYPES* (CONS (QUOTE ("" "any" EXPLAINSTRING "<cr> - list ALL objects" RETURN (QUOTE ALL))) (CONS (QUOTE (* "" EXPLAINSTRING "* - list ALL objects" CONFIRMFLG T RETURN (QUOTE ALL))) (SORT (DREMOVE (QUOTE ALL) (MAPCAR CH.PROPERTIES (FUNCTION CAR)))))))) T))) (SETQ PATTERN (\NSMT.READFNAME " by pattern:" (AND *LASTNAME* (create NSNAME using *LASTNAME* NSOBJECT _ "*")) NIL T NIL T))) (AND (\NSMT.DOMAIN.MAY.EXIST PATTERN) (\NSMT.PROCESS.LIST (CH.LIST.OBJECTS PATTERN PROP) PATTERN LISTFN))))))
)
(\NSMT.LIST.CLEARINGHOUSES
(LAMBDA NIL (* ; "Edited 21-Aug-89 17:10 by bvm") (DECLARE (USEDFREE *LASTDOMAIN*)) (LET ((DOMAIN (\NSMT.READFNAME " serving domain:" *LASTDOMAIN* T)) (CHSPART "CHServers") SERVERS) (COND (DOMAIN (SETQ *LASTDOMAIN* DOMAIN) (TERPRI T) (SETQ SERVERS (LISTP (CH.RETRIEVE.MEMBERS (create NSNAME NSOBJECT _ (fetch NSDOMAIN of DOMAIN) NSDOMAIN _ (fetch NSORGANIZATION of DOMAIN) NSORGANIZATION _ CHSPART)))) (COND ((EQ (CAR SERVERS) (QUOTE ERROR)) (\NSMT.SHOW.RESULT (COND ((EQ (CADDR SERVERS) (QUOTE NoSuchObject)) (* ; "translate this error") "No Such Domain") (T SERVERS)))) ((SETQ SERVERS (for S in SERVERS collect (COND ((AND (STRING-EQUAL (fetch NSDOMAIN of S) CHSPART) (STRING-EQUAL (fetch NSORGANIZATION of S) CHSPART)) (* ;; "Clearinghouse names are usually of the form server:CHServers:CHServers. The domain here is thus junk--print the name only. Hope for not too much confusion if user tries to type name by hand, rather than using Show Details command.") (fetch NSOBJECT of S)) (T (* ; "An aberrant name--punt by printing all full names") (\NSMT.PROCESS.LIST SERVERS) (RETURN NIL))))) (* ; "Show short names, preserve domain for Show Details") (\NSMT.PROCESS.LIST SERVERS (create NSNAME NSDOMAIN _ CHSPART NSORGANIZATION _ CHSPART))))))))
)
(\NSMT.LIST.SERVERS
(LAMBDA NIL (* ; "Edited 19-Nov-90 14:53 by bvm") (* ;; "List Objects specialized to servers. We offer as choices those properties with SERVICE in their name, plus the oddly generic %"SERVER%". CLEARINGHOUSE.SERVICE is excluded because its name space doesn't work as you'd expect.") (LET ((PROP (\NSMT.CHOOSE " of type " (OR *SERVERTYPES* (SETQ *SERVERTYPES* (SORT (CONS (QUOTE ("Server" "" RETURN (QUOTE SERVER))) (for P in CH.PROPERTIES when (AND (STRPOS "SERVICE" (CAR P) -7) (NEQ (CAR P) (QUOTE CLEARINGHOUSE.SERVICE))) collect (BQUOTE ((\, (CL:STRING-CAPITALIZE (SUBSTRING (CAR P) 1 -9))) "" RETURN (QUOTE (\, (CAR P))))))) T)))))) (AND PROP (\NSMT.LIST.OBJECTS PROP))))
)
(\NSMT.SHOW.DETAILS
(LAMBDA NIL (* ; "Edited 20-Nov-90 17:19 by bvm") (COND ((NULL *LASTLIST*) (PRINTOUT T " (no previous list)" T)) (T (DESTRUCTURING-BIND (DOMAIN . OBJECTS) *LASTLIST* (COND ((NULL (CDR OBJECTS)) (* ; "only one, describe it straight away") (TERPRI T) (\NSMT.DESCRIBE.OBJECT (COND (DOMAIN (create NSNAME using DOMAIN NSOBJECT _ (CAR OBJECTS))) (T (PARSE.NSNAME (CAR OBJECTS)))))) (T (COND ((NOT (STRINGP (CAR OBJECTS))) (* ; "Turn ns names into strings") (RPLACD *LASTLIST* (SETQ OBJECTS (for N in OBJECTS collect (NSNAME.TO.STRING N T)))))) (bind (CMDS _ (CONS *NSMAINTAIN-ABORT-ITEM* OBJECTS)) NAME while (SETQ NAME (PROGN (TERPRI T) (ASKUSER NIL NIL " name: " CMDS T))) do (\NSMT.DESCRIBE.OBJECT (COND (DOMAIN (create NSNAME using DOMAIN NSOBJECT _ NAME)) (T (PARSE.NSNAME NAME)))))))))))
)
(\NSMT.GROUP.FILTER
(LAMBDA (NAMES) (* ; "Edited 26-Sep-90 17:47 by bvm") (DECLARE (USEDFREE *DOMAIN*)) (* ;; "List function for List Objects -- NAMES is a list of objects that have a members prop. Filter out those that also have a USER prop, assuming that these %"groups%" are merely for forwarding, and print the rest.") (* ;; "We could ask for each object whether it's a user, but it's much faster to just ask the server to enumerate the users and take the difference.") (LET ((USERS (CH.LIST.OBJECTS *DOMAIN* (QUOTE USER)))) (\NSMT.PRINT.LIST (CL:SET-DIFFERENCE NAMES USERS :TEST (QUOTE STRING-EQUAL)))))
)
(\NSMT.LIST.ADMINISTRATORS
(LAMBDA NIL (* ; "Edited 20-Nov-90 16:12 by bvm") (LET ((DOMAIN (\NSMT.READFNAME " of domain:" *LASTDOMAIN* T T))) (if (AND DOMAIN (\NSMT.DOMAIN.MAY.EXIST DOMAIN)) then (\NSMT.PROCESS.LIST (\NSMT.FETCH.ADMINISTRATORS (SETQ *LASTDOMAIN* DOMAIN))))))
)
(\NSMT.FETCH.ADMINISTRATORS
(LAMBDA (DOMAIN CACHEOK S) (* ; "Edited 20-Nov-90 16:05 by bvm") (* ;; "Return the list of administrators for domain. If CACHEOK is true, we're allowed to find the answer in the cache. S is appropriate courier stream, or NIL.") (SETQ DOMAIN (create NSNAME using DOMAIN NSOBJECT _ "*")) (* ; "Copy just in case") (OR (AND CACHEOK (GETHASH DOMAIN *REAL-NAME-CACHE*)) (LET ((ADMIN (if S then (\NSMT.FETCH.ADMINISTRATORS1 S DOMAIN) else (WITH-CHS (S DOMAIN) (\NSMT.FETCH.ADMINISTRATORS1 S DOMAIN))))) (if (AND ADMIN (NEQ (CAR (LISTP ADMIN)) (QUOTE ERROR))) then (PUTHASH DOMAIN ADMIN *REAL-NAME-CACHE*) (* ; "Cache the results") ADMIN))))
)
(\NSMT.FETCH.ADMINISTRATORS1
(LAMBDA (S DOMAIN) (* ; "Edited 20-Nov-90 16:03 by bvm") (COURIER.CALL S (QUOTE CHACCESSCONTROL) (QUOTE RETRIEVE.DOMAIN.ACL) DOMAIN (QUOTE Administrators) (QUOTE (CHACCESSCONTROL . ELEMENT.NAME)) (QUOTE (SIMPLE NIL)) (QUOTE (0)) (QUOTE RETURNERRORS)))
)
(\NSMT.LIST.DOMAINS
(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET ((DOMAIN (\NSMT.READFNAME " by pattern:" (create NSNAME using *LASTDOMAIN* NSDOMAIN _ "*") T T NIL T))) (COND (DOMAIN (\NSMT.PRINT.LIST (CH.LIST.DOMAINS DOMAIN))))))
)
(\NSMT.TYPE.ENTRY
(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (NAME) (COND ((SETQ NAME (\NSMT.READFNAME " name:" *LASTSTRING* NIL T NIL T)) (\NSMT.DESCRIBE.OBJECT NAME)))))
)
(\NSMT.TYPE.MEMBERS
(LAMBDA NIL (* ; "Edited 21-Nov-90 12:53 by bvm") (DECLARE (USEDFREE *LASTGROUP* *LASTSTRING*)) (PROG ((NAME (\NSMT.READFNAME " of group:" *LASTGROUP* NIL T)) ITEMS) (if (NOT NAME) then (RETURN)) (SETQ *LASTSTRING* NAME) (if (AND *LAST-MEMBERSHIP* (EQUAL.CH.NAMES NAME (CAR *LAST-MEMBERSHIP*))) then (SETQ ITEMS (CDR *LAST-MEMBERSHIP*)) elseif (NOT (\NSMT.DOMAIN.MAY.EXIST NAME)) then (RETURN) elseif (EQ (CAR (SETQ ITEMS (LISTP (CH.RETRIEVE.MEMBERS NAME (QUOTE MEMBERS))))) (QUOTE ERROR)) then (* ; "Failure. Translate the %"Missing%" error into English") (RETURN (\NSMT.SHOW.RESULT (if (EQ (CADDR ITEMS) (QUOTE Missing)) then "Not A Group" else ITEMS)))) (SETQ *LASTGROUP* NAME) (if (NULL ITEMS) then (PRIN1 "(No members)" T) else (if (CDR ITEMS) then (CL:FORMAT T "~2%%(~D members)~%%" (LENGTH ITEMS)) (\NSMT.PRINT.OBJECTS ITEMS) else (* ; "Just one") (PRINTOUT T (CAR ITEMS) T)) (* ; "Save list for Show Details command.") (SETQ *LASTLIST* (CONS NIL ITEMS)))))
)
(\NSMT.UNCACHE
(LAMBDA (ALLP) (* ; "Edited 14-Nov-90 18:09 by bvm") (LET (DOMAIN) (if (OR ALLP (SETQ DOMAIN (\NSMT.READFNAME ":" *LASTDOMAIN* T T))) then (if (NOT ALLP) then (SETQ *LASTDOMAIN* DOMAIN)) (PRINTOUT T (if (\NSMT.CLEAR.CACHE (AND (NOT ALLP) DOMAIN)) then "done" else "nothing cached") T))))
)
(\NSMT.CLEAR.NAME.CACHE
(LAMBDA NIL (* ; "Edited 21-Nov-90 13:06 by bvm") (LET ((CNT (CL:HASH-TABLE-COUNT *REAL-NAME-CACHE*))) (TERPRI T) (if *LAST-MEMBERSHIP* then (* ; "This is another cache") (add CNT 1)) (if (EQ CNT 0) then (PRINTOUT T "nothing cached" T) else (CLRHASH *REAL-NAME-CACHE*) (SETQ *LAST-MEMBERSHIP* NIL) (CL:FORMAT T "Ok, ~D cache entries cleared.~%%" CNT))))
)
)
(* ; "Administrator commands")
(DEFINEQ
(\NSMT.ADD.ALIAS
(LAMBDA NIL (* ; "Edited 14-Nov-90 12:13 by bvm") (LET (OBJECT ALIAS) (COND ((AND (SETQ OBJECT (\NSMT.READFNAME " for object:" *LASTSTRING*)) (LET ((*DEFAULTDOMAIN* (create NSNAME using OBJECT NSOBJECT _ NIL))) (DECLARE (CL:SPECIAL *DEFAULTDOMAIN*)) (* ; "Read the alias by default in the same domain as object") (TERPRI T) (SETQ ALIAS (\NSMT.READFNAME " Alias:" NIL NIL T)))) (OR (\NSMT.SHOW.RESULT (LISTP (SETQ *LASTSTRING* (WITH-CHS (S OBJECT) (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE CREATE.ALIAS) ALIAS OBJECT (\NSMT.GETAUTHENTICATOR) (QUOTE RETURNERRORS)))))) (SETQ *LASTSTRING* OBJECT))))))
)
(\NSMT.ADD.GROUP
(LAMBDA NIL (* ; "Edited 15-Nov-90 18:01 by bvm") (* ;; "Create a new group") (LET ((GROUP (\NSMT.READFNAME " New group name:" NIL NIL T)) AUTH REMARK RESULT MEMBERS OWNERS FRIENDS) (if (NULL GROUP) elseif (LISTP (SETQ RESULT (WITH-CHS (S GROUP) (* ;; "Note: two calls on with-chs, because we want to create the object first, to assure it can be done, but then user can take arbitrarily long supplying the group components") (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE CREATE.OBJECT) GROUP (SETQ AUTH (\NSMT.GETAUTHENTICATOR)) (QUOTE RETURNERRORS))))) then (* ; "Failed to create object") (\NSMT.SHOW.RESULT RESULT) else (SETQ *LASTSTRING* (SETQ *LASTGROUP* GROUP)) (* ;; "Assume if user had access rights to create the object, then calls below don't fail. Gather all the info before taking the time to call the Clearinghouse, since sometimes these update calls are very slow.") (TERPRI T) (SETQ REMARK (\NSMT.GET.REMARK)) (CL:FORMAT T "~%%~%%Enter names of members, owners and friends, one per line, terminated with a blank line.~%%") (SETQ MEMBERS (\NSMT.COLLECT.NAMES "Member:" :FOREIGN :ANY)) (CL:FORMAT T "~%%(If you enter no owners, the group will be owned by the administrators of ~A.)~%%" (create NSNAME using GROUP NSOBJECT _ NIL)) (SETQ OWNERS (\NSMT.COLLECT.NAMES "Owner:" T :ANY)) (SETQ FRIENDS (\NSMT.COLLECT.NAMES "Friend:" T :ANY)) (TERPRI T) (* ;; "Ok, we're ready to roll...") (WITH-CHS (S GROUP) (LET ((USERADMIN (create NSNAME using GROUP NSOBJECT _ "UserAdministration"))) (if (AND (NOT (CL:MEMBER USERADMIN OWNERS)) (SETQ USERADMIN (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE LOOKUP.OBJECT) USERADMIN AUTH (QUOTE NOERROR))) (CL:Y-OR-N-P "Do you want to include, as is conventional, ~A as an owner? " USERADMIN)) then (push OWNERS USERADMIN)) (LET* ((SELF *USER*) (FOUNDSELF (CL:MEMBER SELF OWNERS :TEST (QUOTE EQUAL.CH.NAMES)))) (* ;; "Have to make user be first owner, because as soon as we add one administrator, we override the default administrators, which means user is no longer empowered to add the rest of the owners! Stupid @#&#!!@ Clearinghouse design.") (if FOUNDSELF then (if (NEQ FOUNDSELF OWNERS) then (SETQ OWNERS (CONS SELF (CL:REMOVE (CAR FOUNDSELF) OWNERS)))) elseif (CL:Y-OR-N-P "Do you want to include yourself as an owner? ") then (SETQ OWNERS (CONS SELF OWNERS)))) (PRINTOUT T "Setting remark...") (\NSMT.SHOW.RESULT (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.ITEM.PROPERTY) GROUP (CH.PROPERTY (QUOTE USERGROUP)) (COURIER.WRITE.REP REMARK (QUOTE CLEARINGHOUSE) (QUOTE STRING)) AUTH (QUOTE RETURNERRORS)))) (if MEMBERS then (PRINTOUT T "Adding members...") (\NSMT.SHOW.RESULT (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.GROUP.PROPERTY) GROUP (CH.PROPERTY (QUOTE MEMBERS)) (FUNCTION (LAMBDA (DATASTREAM) (* ; "Function to write the membership onto the bulk data stream") (COURIER.WRITE.BULKDATA DATASTREAM MEMBERS NIL (QUOTE NSNAME)))) AUTH (QUOTE RETURNERRORS))))) (if OWNERS then (\NSMT.SET.INITIAL.ACL GROUP OWNERS (QUOTE Administrators) AUTH S)) (if FRIENDS then (\NSMT.SET.INITIAL.ACL GROUP FRIENDS (QUOTE selfControllers) AUTH S)))))))
)
(\NSMT.SET.INITIAL.ACL
(LAMBDA (GROUP MEMBERS WHICH.LIST AUTH S) (* ; "Edited 31-Oct-90 16:59 by bvm") (* ;; "Set the initial access control list WHICH.LIST for GROUP to be MEMBERS") (PRINTOUT T "Adding " (CASE WHICH.LIST (Administrators "owners") (selfControllers "friends") (T WHICH.LIST)) "...") (\NSMT.SHOW.RESULT (for NAME in MEMBERS thereis (SETQ $$VAL (LISTP (COURIER.CALL S (QUOTE CHACCESSCONTROL) (QUOTE ADD.MEMBER.TO.PROPERTY.ACL) GROUP (CH.PROPERTY (QUOTE MEMBERS)) WHICH.LIST NAME (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS)))))))
)
(\NSMT.ADD.USER
(LAMBDA NIL (* ; "Edited 19-Nov-90 15:48 by bvm") (* ;; "Create new user") (PROG (AUTH NAME PASS ERROR) (DECLARE (USEDFREE *LASTNAME* *LASTSTRING*)) (TERPRI T) (if (NOT (SETQ NAME (\NSMT.READFNAME "Name for new object:" *LASTNAME* NIL T))) then (RETURN)) (SETQ *LASTSTRING* (SETQ *LASTNAME* NAME)) (if (LISTP (SETQ ERROR (\NSMT.CREATE.OBJECT NAME (SETQ AUTH (\NSMT.GETAUTHENTICATOR))))) then (* ; "Error") (RETURN (\NSMT.SHOW.RESULT ERROR))) (* ;; "Having created the object, get all the other parts. We assume that if the creation succeeded, we'll be able to do the rest, so gather all the info first, then do the calls.") (TERPRI T) (if (NULL (SETQ PASS (\NSMT.GET.PASSWORD "Initial password:"))) then (printout T " (no password stored; use Change Password to create one)" T)) (\NSMT.ADD.OBJECT.GENERIC NAME AUTH (CH.PROPERTY (QUOTE USER))) (* ;; "Unfortunately, can't use the same Clearinghouse stream to do the passwords, since that requires an Authentication service. The two are usually the same, but we can't assume so.") (if PASS then (PRINTOUT T "Setting password...") (\NSMT.SHOW.RESULT (AS.CREATE.PASSWORDS NAME (\ENCRYPT.PWD PASS))))))
)
(\NSMT.ADD.OBJECT
(LAMBDA NIL (* ; "Edited 19-Nov-90 15:04 by bvm") (* ;; "Create new object of arbitrary type") (PROG (TYPE AUTH NAME PASS ERROR) (DECLARE (USEDFREE *LASTNAME* *LASTSTRING*)) (if (NOT (AND (SETQ TYPE (\NSMT.GET.OBJECT.TYPE " of type: ")) (SETQ NAME (\NSMT.READFNAME "Name for new object:" *LASTNAME* NIL T)))) then (RETURN)) (SETQ *LASTSTRING* (SETQ *LASTNAME* NAME)) (if (LISTP (SETQ ERROR (\NSMT.CREATE.OBJECT NAME (SETQ AUTH (\NSMT.GETAUTHENTICATOR))))) then (* ; "Error") (RETURN (\NSMT.SHOW.RESULT ERROR))) (* ;; "Having created the object, get all the other parts. We assume that if the creation succeeded, we'll be able to do the rest, so gather all the info first, then do the calls.") (TERPRI T) (\NSMT.ADD.OBJECT.GENERIC NAME AUTH (CH.PROPERTY TYPE))))
)
(\NSMT.CREATE.OBJECT
(LAMBDA (NAME AUTH) (* ; "Edited 19-Nov-90 14:17 by bvm") (* ;; "Create object and return its name or error") (WITH-CHS (S NAME) (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE CREATE.OBJECT) NAME AUTH (QUOTE RETURNERRORS))))
)
(\NSMT.ADD.OBJECT.GENERIC
(LAMBDA (NAME AUTH TYPE) (* ; "Edited 19-Nov-90 15:00 by bvm") (* ;; "Add the %"generic%" parts of a new object -- remark, aliases.") (LET ((DESC (\NSMT.GET.REMARK)) (ALIASES (LET ((*DEFAULTDOMAIN* (create NSNAME using NAME NSOBJECT _ NIL))) (DECLARE (CL:SPECIAL *DEFAULTDOMAIN*)) (* ; "Read the aliases by default in the same domain as object") (\NSMT.COLLECT.NAMES "Alias:")))) (PRIN1 "... " T) (WITH-CHS (S NAME) (LET (ERROR) (PRINTOUT T "Setting remark...") (\NSMT.SHOW.RESULT (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.ITEM.PROPERTY) NAME TYPE (AND DESC (COURIER.WRITE.REP DESC (QUOTE CLEARINGHOUSE) (QUOTE STRING))) AUTH (QUOTE RETURNERRORS)))) (if ALIASES then (PRINTOUT T "Setting aliases...") (\NSMT.SHOW.RESULT (AND (for A in ALIASES thereis (SETQ ERROR (LISTP (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE CREATE.ALIAS) A NAME AUTH (QUOTE RETURNERRORS))))) ERROR)))))))
)
(\NSMT.CHANGE.ADDRESS
(LAMBDA NIL (* ; "Edited 19-Nov-90 15:45 by bvm") (* ;; "Change the Address.list property of a machine.") (PROG ((ADDRESS.PROPERTY (CONSTANT (CH.PROPERTY (QUOTE ADDRESS.LIST)))) PROPS NAME INPUT OLDADDRESSES NEWADDRESSES HADADDRESS) (DECLARE (USEDFREE *LASTSTRING* *LASTNAME*)) (if (NOT (SETQ NAME (\NSMT.READFNAME " of machine:" *LASTNAME*))) then (RETURN)) (TERPRI T) (SETQ PROPS (CH.LIST.PROPERTIES NAME)) (* ; "returns (realname props)") (if (EQ (SETQ NAME (CAR PROPS)) (QUOTE ERROR)) then (* ; "Object does not exist, probably") (RETURN (\NSMT.SHOW.RESULT PROPS))) (if (AND (SETQ HADADDRESS (MEMB ADDRESS.PROPERTY PROPS)) (SETQ OLDADDRESSES (CH.RETRIEVE.ITEM NAME ADDRESS.PROPERTY))) then (SETQ OLDADDRESSES (COURIER.READ.REP OLDADDRESSES (QUOTE CLEARINGHOUSE) (QUOTE NETWORK.ADDRESS.LIST))) else (PRINTOUT T NAME " does not yet have an address." T)) (SETQ *LASTSTRING* (SETQ *LASTNAME* NAME)) RETRY (PRINTOUT T "Type one or more NS addresses, separated by commas." T "Octal format: oo#o...o#oo or Decimal: n-nnn#nnn-...-nnn#nnn" T) (if (NULL (SETQ INPUT (for X in (\NSMT.READ.COMMA.LIST "Address(es): " (OR INPUT OLDADDRESSES)) collect (PARSE-NSADDRESS X 0)))) then (* ; "No new address...delete old?") (if (NOT HADADDRESS) then (RETURN (PRINTOUT T " (not changed)" T)) elseif (CL:Y-OR-N-P "Remove address list for ~A? " NAME) then (\NSMT.SHOW.RESULT (LISTP (CH.DELETE.PROPERTY ADDRESS.PROPERTY)))) elseif (MEMB NIL (SETQ NEWADDRESSES (for X in INPUT collect (PARSE-NSADDRESS X 0)))) then (PRINTOUT T "Illegal address:") (for I in INPUT as A in NEWADDRESSES unless A bind (SEPR _ " ") do (PRINTOUT T SEPR I) (SETQ SEPR ",")) (TERPRI T) elseif (AND (EQ (LENGTH OLDADDRESSES) (LENGTH NEWADDRESSES)) (for O in OLDADDRESSES as N in NEWADDRESSES always (EQUAL.NSADDRESS O N))) then (RETURN (PRINTOUT T " (not changed)" T)) else (\NSMT.SHOW.RESULT (LISTP (CL:FUNCALL (if HADADDRESS then (FUNCTION CH.CHANGE.ITEM) else (FUNCTION CH.ADD.ITEM.PROPERTY)) NAME ADDRESS.PROPERTY NEWADDRESSES (QUOTE (CLEARINGHOUSE . NETWORK.ADDRESS.LIST))))))))
)
(\NSMT.CHANGE.ADMINISTRATORS
(LAMBDA (CHACCESSFN OPERATION) (* ; "Edited 20-Nov-90 16:15 by bvm") (* ;; "Add/remove a domain administrator") (LET (DOMAIN INDIVIDUAL) (DECLARE (USEDFREE *LASTNAME* *LASTDOMAIN* *LASTSTRING*)) (COND ((AND (SETQ INDIVIDUAL (\NSMT.READFNAME " name:" *LASTNAME*)) (SETQ DOMAIN (\NSMT.READFNAME (SELECTQ OPERATION (ADD " to domain:") (REMOVE " from domain:") (SHOULDNT)) *LASTDOMAIN* T T))) (REMHASH (create NSNAME using DOMAIN NSOBJECT _ "*") *REAL-NAME-CACHE*) (* ; "We're about to invalidate this cache entry") (\NSMT.SHOW.RESULT (CL:FUNCALL CHACCESSFN DOMAIN (QUOTE Administrators) INDIVIDUAL)) (SETQ *LASTSTRING* (SETQ *LASTNAME* INDIVIDUAL)) (SETQ *LASTDOMAIN* DOMAIN)))))
)
(\NSMT.CHANGE.FORWARDING
(LAMBDA NIL (* ; "Edited 20-Nov-90 13:00 by bvm") (* ;; "Change the %"Forwarding%" list for a user. Since NS doesn't really have forwarding, it is faked by giving an object a MEMBERS property--the mail system, finding no mailbox, looks at the members and sends the message to all of them.") (PROG (PROPS GOODPROPS NAME REALNAME OLDFORWARDING NEWFORWARDING HADFORWARDING HADUSERGROUP) (DECLARE (USEDFREE *LASTSTRING* *LASTNAME* *LASTGROUP*)) (if (NOT (SETQ NAME (\NSMT.READFNAME " for user:" *LASTNAME*))) then (RETURN)) (TERPRI T) (SETQ PROPS (CH.LIST.PROPERTIES NAME)) (* ; "returns (realname props)") (if (EQ (SETQ REALNAME (CAR PROPS)) (QUOTE ERROR)) then (* ; "Object does not exist, probably") (RETURN (\NSMT.SHOW.RESULT PROPS))) (if (MEMB (CH.PROPERTY (QUOTE USER)) (SETQ PROPS (CADR PROPS))) then (* ; "Ok, it's a user") else (PRINTOUT T T REALNAME " is not a User") (if (NULL (SETQ GOODPROPS (\NSMT.DESCRIPTIVE.PROPS PROPS))) then (RETURN (PRINTOUT T ", or any other type I know about." T))) (PRINTOUT T ", but a " (\NSMT.PRETTY.PROPERTY (CAR GOODPROPS))) (if (CDR GOODPROPS) then (PRINTOUT T " (also " (CONCATLIST (CDR (for P in (CDR GOODPROPS) join (LIST ", " (\NSMT.PRETTY.PROPERTY P))))) ")")) (if (EQ (CAR GOODPROPS) (CH.PROPERTY (QUOTE USERGROUP))) then (RETURN (PRINTOUT T " Groups %"forward%" to their members." T)) elseif (NOT (CL:Y-OR-N-P "Are you sure you want to change the Forwarding? ")) then (RETURN))) (if (SETQ HADFORWARDING (MEMB (CH.PROPERTY (QUOTE MEMBERS)) PROPS)) then (* ; "There's already forwarding, so fetch it") (SETQ OLDFORWARDING (CH.RETRIEVE.MEMBERS REALNAME)) else (PRINTOUT T REALNAME " does not yet have Forwarding." T)) (SETQ HADUSERGROUP (MEMB (CH.PROPERTY (QUOTE USERGROUP)) PROPS)) (SETQ *LASTSTRING* (SETQ *LASTNAME* REALNAME)) (PRINTOUT T "Type one or more NS names, separated by commas." T) (if (NULL (SETQ NEWFORWARDING (MAPCAR (\NSMT.READ.COMMA.LIST "Forward to: " (for NAME in OLDFORWARDING collect (NSNAME.TO.STRING NAME T))) (FUNCTION PARSE.NSNAME)))) then (* ; "No new forwarding...delete old?") (if (NOT HADFORWARDING) then (RETURN (PRINTOUT T " (not changed)" T)) elseif (NOT (CL:Y-OR-N-P "Remove forwarding for ~A? " REALNAME)) then (RETURN)) elseif (AND (EQ (LENGTH OLDFORWARDING) (LENGTH NEWFORWARDING)) (for O in OLDFORWARDING as N in NEWFORWARDING always (* ; "See if the lists are the same. Could use EQUAL.CH.NAMES, but want to be able to recognize case differences") (AND (CL:STRING= (fetch NSOBJECT of O) (fetch NSOBJECT of N)) (CL:STRING= (fetch NSDOMAIN of O) (fetch NSDOMAIN of N)) (CL:STRING= (fetch NSORGANIZATION of O) (fetch NSORGANIZATION of N))))) then (RETURN (PRINTOUT T " (not changed)"))) (WITH-CHS (S REALNAME) (* ;; "Ok, ready to either delete old forwarding or change it. Since there is no command to replace group membership, the easiest thing when prop already existed is to delete the old one and add the new one") (PROG ((AUTH (\NSMT.GETAUTHENTICATOR)) RESULT) (if HADFORWARDING then (* ;; "In either case, we want to delete the old members prop.") (SETQ RESULT (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE DELETE.PROPERTY) REALNAME (CH.PROPERTY (QUOTE MEMBERS)) AUTH (QUOTE RETURNERRORS))) (if (EQ (CAR RESULT) (QUOTE ERROR)) then (RETURN (\NSMT.SHOW.RESULT RESULT)))) (if (NOT NEWFORWARDING) then (PRINTOUT T "Forwarding removed") (if (AND HADUSERGROUP (EQ (CAR (SETQ RESULT (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE DELETE.PROPERTY) REALNAME (CH.PROPERTY (QUOTE USERGROUP)) AUTH (QUOTE RETURNERRORS)))) (QUOTE ERROR))) then (* ; "Failed to delete the %"group%" comment") (PRINTOUT T ", but failed to remove the forwarding comment because: " (CADDR RESULT) T) else (PRINTOUT T "." T)) else (* ;; "Create new membership ") (SETQ RESULT (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.GROUP.PROPERTY) REALNAME (CH.PROPERTY (QUOTE MEMBERS)) (FUNCTION (LAMBDA (DATASTREAM) (* ; "Function to write the membership onto the bulk data stream") (COURIER.WRITE.BULKDATA DATASTREAM NEWFORWARDING NIL (QUOTE NSNAME)))) AUTH (QUOTE RETURNERRORS))) (if (EQ (CAR RESULT) (QUOTE ERROR)) then (\NSMT.SHOW.RESULT RESULT) else (if (NOT HADUSERGROUP) then (SETQ RESULT (COURIER.CALL S (QUOTE CLEARINGHOUSE) (QUOTE ADD.ITEM.PROPERTY) REALNAME (CH.PROPERTY (QUOTE USERGROUP)) (COURIER.WRITE.REP (CONCAT "Forwarding for " (fetch NSOBJECT of REALNAME)) (QUOTE CLEARINGHOUSE) (QUOTE STRING)) AUTH (QUOTE RETURNERRORS))) (* ; "This isn't strictly necessary, but I think some tools expect it to be there") (if (EQ (CAR RESULT) (QUOTE ERROR)) then (PRINTOUT T "(Failed to set usergroup comment)" T))) (PRINTOUT T "Done, forwarding set to ") (\NSMT.PRINT.LIST NEWFORWARDING) (TERPRI T)))))))
)
(\NSMT.CHANGE.GROUP.COMPONENT
(LAMBDA (CHFN OPERATION SELF/LIST) (* ; "Edited 21-Nov-90 13:06 by bvm") (* ;; "Add or remove a member from to/from a group. CHACCESSFN is the CH function that will make the change, OPERATION is ADD or REMOVE, and SELF/LIST is one of T (self), NIL (general member) or the name of an access list property.") (LET (GROUP INDIVIDUAL ORIGINAL) (if (AND (OR (EQ SELF/LIST T) (SETQ INDIVIDUAL (\NSMT.READFNAME " name:" *LASTNAME* NIL NIL (COND ((EQ OPERATION (QUOTE REMOVE)) (* ; "Want to be able to remove bogus names if they got on there somehow, so let's do the processing ourselves") NIL) (SELF/LIST (* ; "must be valid ns name") T) (T (* ; "use canonical name, but foreign names ok") :FOREIGN)) :ANY))) (PROGN (if (AND (EQ OPERATION (QUOTE REMOVE)) (NEQ SELF/LIST T) (NOT (STRPOS "*" (NSNAME.TO.STRING INDIVIDUAL)))) then (* ; "Do name fixing ourselves so we can keep track of the original (below)") (SETQ INDIVIDUAL (OR (\NSMT.LOOKUP (SETQ ORIGINAL INDIVIDUAL)) INDIVIDUAL))) (SETQ GROUP (\NSMT.READFNAME (SELECTQ OPERATION (ADD " to group:") (REMOVE " from group:") (SHOULDNT)) *LASTGROUP* NIL T)))) then (* ;; "Ok, here's a name and a group, try the desired operation") (CASE SELF/LIST ((T NIL) (* ; "We're about to spoil the cache") (SETQ *LAST-MEMBERSHIP* NIL))) (WITH-CHS (S GROUP) (PROG ((AUTH (\NSMT.GETAUTHENTICATOR)) (MEMBER INDIVIDUAL) RESULT) RETRY (SETQ RESULT (CASE SELF/LIST ((T) (* ; "adding/removing self") (COURIER.CALL S (QUOTE CLEARINGHOUSE) CHFN GROUP (CH.PROPERTY (QUOTE MEMBERS)) AUTH (QUOTE RETURNERRORS))) ((NIL) (* ; "adding/removing member") (COURIER.CALL S (QUOTE CLEARINGHOUSE) CHFN GROUP (CH.PROPERTY (QUOTE MEMBERS)) MEMBER AUTH (QUOTE RETURNERRORS))) (T (* ; "Adding/removing from access list") (COURIER.CALL S (QUOTE CHACCESSCONTROL) CHFN GROUP (CH.PROPERTY (QUOTE MEMBERS)) SELF/LIST MEMBER (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) CREDENTIALS of AUTH) (COURIER.FETCH (CLEARINGHOUSE . AUTHENTICATOR) VERIFIER of AUTH) (QUOTE RETURNERRORS))))) (if (AND (LISTP RESULT) (EQ (CADDR RESULT) (QUOTE NoChange)) ORIGINAL (EQ MEMBER INDIVIDUAL) (NOT (EQUAL.CH.NAMES INDIVIDUAL ORIGINAL))) then (* ;; "Command was to remove something. We first tried the full name, but CH said nothing happened. So try original name, just in case someone got an alias on the list by mistake.") (SETQ MEMBER ORIGINAL) (GO RETRY)) (if (\NSMT.SHOW.RESULT (LISTP RESULT) NIL GROUP MEMBER) then (* ; "Success") (if (NEQ MEMBER INDIVIDUAL) then (PRINTOUT T "(removed " (NSNAME.TO.STRING ORIGINAL T) ")" T)) (SETQ *LASTSTRING* (SETQ *LASTGROUP* RESULT))))) (if INDIVIDUAL then (SETQ *LASTNAME* INDIVIDUAL)))))
)
(\NSMT.CHANGE.REMARK
(LAMBDA NIL (* ; "Edited 20-Nov-90 12:58 by bvm") (PROG (PROPS GOODPROPS MAINPROP NAME REALNAME RESULT REMARK OLDREMARK) (DECLARE (USEDFREE *LASTSTRING* *LASTNAME* *LASTGROUP*)) (if (NOT (SETQ NAME (\NSMT.READFNAME " for object:" *LASTSTRING*))) then (RETURN)) (SETQ PROPS (CH.LIST.PROPERTIES NAME)) (* ; "returns (realname props)") (if (EQ (SETQ REALNAME (CAR PROPS)) (QUOTE ERROR)) then (* ; "Object does not exist, probably") (RETURN (\NSMT.SHOW.RESULT PROPS))) (if (NULL (SETQ GOODPROPS (\NSMT.DESCRIPTIVE.PROPS (CADR PROPS)))) then (printout T T (SETQ *LASTSTRING* REALNAME) " has no remarkable properties." T) (if (NULL (SETQ MAINPROP (\NSMT.GET.OBJECT.TYPE "Add remark of type (<cr> to abort): "))) then (RETURN)) else (if (OR (NULL (CDR GOODPROPS)) (AND (EQ (CAR GOODPROPS) (CH.PROPERTY (QUOTE USER))) (EQ (CADR GOODPROPS) (CH.PROPERTY (QUOTE USERGROUP))) (NULL (CDDR GOODPROPS)))) then (* ; "only one, the normal case (or both user & usergroup, in which case we ignore the boring forwarding remark)") (CL:FORMAT T " (~@[~A -- ~]a ~A)" (AND (NOT (EQUAL.CH.NAMES REALNAME NAME)) (NSNAME.TO.STRING REALNAME)) (\NSMT.PRETTY.PROPERTY (SETQ MAINPROP (CAR GOODPROPS)))) else (PRINTOUT T T (NSNAME.TO.STRING REALNAME) " has the descriptive properties ") (\NSMT.PRINT.LIST (SETQ GOODPROPS (for P in GOODPROPS collect (OR (CH.NUMBER.TO.PROPERTY P) P)))) (if (NULL (SETQ MAINPROP (\NSMT.CHOOSE "Specify property to modify: " GOODPROPS))) then (RETURN))) (TERPRI T) (if (SETQ OLDREMARK (CADR (CH.RETRIEVE.ITEM REALNAME MAINPROP))) then (* ; "Retrieve carefully in case the prop is null") (SETQ OLDREMARK (COURIER.READ.REP OLDREMARK NIL (QUOTE STRING))))) (if (NOT (FIXP MAINPROP)) then (* ; "Convert prop we got from interaction back to number") (SETQ MAINPROP (CH.PROPERTY MAINPROP))) (if (SETQ REMARK (\NSMT.GET.REMARK OLDREMARK)) then (PRIN1 "..." T) (\NSMT.SHOW.RESULT (LISTP (if GOODPROPS then (CH.CHANGE.ITEM REALNAME MAINPROP REMARK (QUOTE STRING)) else (CH.ADD.ITEM.PROPERTY REALNAME MAINPROP REMARK (QUOTE STRING))))) else (PRINTOUT T " xxx" T)) (SETQ *LASTSTRING* (if (EQ MAINPROP (CH.PROPERTY (QUOTE USERGROUP))) then (SETQ *LASTGROUP* REALNAME) else (SETQ *LASTNAME* REALNAME)))))
)
(\NSMT.GET.OBJECT.TYPE
(LAMBDA (PROMPT) (* ; "Edited 19-Nov-90 14:50 by bvm") (\NSMT.CHOOSE PROMPT (OR *OBJECTTYPES* (SETQ *OBJECTTYPES* (SORT (for P in *NSMAINTAIN-DESCRIPTIVE-PROPERTIES* collect (OR (CH.NUMBER.TO.PROPERTY P) P)))))))
)
(\NSMT.REMOVE.ALIAS
(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (ALIAS) (COND ((NULL (SETQ ALIAS (\NSMT.READFNAME " alias:" NIL NIL T)))) ((NLISTP (SETQ ALIAS (CH.DELETE.ALIAS ALIAS))) (* ; "Success, returned canonical name") (CL:FORMAT T "done, alias was removed from ~S~%%" (SETQ *LASTSTRING* ALIAS))) (T (\NSMT.SHOW.RESULT ALIAS)))))
)
(\NSMT.REMOVE.OBJECT
(LAMBDA (NAME) (* ; "Edited 18-Aug-89 17:12 by bvm") (COND ((AND (OR NAME (SETQ NAME (\NSMT.READFNAME ":" *LASTSTRING* NIL T))) (SETQ NAME (\NSMT.DESCRIBE.OBJECT NAME T)) (CL:Y-OR-N-P " Confirm deletion (y or n): ")) (\NSMT.SHOW.RESULT (LISTP (CH.DELETE.OBJECT NAME))))))
)
(\NSMT.REMOVE.USER
(LAMBDA NIL (* ; "Edited 18-Aug-89 17:12 by bvm") (LET (USER INFO) (COND ((NULL (SETQ USER (\NSMT.READFNAME ":" *LASTNAME* NIL T)))) ((NULL (SETQ INFO (CH.RETRIEVE.ITEM USER (QUOTE USER)))) (PRINTOUT T " not a user." T)) (T (PRINTOUT T T (NSNAME.TO.STRING (CAR INFO) T)) (COND ((CADR INFO) (CL:FORMAT T " (~A)" (COURIER.READ.REP (CADR INFO) NIL (QUOTE STRING))))) (COND ((CL:Y-OR-N-P " Confirm deletion (y or n): ") (\NSMT.SHOW.RESULT (LISTP (CH.DELETE.OBJECT USER)))))))))
)
)
(FILESLOAD (SYSLOAD) DES AUTHENTICATION)
(* ; "Patch to clearinghouse")
(DEFINEQ
(CH.FINDSERVER
(LAMBDA (DOMAINPATTERN NOERRORFLG DONTPROBEFLG) (* ; "Edited 20-Feb-91 16:16 by bvm") (* ;; "Find a Clearinghouse which serves the specified domain and return its NS address. If DONTPROBEFLG is T, just search the cache.") (OR (type? NSNAME DOMAINPATTERN) (SETQ DOMAINPATTERN (PARSE.NSNAME DOMAINPATTERN 2))) (LET ((ORGANIZATION (fetch NSORGANIZATION of DOMAINPATTERN)) (DOMAIN (fetch NSDOMAIN of DOMAINPATTERN)) (GLUE "CHServers") ORGANIZATION.INFO) (if (STRING-EQUAL ORGANIZATION GLUE) then (* ; "Shift right") (if (STRING-EQUAL DOMAIN GLUE) then (* ; "Everyone handles this") (GETCLEARINGHOUSE) else (CAR (CAR (fetch OCALLSERVERS of (\CH.FIND.ORG.SERVER DOMAIN NOERRORFLG DONTPROBEFLG))))) else (SETQ ORGANIZATION.INFO (\CH.FIND.ORG.SERVER ORGANIZATION NOERRORFLG DONTPROBEFLG)) (if (STRING-EQUAL DOMAIN "*") then (* ; "Any server in the org will do.") (CAR (CAR (fetch OCALLSERVERS of ORGANIZATION.INFO))) elseif (for DOMAIN.INFO in (fetch OCDOMAINS of ORGANIZATION.INFO) when (STRING-EQUAL (fetch DCDOMAIN of DOMAIN.INFO) DOMAIN) do (RETURN (CAR (CAR (fetch DCKNOWNSERVERS of DOMAIN.INFO))))) elseif DONTPROBEFLG then (AND (NOT NOERRORFLG) (ERROR "Couldn't find Clearinghouse server for domain" DOMAINPATTERN T)) else (* ;; "Ask a clearinghouse in ORGANIZATION to find servers for this domain. For simplicity, assume the first one will tell us. This should be 'Local Clearinghouse' if it serves ORGANIZATION") (\CH.LOCATE.SERVERS (CAR (CAR (fetch OCALLSERVERS of ORGANIZATION.INFO))) (create NSNAME NSOBJECT _ DOMAIN NSDOMAIN _ ORGANIZATION NSORGANIZATION _ GLUE) NOERRORFLG ORGANIZATION DOMAIN) (CH.FINDSERVER DOMAINPATTERN NOERRORFLG T)))))
)
)
(RPAQQ *NSMAINTAIN-COMMANDS* (("?" "" RETURN (FUNCTION \NSMT.HELP)) ("Add Alias" "" RETURN (FUNCTION \NSMT.ADD.ALIAS)) ("Add Domain Administrator" "" RETURN (QUOTE (\NSMT.CHANGE.ADMINISTRATORS CH.ADD.MEMBER.TO.DOMAIN.ACL ADD))) ("Add Friend" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT ADD.MEMBER.TO.PROPERTY.ACL ADD selfControllers))) ("Add Group" "" RETURN (FUNCTION \NSMT.ADD.GROUP)) ("Add Member" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT ADD.MEMBER ADD))) ("Add Owner" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT ADD.MEMBER.TO.PROPERTY.ACL ADD Administrators))) ("Add Registered Object" "" RETURN (FUNCTION \NSMT.ADD.OBJECT)) ("Add Self" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT ADD.SELF ADD T))) ("Add User" "" RETURN (FUNCTION \NSMT.ADD.USER)) ("Remove Alias" "" RETURN (FUNCTION \NSMT.REMOVE.ALIAS)) ("Remove Domain Administrator" "" RETURN (QUOTE (\NSMT.CHANGE.ADMINISTRATORS CH.DELETE.MEMBER.FROM.DOMAIN.ACL REMOVE))) ("Remove Friend" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT DELETE.MEMBER.FROM.PROPERTY.ACL REMOVE selfControllers))) ("Remove Member" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT DELETE.MEMBER REMOVE))) ("Remove Owner" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT DELETE.MEMBER.FROM.PROPERTY.ACL REMOVE Administrators))) ("Remove Registered Object" "" RETURN (FUNCTION \NSMT.REMOVE.OBJECT)) ("Remove Self" "" RETURN (QUOTE (\NSMT.CHANGE.GROUP.COMPONENT DELETE.SELF REMOVE T))) ("Remove User" "" RETURN (FUNCTION \NSMT.REMOVE.USER)) ("Change Address" "" RETURN (FUNCTION \NSMT.CHANGE.ADDRESS)) ("Change Default Domain" "" RETURN (FUNCTION \NSMT.CHANGE.DOMAIN)) ("Change Forwarding" "" RETURN (FUNCTION \NSMT.CHANGE.FORWARDING)) ("Change Login" "" RETURN (FUNCTION \NSMT.LOGIN)) ("Change Password" "" RETURN (FUNCTION \NSMT.CHANGE.PASSWORD)) ("Change Remark" "" RETURN (FUNCTION \NSMT.CHANGE.REMARK)) ("Describe" "" RETURN (FUNCTION \NSMT.TYPE.ENTRY)) ("List Aliases" "" RETURN (QUOTE (\NSMT.LIST.OBJECTS ALIAS))) ("List Administrators" "" RETURN (FUNCTION \NSMT.LIST.ADMINISTRATORS)) ("List Clearinghouses" "" RETURN (FUNCTION \NSMT.LIST.CLEARINGHOUSES)) ("List Domains" "" RETURN (FUNCTION \NSMT.LIST.DOMAINS)) ("List Groups" "" RETURN (QUOTE (\NSMT.LIST.OBJECTS MEMBERS))) ("List Members" "" RETURN (FUNCTION \NSMT.TYPE.MEMBERS)) ("List Objects" "" RETURN (FUNCTION \NSMT.LIST.OBJECTS)) ("List Servers" "" RETURN (FUNCTION \NSMT.LIST.SERVERS)) ("List True Groups" "" RETURN (QUOTE (\NSMT.LIST.OBJECTS MEMBERS \NSMT.GROUP.FILTER))) ("List Users" "" RETURN (QUOTE (\NSMT.LIST.OBJECTS USER))) ("Show Details of previously listed names" "" RETURN (FUNCTION \NSMT.SHOW.DETAILS)) ("Type Entry" "" RETURN (FUNCTION \NSMT.TYPE.ENTRY) EXPLAINSTRING "Type Entry -- same as Describe") ("Type Members" "" RETURN (FUNCTION \NSMT.TYPE.MEMBERS) EXPLAINSTRING "Type Members -- same as List Members") ("Uncache All Clearinghouses" " [confirm]" CONFIRMFLG T RETURN (QUOTE (\NSMT.UNCACHE T))) ("Uncache Clearinghouse for domain" "" RETURN (FUNCTION \NSMT.UNCACHE)) ("Uncache Local (force Maintain to refetch some info)" " [confirm]" CONFIRMFLG T RETURN (FUNCTION \NSMT.CLEAR.NAME.CACHE)) ("Quit" " [confirm]" CONFIRMFLG T RETURN NIL)))
(RPAQQ *NSMAINTAIN-ABORT-ITEM* ("" "" EXPLAINSTRING "<cr> - abort" RETURN NIL))
(ADDTOVAR CH.PROPERTIES (ALIAS 1) (BOOT.SERVICE 10026))
(ADDTOVAR *NSMAINTAIN-DESCRIPTIVE-PROPERTIES* 10000 10001 10002 10003 10004 10005 10006 10007 10008 10009 10010 10011 10012 10013 10014 10015 10016 10017 10018 10019 10020 10021 10022 10023 10024 10026)
(ADDTOVAR *NSMAINTAIN-IGNORE-PROPERTIES* 6 7 10027 20003 20002 20101)
(ADDTOVAR *NSMAINTAIN-PROPERTY-FORMATS* (4 CLEARINGHOUSE . NETWORK.ADDRESS.LIST) (8 RECORD (SIMPLE BOOLEAN) (STRONG BOOLEAN)) (30 . NSNAME) (31 CLEARINGHOUSE . MAILBOX.VALUES) (10000 . STRING) (10001 . STRING) (10002 . STRING) (10003 . STRING) (10004 . STRING) (10005 . STRING) (10006 . STRING) (10007 . STRING) (10008 . STRING) (10009 . STRING) (10010 . STRING) (10011 . STRING) (10012 . STRING) (10013 . STRING) (10014 . STRING) (10015 . STRING) (10016 . STRING) (10017 . STRING) (10018 . STRING) (10019 . STRING) (10020 . STRING) (10021 . STRING) (10022 . STRING) (10023 . STRING) (10024 . STRING) (10026 . STRING) (10029 . STRING) (10030 . STRING) (10032 . STRING) (10034 . STRING) (10035 . STRING) (15002 . STRING) (20000 CLEARINGHOUSE . USERDATA.VALUE) (20001 GAP . RS232CData) (20006 SEQUENCE NSNAME) (20007 . NSNAME) (20102 GAP . RS232CBack) (29965 . STRING) (30005 . NSNAME))
(ADDTOVAR *NSMAINTAIN-MEMBER-PROPERTIES* 3 20006)
(RPAQ? *NSMAINTAIN-MEMBER-THRESHOLD* 3)
(RPAQ? *NSMAINTAIN-SHOW-GROUP-ACCESS*)
(DECLARE%: EVAL@COMPILE
(CL:PROCLAIM (QUOTE (CL:SPECIAL *NSMAINTAIN-MEMBER-THRESHOLD* *NSMAINTAIN-SHOW-GROUP-ACCESS*)))
(CL:PROCLAIM (QUOTE (GLOBAL *NSMAINTAIN-MEMBER-PROPERTIES* *NSMAINTAIN-PROPERTY-FORMATS* *NSMAINTAIN-IGNORE-PROPERTIES* *NSMAINTAIN-DESCRIPTIVE-PROPERTIES*)))
DONTCOPY
(DEFMACRO WITH-CHS ((STREAMVAR DOMAIN) &BODY BODY) (BQUOTE (LET (((\, STREAMVAR) (\NSMT.COURIER.OPEN (\, DOMAIN)))) (AND (\, STREAMVAR) (CL:UNWIND-PROTECT (PROGN (\,@ BODY)) (CLOSEF? (\, STREAMVAR)))))))
(FILESLOAD (LOADCOMP) CLEARINGHOUSE)
(DECLARE%: EVAL@COMPILE
(RPAQQ \CH.BROADCAST.SOCKET 20)
(CONSTANTS \CH.BROADCAST.SOCKET)
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS *NSMAINTAIN-COMMANDS* *NSMAINTAIN-ABORT-ITEM* CH.PROPERTIES)
)
(CL:PROCLAIM (QUOTE (CL:SPECIAL *USER* *LASTDOMAIN* *LASTNAME* *LASTGROUP* *LASTLIST* *LASTSTRING* *LAST-MEMBERSHIP* *SERVERTYPES* *ALLTYPES* *OBJECTTYPES* *DEFAULTDOMAIN* *REAL-NAME-CACHE* *DOMAIN*)))
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(RPAQ *NSMT-MENU-FNS* (CL:REMOVE-DUPLICATES (FOR ENTRY IN *NSMAINTAIN-COMMANDS* WHEN (LISTP (SETQ ENTRY (CADR (MEMB (QUOTE RETURN) ENTRY)))) COLLECT (IF (EQ (CAR ENTRY) (QUOTE FUNCTION)) THEN (CADR ENTRY) ELSEIF (EQ (CAR ENTRY) (QUOTE QUOTE)) THEN (CAR (LISTP (CADR ENTRY)))))))
)
(PUTPROPS NSMAINTAIN COPYRIGHT ("Xerox Corporation" 1985 1986 1987 1989 1990 1991 1992))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (4329 24808 (NSMAINTAIN 4339 . 5822) (\NSMT.INITIAL.LOGIN 5824 . 6771) (\NSMT.HELP 6773
. 8409) (\NSMT.READFNAME 8411 . 11270) (\NSMT.LOOKUP 11272 . 12144) (\NSMT.LOOKUP1 12146 . 12707) (
\NSMT.CHECK.DOMAIN 12709 . 14737) (\NSMT.DOMAIN.MAY.EXIST 14739 . 14873) (\NSMT.FOREIGN.DOMAINP 14875
. 16123) (\NSMT.COLLECT.NAMES 16125 . 16439) (\NSMT.GET.REMARK 16441 . 16733) (\NSMT.GET.PASSWORD
16735 . 17316) (\NSMT.LOGIN 17318 . 17852) (\NSMT.GETAUTHENTICATOR 17854 . 18406) (\NSMT.CHANGE.DOMAIN
18408 . 18851) (\NSMT.PRINT.LIST 18853 . 19162) (\NSMT.PRINT.OBJECTS 19164 . 19642) (
\NSMT.PROCESS.LIST 19644 . 20446) (\NSMT.READ.COMMA.LIST 20448 . 21251) (\NSMT.SHOW.RESULT 21253 .
22013) (\NSMT.CHOOSE 22015 . 22229) (\NSMT.COURIER.OPEN 22231 . 23145) (\NSMT.CLEAR.CACHE 23147 .
24365) (EQUAL.NSADDRESS 24367 . 24806)) (24848 40360 (\NSMT.CHANGE.PASSWORD 24858 . 25614) (
\NSMT.DESCRIBE.ACL 25616 . 26848) (\NSMT.DESCRIBE.OBJECT 26850 . 30408) (\NSMT.DESCRIPTIVE.PROPS 30410
. 30901) (\NSMT.DESCRIBE.PROPERTY 30903 . 32520) (\NSMT.PRETTY.PROPERTY 32522 . 32722) (
\NSMT.LIST.OBJECTS 32724 . 33567) (\NSMT.LIST.CLEARINGHOUSES 33569 . 34849) (\NSMT.LIST.SERVERS 34851
. 35554) (\NSMT.SHOW.DETAILS 35556 . 36371) (\NSMT.GROUP.FILTER 36373 . 36988) (
\NSMT.LIST.ADMINISTRATORS 36990 . 37271) (\NSMT.FETCH.ADMINISTRATORS 37273 . 37943) (
\NSMT.FETCH.ADMINISTRATORS1 37945 . 38231) (\NSMT.LIST.DOMAINS 38233 . 38479) (\NSMT.TYPE.ENTRY 38481
. 38670) (\NSMT.TYPE.MEMBERS 38672 . 39663) (\NSMT.UNCACHE 39665 . 39973) (\NSMT.CLEAR.NAME.CACHE
39975 . 40358)) (40400 61713 (\NSMT.ADD.ALIAS 40410 . 41034) (\NSMT.ADD.GROUP 41036 . 44171) (
\NSMT.SET.INITIAL.ACL 44173 . 44831) (\NSMT.ADD.USER 44833 . 46004) (\NSMT.ADD.OBJECT 46006 . 46792) (
\NSMT.CREATE.OBJECT 46794 . 47043) (\NSMT.ADD.OBJECT.GENERIC 47045 . 47969) (\NSMT.CHANGE.ADDRESS
47971 . 50037) (\NSMT.CHANGE.ADMINISTRATORS 50039 . 50750) (\NSMT.CHANGE.FORWARDING 50752 . 55440) (
\NSMT.CHANGE.GROUP.COMPONENT 55442 . 58095) (\NSMT.CHANGE.REMARK 58097 . 60313) (\NSMT.GET.OBJECT.TYPE
60315 . 60556) (\NSMT.REMOVE.ALIAS 60558 . 60911) (\NSMT.REMOVE.OBJECT 60913 . 61211) (
\NSMT.REMOVE.USER 61213 . 61711)) (61795 63477 (CH.FINDSERVER 61805 . 63475)))))
STOP

251
library/PCTREE Normal file
View File

File diff suppressed because one or more lines are too long

2523
library/POSTSCRIPTSTREAM Normal file
View File

File diff suppressed because one or more lines are too long

1
library/POSTSCRIPTSTREAM.DATABASE Normal file
View File

File diff suppressed because one or more lines are too long

321
library/RDSYS Normal file
View File

File diff suppressed because one or more lines are too long

1
library/READNUMBER Normal file
View File

File diff suppressed because one or more lines are too long

1
library/READSYS Normal file
View File

File diff suppressed because one or more lines are too long

1
library/REMOTEVMEM Normal file
View File

File diff suppressed because one or more lines are too long

1
library/SAMEDIR Normal file
View File

File diff suppressed because one or more lines are too long

1
library/SCALEBITMAP Normal file
View File

File diff suppressed because one or more lines are too long

1
library/SEDIT-COMMONLISP Normal file
View File

File diff suppressed because one or more lines are too long

1
library/SKETCH Normal file
View File

File diff suppressed because one or more lines are too long

1
library/SKETCHBMELT Normal file
View File

File diff suppressed because one or more lines are too long

1
library/SKETCHEDIT Normal file
View File

File diff suppressed because one or more lines are too long

7756
library/SKETCHELEMENTS Normal file
View File

File diff suppressed because one or more lines are too long

1
library/SKETCHOBJ Normal file
View File

File diff suppressed because one or more lines are too long

1
library/SKETCHOPS Normal file
View File

File diff suppressed because one or more lines are too long

1
library/SKETCHSTREAM Normal file
View File

File diff suppressed because one or more lines are too long

943
library/SPY Normal file
View File

@@ -0,0 +1,943 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Apr-94 14:13:52" {DSK}<king>export>lispcore>library>SPY.;4 64372
changes to%: (FILES GRAPHER)
(FNS SPY.GRAPH.EDITOR SPY.UPDATE.TITLE SPY.MERGEINFO SPY.MAKEGRAPHNODES SPY.MAX
SPY.MERGE SPY.MERGE1 SPY.MERGETREE SPY.NEXT.TREE SPY.SUM SPY.MAKE.TREE
SPY.DELETE SPY.DUMP.BUFFER SPY.ORIGINAL SPY.MERGE.CALLEES)
previous date%: "28-Apr-94 15:56:32" {DSK}<king>export>lispcore>library>SPY.;3)
(* ; "
Copyright (c) 1984, 1985, 1987, 1988, 1990, 1991, 1993, 1994 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT SPYCOMS)
(RPAQQ SPYCOMS
((VARS SPY.BORDERS SPY.BUFFER.SIZE SPY.FRAGMENTS SPY.NOMERGEFNS SPY.MERGEINFO (SPY.HASH)
(SPY.GRAPH.MENU)
SPY.SHOW.PERCENTAGES SPY.SMALLGHOSTS SPY.ICON)
(INITVARS (SPY.NEXT 0)
(SPY.BUFFER)
(SPY.SHOWCOUNTS T)
(SPY.SHOW.THRESHOLD 1)
(SPY.MAXLINES 10)
(SPY.FREQUENCY 10)
(SPY.FONT '(GACHA 8))
(SPY.TREE))
(COMS * SPYOBJCOMS)
(FNS SPY.FIND.TREE SPY.TOGGLE SPY.TREE SPY.LEGEND SPY.GRAPH.EDITOR SPY.END SPY.MAKEGRAPHNODES
SPY.MAX SPY.MERGE SPY.MERGE1 SPY.MERGETREE SPY.NEXT.TREE SPY.SUM SPY.TITLE SPY.MAKE.TREE
SPY.UPDATE.TITLE SPY.DELETE SPY.DRAWBOX SPY.BUFFER.ENTRY SPY.BUTTON SPY.END.ENTRY
SPY.START SPY.INIT \SPY.INTERRUPT SPY.DUMP.BUFFER SPY.START.ENTRY SPY.ADD.ENTRY
SPY.ORIGINAL SPY.OVERFLOW SPY.MERGE.CALLEES SPY.PRINT)
(COMS (INITVARS (SPY.BUTTON))
(VARS SPY.OPEN SPY.CLOSED))
(VARIABLES SPY.POINTERS)
(GLOBALVARS SPY.OVERFLOWED \PERIODIC.INTERRUPT SPY.TREE SPY.BUFFER.SIZE SPY.NEXT
SPY.BUFFER.THRESHOLD SPY.BUFFER SPY.FREQUENCY SPY.SHOW.THRESHOLD SPY.MAXLINES SPY.FONT
)
(MACROS WITH-SPY WITH.SPY)
(DECLARE%: DONTCOPY (RECORDS SPYRECORD SPYDATA))
(INITRECORDS SPYRECORD)
(DECLARE%: DOCOPY DOEVAL@COMPILE (FILES GRAPHER READNUMBER IMAGEOBJ))))
(RPAQQ SPY.BORDERS ((NORMAL "Normal" 2 -1)
(GHOST "Shown elsewhere" 2 8840)
(RECURSIVEGHOST "End of recursive chain" 2 0 -1)
(MERGED "Includes other branches" 4 42405)
(SELFRECURSIVE "Includes self-recursive calls" 2 61375)
(RECURSIVE "Head of recursive chain" 4 28086)
(ENDOFLINE "exceeded depth limit" 6 64510)))
(RPAQQ SPY.BUFFER.SIZE 5120)
(RPAQQ SPY.FRAGMENTS T)
(RPAQQ SPY.NOMERGEFNS (SI::*UNWIND-PROTECT* CL:EVAL \EVAL-PROGN \INTERPRET-ARGUMENTS \INTERPRETER
\INTERPRETER1 ERRORSET \EVAL \EVALFORM APPLY \PROGV EVAL))
(RPAQQ SPY.MERGEINFO ((EXEC :EXEC)
(EXEC-READ-LINE :EXEC)
(EXEC-READ :EXEC)
(XCL-USER::LEX-DO-EVENT :EXEC)
(DO-EVENT :EXEC)
(EVAL-INPUT :EXEC)
(SI::*UNWIND-PROTECT* :ANY)
(\MAKE.PROCESS0 T)
(\PROC.REPEATEDLYEVALQT T)
(\EVALFORM T :EVAL)
(PROGN PROGN :EVAL T)
(TTYIN1 TTYIN)
(TTBIN TTYIN)
(TTWAITFORINPUT TTYIN)
(\PROGV :ANY)))
(RPAQQ SPY.HASH NIL)
(RPAQQ SPY.GRAPH.MENU NIL)
(RPAQQ SPY.SHOW.PERCENTAGES T)
(RPAQQ SPY.SMALLGHOSTS T)
(RPAQQ SPY.ICON #*(56 28)OOOOOOOOOOOOOO@@OOOOOOOOOOOOOO@@L@@@@@@@@@@@@C@@L@@@@@@@@@@@@C@@L@@@@@@@@@@@@C@@L@@@@@@@@COONC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@GOOOO@@N@@BC@@L@D@@@A@CB@@BC@@L@ENODE@LB@@BC@@L@E@IBIC@COONC@@L@ENOAAL@@@@@C@@L@DBHAAF@COONC@@L@ENHAAAHB@@BC@@L@D@@@A@FB@@BC@@L@GOOOO@AJ@@BC@@L@@@@@@@@F@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@B@@BC@@L@@@@@@@@COONC@@L@@@@@@@@@@@@C@@L@@@@@@@@@@@@C@@OOOOOOOOOOOOOO@@OOOOOOOOOOOOOO@@
)
(RPAQ? SPY.NEXT 0)
(RPAQ? SPY.BUFFER )
(RPAQ? SPY.SHOWCOUNTS T)
(RPAQ? SPY.SHOW.THRESHOLD 1)
(RPAQ? SPY.MAXLINES 10)
(RPAQ? SPY.FREQUENCY 10)
(RPAQ? SPY.FONT '(GACHA 8))
(RPAQ? SPY.TREE )
(RPAQQ SPYOBJCOMS ((FNS SPYOBJ SPYOBJ.BUTTON SPYOBJ.SAVE SPYOBJ.COPY SPYOBJ.GET SPYOBJ.IMAGEBOX
SPYOBJ.DISPLAY SPYOBJ.LABEL SPYOBJ.HEIGHT SPYOBJ.COPYIN SPY.COPYBUTTON
SPY.MERGEINFO)
[VARS (SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
(FUNCTION SPYOBJ.IMAGEBOX)
(FUNCTION SPYOBJ.SAVE)
(FUNCTION SPYOBJ.GET)
(FUNCTION SPYOBJ.COPY)
(FUNCTION SPYOBJ.BUTTON)
(FUNCTION SPYOBJ.COPYIN)
NIL NIL NIL NIL NIL NIL 'SPYNODE]
(DECLARE%: DONTCOPY DOEVAL@COMPILE (RECORDS FX SPYOBJDATA))
(INITRECORDS SPYOBJDATA)))
(DEFINEQ
(SPYOBJ
(LAMBDA (NAME PERCENT STATUS) (* ; "Edited 9-Sep-87 17:56 by Masinter") (IMAGEOBJCREATE (create SPYOBJDATA LABEL _ NAME PERCENT _ PERCENT CACHEDLABEL _ (LET ((*PRINT-PRETTY* NIL) (*PRINT-LEVEL* 1) (*PRINT-LENGTH* 1)) (CL:FORMAT NIL "~D ~S" PERCENT LABEL))) SPYOBJ.IMAGEFNS))
)
(SPYOBJ.BUTTON
(LAMBDA (OBJ WINDOWSTREAM SEL RELX RELY WINDOW TEXT BUTTON) (* lmm " 9-Jun-85 00:40") NIL))
(SPYOBJ.SAVE
(LAMBDA (OBJ STREAM) (* edited%: "11-Jun-85 05:03") (PRIN2 (fetch OBJECTDATUM OBJ) STREAM FILERDTBL)))
(SPYOBJ.COPY
(LAMBDA (OBJ) (* lmm " 9-Jun-85 00:43") OBJ))
(SPYOBJ.GET
(LAMBDA (STREAM TEXTSTREAM) (* lmm " 9-Jun-85 00:44") (IMAGEOBJCREATE (READ STREAM FILERDTBL) SPYOBJ.IMAGEFNS))
)
(SPYOBJ.IMAGEBOX
[LAMBDA (OBJ FONTSOURCE) (* ; "Edited 16-Aug-88 11:07 by sye")
(OR FONTSOURCE (SETQ FONTSOURCE SPY.FONT))
(LET ((DATA (fetch OBJECTDATUM OBJ)))
(LET ((HEIGHT (SPYOBJ.HEIGHT OBJ FONTSOURCE)))
(create IMAGEBOX
XSIZE _ (STRINGWIDTH (SPYOBJ.LABEL OBJ)
FONTSOURCE)
YSIZE _ HEIGHT
YDESC _ 0
XKERN _ 0])
(SPYOBJ.DISPLAY
(LAMBDA (OBJ STREAM) (* lmm " 9-Jun-85 01:13") (DSPFONT SPY.FONT STREAM) (LET ((DATA (fetch OBJECTDATUM OBJ))) (LET ((HEIGHT (SPYOBJ.HEIGHT OBJ STREAM))) (RELMOVETO 0 (QUOTIENT (DIFFERENCE HEIGHT (QUOTIENT (FONTHEIGHT STREAM) 2)) 2) STREAM) (PRIN3 (SPYOBJ.LABEL OBJ) STREAM))))
)
(SPYOBJ.LABEL
(LAMBDA (OBJ) (* lmm " 9-Jun-85 01:24") (LET ((DATUM (fetch OBJECTDATUM OBJ))) (with SPYOBJDATA DATUM CACHEDLABEL)))
)
(SPYOBJ.HEIGHT
(LAMBDA (OBJ STREAM) (* lmm " 9-Jun-85 00:51") (LET ((DATUM (fetch OBJECTDATUM OBJ)) (FH (FONTHEIGHT STREAM))) (with SPYOBJDATA DATUM (MAX FH (QUOTIENT (TIMES PERCENT SPY.MAXLINES FH) 100)))))
)
(SPYOBJ.COPYIN
(LAMBDA (A B C) (HELP)))
(SPY.COPYBUTTON
(LAMBDA (WINDOW) (* lmm " 9-Jun-85 01:55") (SPY.GRAPH.EDITOR WINDOW T)))
(SPY.MERGEINFO
[LAMBDA (NAME SPYDATA PARENT-NAME) (* ; "Edited 28-Apr-94 14:00 by sybalsky")
(OR [AND (fetch (SPYDATA MERGEINFO) of SPYDATA)
(for X in (fetch (SPYDATA MERGEINFO) of SPYDATA)
when (AND (EQ (CAR X)
NAME)
(FMEMB PARENT-NAME (CDR X))) do (RETURN (CDR X]
(CDR (FASSOC NAME SPY.MERGEINFO))
(if (STRPOS "\interpret-" NAME)
then '(:INTERPRETER CL:EVAL])
)
(RPAQ SPYOBJ.IMAGEFNS (IMAGEFNSCREATE (FUNCTION SPYOBJ.DISPLAY)
(FUNCTION SPYOBJ.IMAGEBOX)
(FUNCTION SPYOBJ.SAVE)
(FUNCTION SPYOBJ.GET)
(FUNCTION SPYOBJ.COPY)
(FUNCTION SPYOBJ.BUTTON)
(FUNCTION SPYOBJ.COPYIN)
NIL NIL NIL NIL NIL NIL 'SPYNODE))
(DECLARE%: DONTCOPY DOEVAL@COMPILE
(DECLARE%: EVAL@COMPILE
(ACCESSFNS FX ((FXBLOCK (ADDSTACKBASE DATUM))) (* ; "frame extension index")
(BLOCKRECORD FXBLOCK ((FLAGS BITS 3) (* ; "= \STK.FX")
(FAST FLAG)
(NIL FLAG)
(INCALL FLAG) (* ;
 "set when fncall microcode has to punt")
(VALIDNAMETABLE FLAG)(* ;
 "if on, NAMETABLE field is filled in. If off, is same as FNHEADER")
(NOPUSH FLAG) (* ;
 "when returning to this frame, don't push a value. Set by interrupt code")
(USECNT BITS 8)
(%#ALINK WORD) (* ; "low bit is SLOWP")
(FNHEADER FULLXPOINTER)
(NEXTBLOCK WORD)
(PC WORD)
(NAMETABLE# FULLXPOINTER)
(%#BLINK WORD)
(%#CLINK WORD)))
(BLOCKRECORD FXBLOCK ((FLAGBYTE BYTE)
(NIL BYTE)
(NIL BITS 15) (* ; "most of the bits of #ALINK")
(SLOWP FLAG) (* ;
 "if on, then BLINK and CLINK fields are valid. If off, they are implicit")
(NIL FULLXPOINTER 2)
(NAMETABHI WORD)
(NAMETABLO WORD)))
(TYPE? (IEQ (fetch (FX FLAGS) of DATUM)
\STK.FX))
[ACCESSFNS FX ((NAMETABLE (COND
((fetch (FX VALIDNAMETABLE) of DATUM)
(fetch (FX NAMETABLE#) of DATUM))
(T (fetch (FX FNHEADER) of DATUM)))
(PROGN (replace (FX FAST) of DATUM with NIL)
(replace (FX NAMETABLE#) of DATUM with
NEWVALUE)
(replace (FX VALIDNAMETABLE) of DATUM
with T)))
(FRAMENAME (fetch (FNHEADER FRAMENAME)
of (fetch (FX NAMETABLE) of DATUM)))
(INVALIDP (EQ DATUM 0)) (* ;
 "true when A/CLink points at nobody, i.e. FX is bottom of stack")
[FASTP (NOT (fetch (FX SLOWP) of DATUM))
(PROGN (CHECK (NULL NEWVALUE))
(COND
((fetch (FX FASTP) of DATUM)
(replace (FX %#BLINK) of DATUM
with (fetch (FX DUMMYBF) of DATUM))
(replace (FX %#CLINK) of DATUM
with (fetch (FX %#ALINK) of DATUM))
(replace (FX SLOWP) of DATUM with
T]
[BLINK (COND
((fetch (FX FASTP) of DATUM)
(fetch (FX DUMMYBF) of DATUM))
(T (fetch (FX %#BLINK) of DATUM)))
(PROGN (replace (FX %#BLINK) of DATUM with
NEWVALUE)
(COND
((fetch (FX FASTP) of DATUM)
(replace (FX %#CLINK) of DATUM
with (fetch (FX %#ALINK) of DATUM))
(replace (FX SLOWP) of DATUM with
T]
[CLINK (IDIFFERENCE (COND
((fetch (FX FASTP) of DATUM)
(fetch (FX %#ALINK) of DATUM))
(T (fetch (FX %#CLINK) of DATUM)))
\#ALINK.OFFSET)
(PROGN (replace (FX %#CLINK) of DATUM
with (IPLUS NEWVALUE \#ALINK.OFFSET))
(COND
((fetch (FX FASTP) of DATUM)
(replace (FX %#BLINK) of DATUM
with (fetch (FX DUMMYBF) of DATUM))
(replace (FX SLOWP) of DATUM with
T]
[ALINK (IDIFFERENCE (FLOOR (fetch (FX %#ALINK) of DATUM)
WORDSPERCELL)
\#ALINK.OFFSET)
(PROGN [COND
((fetch (FX FASTP) of DATUM)
(replace (FX %#BLINK) of DATUM
with (fetch (FX DUMMYBF) of DATUM))
(replace (FX %#CLINK) of DATUM
with (fetch (FX %#ALINK) of DATUM]
(replace (FX %#ALINK) of DATUM
with (IPLUS NEWVALUE \#ALINK.OFFSET
(SUB1 WORDSPERCELL]
[ACLINK (SHOULDNT)
(PROGN [COND
((fetch (FX FASTP) of DATUM)
(replace (FX %#BLINK) of DATUM
with (fetch (FX DUMMYBF) of DATUM]
(replace (FX %#CLINK) of DATUM
with (IPLUS NEWVALUE \#ALINK.OFFSET))
(replace (FX %#ALINK) of DATUM
with (IPLUS NEWVALUE \#ALINK.OFFSET
(SUB1 WORDSPERCELL]
(* ;
 "replaces A & C Links at once more efficiently than separately")
(DUMMYBF (IDIFFERENCE DATUM WORDSPERCELL))
(* ;; "This is either an actual BF or %"residual%" BF that provides enough BF to find its IVAR slot. This means that when a FX is copied, the cell preceding the FX is copied too.")
(IVAR (fetch (BF IVAR) of (fetch (FX DUMMYBF)
of DATUM)))
[CHECKED (AND (type? FX DATUM)
(OR (IEQ (fetch (FX DUMMYBF) of DATUM)
(fetch (FX BLINK) of DATUM))
(AND (fetch (BF RESIDUAL)
of (fetch (FX DUMMYBF)
of DATUM))
(IEQ (fetch (BF IVAR)
of (fetch (FX DUMMYBF)
of DATUM))
(fetch (BF IVAR)
of (fetch (FX BLINK)
of DATUM]
(FIRSTPVAR (IPLUS DATUM (fetch (FX FXSIZE) of T)))
(* ; "stack offset of PVAR0")
(FXSIZE (PROGN 10)) (* ;
 "fixed overhead from flags thru clink")
(PADDING (PROGN 4)) (* ;
 "doublecell of garbage for microcode use")
(FIRSTTEMP (IPLUS (fetch (FX FIRSTPVAR) of DATUM)
(fetch (FX NPVARWORDS) of DATUM)
(fetch (FX PADDING) of DATUM)))
(* ;
 "note that NPVARWORDS is obtained from the FNHEADER")
(SIZE (IDIFFERENCE (fetch (FX NEXTBLOCK) of DATUM)
DATUM])
(RECORD SPYOBJDATA (CACHEDLABEL PERCENT LABEL))
)
)
(DEFINEQ
(SPY.FIND.TREE
[LAMBDA (FN) (* ; "Edited 25-Sep-87 16:23 by jop")
(OR (find X in SPY.TREE suchthat (EQ (fetch (SPYRECORD NAME) of X)
FN))
(CAR (push SPY.TREE (create SPYRECORD
NAME _ FN
COUNT _ 0])
(SPY.TOGGLE
(LAMBDA NIL (* lmm "24-Oct-84 22:49") (if (EQ \PERIODIC.INTERRUPT (QUOTE \SPY.INTERRUPT)) then (SPY.END) (RESETFORM (CURSOR WAITINGCURSOR) (SPY.TREE 10)) else (SPY.START)))
)
(SPY.TREE
[LAMBDA (THRESHOLD INDIVIDUALP MERGETYPE DEPTHLIMIT) (* ; "Edited 9-Dec-87 13:10 by sye")
(COND
((NULL SPY.TREE)
"no spy samples have been gathered")
(T (PROG ((SPYDATA (create SPYDATA
PACKAGE _ *PACKAGE*
READTABLE _ *READTABLE*
PRINT-CASE _ *PRINT-CASE*
CUMULATIVE _ (NOT INDIVIDUALP)
THRESHOLD _ (OR THRESHOLD SPY.SHOW.THRESHOLD)
MERGETYPE _ (OR (if (EQ MERGETYPE 'DEFAULT)
then T
else MERGETYPE)
(COND
(INDIVIDUALP 'ALL)
(T T)))
DEPTH _ DEPTHLIMIT)))
(SPY.MAKE.TREE (SPY.MERGE SPY.TREE SPYDATA)
SPYDATA])
(SPY.LEGEND
(LAMBDA NIL (* lmm "28-Sep-84 21:27") (SHOWGRAPH (LAYOUTGRAPH (for X in SPY.BORDERS collect (create GRAPHNODE NODEID _ X NODELABEL _ (CADR X) TONODES _ NIL NODEFONT _ SPY.FONT NODEBORDER _ (CDDR X) NODELABELSHADE _ (CADDR (CDDR X)))) (REVERSE SPY.BORDERS) NIL SPY.FONT NIL 10) "SPY border interpretation" (QUOTE NILL) (QUOTE NILL)))
)
(SPY.GRAPH.EDITOR
[LAMBDA (W COPY) (* ; "Edited 29-Apr-94 14:03 by sybalsky")
(PROG* ((TREES (WINDOWPROP W 'TREES))
NEW-TREES
(TOPCOUNT (WINDOWPROP W 'TOPCOUNT))
(WINDOW W)
NODE LASTNODE ACTION (SPYDATA (WINDOWPROP W 'SPYDATA))
PENDING
[MULTIPLE (AND (= (LOGAND LASTKEYBOARD 32)
32)
(MOUSESTATE (OR LEFT MIDDLE]
(*READTABLE* (fetch (SPYDATA READTABLE) of SPYDATA))
(*PACKAGE* (fetch (SPYDATA PACKAGE) of SPYDATA))
(*PRINT-CASE* (fetch (SPYDATA PRINT-CASE) of SPYDATA)))
(TOTOPW W)
(do (SETQ NODE (OR (NODELST/AS/MENU (fetch (GRAPH GRAPHNODES)
of (WINDOWPROP W 'GRAPH))
(CONS (LASTMOUSEX W)
(LASTMOUSEY W)))
COPY))
(if (NEQ NODE LASTNODE)
then [COND
(LASTNODE (if (EQ LASTNODE T)
then (INVERTW W)
else (FLIPNODE LASTNODE W]
[COND
(NODE (if (EQ NODE T)
then (INVERTW W)
else (FLIPNODE NODE W]
(SETQ LASTNODE NODE)) repeatwhile (MOUSESTATE (OR MIDDLE LEFT)))
[COND
(COPY (RETURN (COND
((EQ NODE T)
(INVERTW W)
(GRAPHERCOPYBUTTONEVENTFN W))
(T (FLIPNODE NODE W)
(COPYINSERT (fetch (SPYRECORD NAME) of (fetch
(GRAPHNODE NODEID)
of NODE]
(if NODE
then
(LET [(NAME (fetch (SPYRECORD NAME) of (fetch (GRAPHNODE NODEID)
of NODE]
(SELECTQ [SETQ ACTION (MENU (CONSTANT (create MENU
ITEMS _
'(NewSubTree SubTree Delete Merge
Edit InspectCode]
(NIL (FLIPNODE NODE W) (* ; "no tree action ")
)
(Edit (FLIPNODE NODE W)
(ED NAME '(FUNCTIONS FNS :DONTWAIT :DISPLAY)))
(InspectCode (FLIPNODE NODE W)
(INSPECTCODE NAME))
(Delete (* ;
 "remove this node. Leave still marked")
(push (fetch (SPYDATA DELETED) of SPYDATA)
NAME)
(SETQ PENDING "delete"))
(Merge [if (fetch (GRAPHNODE FROMNODES) of NODE)
then (push (fetch (SPYDATA MERGEINFO) of SPYDATA)
(LIST NAME (fetch (SPYRECORD NAME)
of (CAR (fetch (GRAPHNODE
FROMNODES)
of NODE]
(SETQ PENDING "merge"))
(NewSubTree (FLIPNODE NODE W)
(SPY.MAKE.TREE (SPY.MERGE
(SPY.ORIGINAL (LIST (fetch
(GRAPHNODE NODEID)
of NODE)))
SPYDATA)
(create SPYDATA
using SPYDATA PENDING _ NIL DELETED _ NIL)))
((SubTree)
(SETQ NEW-TREES (SPY.MERGE (SPY.ORIGINAL
(LIST (fetch (GRAPHNODE NODEID)
of NODE)))
SPYDATA)))
(printout PROMPTWINDOW T "SORRY, FEATURE NOT IMPLEMENTED YET")))
elseif (INSIDE? (WINDOWPROP W 'REGION)
LASTMOUSEX LASTMOUSEY)
then (SELECTQ [MENU (create
MENU
ITEMS _
`(Legend Inspect SetThreshold ,(COND
((fetch (SPYDATA
CUMULATIVE
)
of SPYDATA)
'Individual)
(T 'Cumulative))
,@(SELECTQ (fetch (SPYDATA MERGETYPE)
of SPYDATA)
(ALL '(MergeDefault MergeNone))
(T '(MergeNone MergeAll))
((NIL NONE)
'(MergeDefault MergeAll))
(SHOULDNT]
(NIL)
(Legend (SPY.LEGEND))
(Inspect (INSPECT/PLIST SPYDATA))
(SetThreshold (* ; "no need to remerge")
(replace (SPYDATA THRESHOLD) of SPYDATA
with (RNUMBER "Threshold (percent)" NIL DEFAULTFONT
DEFAULTFONT))
(SETQ PENDING "threshold"))
(MergeAll (replace (SPYDATA MERGETYPE) of SPYDATA
with 'ALL)
(SETQ PENDING "merge-type"))
(MergeNone (replace (SPYDATA MERGETYPE) of SPYDATA
with 'NONE)
(SETQ PENDING "merge-type"))
(MergeDefault (replace (SPYDATA MERGETYPE) of SPYDATA
with T)
(SETQ PENDING "merge-type"))
((Cumulative Individual)
[replace (SPYDATA MERGETYPE) of SPYDATA
with (COND
((change (fetch (SPYDATA CUMULATIVE)
of SPYDATA)
(NOT DATUM))
T)
(T 'ALL]
(SETQ PENDING "merge-type"))
(SHOULDNT)))
DOIT
(if (AND (NOT NEW-TREES)
MULTIPLE)
then (* ;
 "multiple action while shift down")
(if PENDING
then [if [NOT (STRPOS PENDING (WINDOWPROP W 'TITLE]
then (WINDOWPROP W 'TITLE (CONCAT PENDING "/"
(WINDOWPROP W 'TITLE]
(replace (SPYDATA PENDING) of SPYDATA with T))
elseif (OR NEW-TREES PENDING (fetch (SPYDATA PENDING) of SPYDATA))
then (SPY.MAKE.TREE (OR NEW-TREES (SPY.MERGE (SPY.ORIGINAL TREES)
SPYDATA))
(create SPYDATA using SPYDATA PENDING _ NIL DELETED _ NIL)
WINDOW])
(SPY.END
(LAMBDA NIL (* ; "Edited 9-Sep-87 17:51 by Masinter") (if (EQ \PERIODIC.INTERRUPT (QUOTE \SPY.INTERRUPT)) then (SETQ \PERIODIC.INTERRUPT) (SPY.DUMP.BUFFER) (if (OPENWP SPY.BUTTON) then (BITBLT SPY.CLOSED NIL NIL SPY.BUTTON))))
)
(SPY.MAKEGRAPHNODES
[LAMBDA (TREE THRESHOLD SPYDATA) (* ; "Edited 28-Apr-94 14:00 by sybalsky")
(* ;;; "RETURNS NODE ID FOR TREE")
(PROG ((LABEL (fetch (SPYRECORD NAME) of TREE))
[COUNT (COND
((fetch (SPYDATA CUMULATIVE)
SPYDATA)
(fetch (SPYRECORD SUM) of TREE))
(T (fetch (SPYRECORD COUNT) of TREE]
(STATUS (fetch (SPYRECORD STATUS) of TREE))
HEIGHT BORDER WIDTH NODEBITMAP TOOSMALL)
[SETQ BORDER (CDDR (OR (ASSOC STATUS SPY.BORDERS)
(SHOULDNT]
(push SPY.NODES (create
GRAPHNODE
NODEID _ TREE
NODELABEL _ (SPYOBJ LABEL (QUOTIENT (TIMES COUNT 100)
TOPCOUNT)
STATUS)
TONODES _ (for X in (fetch (SPYRECORD CALLEES)
of TREE)
when (OR (ZEROP THRESHOLD)
(IGEQ (SPY.MAX
(LIST X)
(NOT (fetch (SPYDATA CUMULATIVE)
SPYDATA)))
THRESHOLD)) bind VAL
do (push VAL (SPY.MAKEGRAPHNODES X THRESHOLD
SPYDATA))
finally (RETURN VAL))
NODEBORDER _ BORDER
NODEFONT _ SPY.FONT)))
TREE])
(SPY.MAX
[LAMBDA (TREES COUNTP MAX) (* ; "Edited 28-Apr-94 13:59 by sybalsky")
[for X in TREES do (SETQ MAX (SPY.MAX (fetch (SPYRECORD CALLEES) of
X)
COUNTP
(IMAX (OR MAX (IMAX))
(if COUNTP
then (fetch (SPYRECORD COUNT)
of X)
else (fetch (SPYRECORD SUM)
of X]
MAX])
(SPY.MERGE
[LAMBDA (TREES SPYDATA) (* ; "Edited 28-Apr-94 14:00 by sybalsky")
[COND
(SPY.HASH (CLRHASH SPY.HASH))
(T (SETQ SPY.HASH (HASHARRAY 100]
(if (fetch (SPYDATA DELETED) of SPYDATA)
then (SETQ TREES (SPY.DELETE (fetch (SPYDATA DELETED) of SPYDATA)
TREES)))
(for X in TREES do (SPY.SUM X))
(for NEWNODE in TREES bind VAL Z
do [for OLDNODE in VAL when (EQ (fetch (SPYRECORD NAME) of OLDNODE)
(fetch (SPYRECORD NAME) of NEWNODE))
do (RETURN (SPY.MERGETREE NEWNODE OLDNODE SPYDATA NIL (fetch
(SPYDATA DEPTH)
SPYDATA)))
finally (AND (SETQ Z (SPY.MERGE1 NEWNODE SPYDATA NIL NIL (fetch
(SPYDATA DEPTH)
SPYDATA)))
(SETQ VAL (NCONC1 VAL Z] finally (CLRHASH SPY.HASH)
(RETURN VAL])
(SPY.MERGE1
[LAMBDA (NEWORIGINAL SPYDATA PARENTS CALLER DEPTH) (* ; "Edited 28-Apr-94 14:00 by sybalsky")
(* ;
 "return the 'merged' tree for TREE, a copy of the original")
(PROG* ((NAME (fetch (SPYRECORD NAME) of NEWORIGINAL))
[PARENT-NAME (AND PARENTS (fetch (SPYRECORD NAME) of (CAR PARENTS]
(NEW-NAME NAME)
MERGE-LIST MERGEP OLDCOPY NEWCOPY)
[SELECTQ (fetch (SPYDATA MERGETYPE) of SPYDATA)
((NIL NONE))
(PROGN (if (AND PARENTS (CL:SYMBOLP NAME)
(CL:SYMBOLP PARENT-NAME)
(GENSYM? NAME)
(if (CL:KEYWORDP PARENT-NAME)
then (STRPOS (LET* [(ORIG (fetch (SPYRECORD TREEFROM)
of (CAR PARENTS]
(fetch (SPYRECORD NAME)
of (if (LISTP ORIG)
then (CAR ORIG)
else ORIG)))
NAME 1 NIL T)
elseif (EQ (CL:SYMBOL-PACKAGE NAME)
(CL:SYMBOL-PACKAGE PARENT-NAME))
then (STRPOS PARENT-NAME NAME 1 NIL T)))
then (SETQ NEW-NAME PARENT-NAME))
(SETQ MERGE-LIST (if (LITATOM NEW-NAME)
then (SPY.MERGEINFO NEW-NAME SPYDATA PARENT-NAME))
)
(if MERGE-LIST
then (if (EQ (CAR MERGE-LIST)
':ANY)
then (if PARENTS
then (SETQ NEW-NAME PARENT-NAME))
elseif (EQ (CAR MERGE-LIST)
':NONE)
then (SETQ MERGEP NIL)
(GO NO-MERGE)
elseif (OR (NULL PARENTS)
(NOT (FMEMB PARENT-NAME MERGE-LIST)))
then (SETQ NEW-NAME (CAR MERGE-LIST))
else (SETQ NEW-NAME PARENT-NAME)))
(SELECTQ (fetch (SPYDATA MERGETYPE) of SPYDATA)
((NIL NONE)
NIL)
((RECURSIVE-ONLY)
NIL)
(T [SETQ MERGEP (OR (NOT (CL:SYMBOLP NEW-NAME))
(AND (NOT MERGE-LIST)
(NOT (FMEMB NEW-NAME SPY.NOMERGEFNS))
(NOT (FMEMB NEW-NAME OPENFNS))
(NOT (STRPOS "\interpret" NEW-NAME])
(ALL (SETQ MERGEP T))
(SHOULDNT]
[COND
([OR (AND MERGEP (SETQ OLDCOPY (GETHASH NEW-NAME SPY.HASH)))
(SELECTQ (fetch (SPYDATA MERGETYPE) of SPYDATA)
((NIL NONE)
NIL)
(AND PARENTS (EQ NEW-NAME (fetch (SPYRECORD NAME) of (SETQ OLDCOPY
(CAR PARENTS]
(* ;
 "mergeable, and we found one to merge into")
(* ; "show this node only as a ghost")
(SPY.MERGETREE NEWORIGINAL OLDCOPY SPYDATA PARENTS DEPTH)
(COND
((OR (fetch (SPYDATA NOGHOSTS) of SPYDATA)
(EQ OLDCOPY (CAR PARENTS)))
(RETURN NIL))
([AND CALLER (SETQ NEWCOPY (find X in (fetch (SPYRECORD CALLEES)
of CALLER)
suchthat (EQ (fetch (SPYRECORD NAME)
of X)
NEW-NAME]
(SELECTQ (fetch (SPYRECORD STATUS) of NEWCOPY)
(GHOST (AND (FMEMB OLDCOPY PARENTS)
(replace (SPYRECORD STATUS) of NEWCOPY with
'RECURSIVEGHOST)))
((RECURSIVEGHOST ENDOFLINE))
(HELP "spy: never seen this case before"))
(RETURN NIL))
(T (SETQ NEWCOPY (create SPYRECORD using NEWORIGINAL CALLEES _ NIL STATUS _
'GHOST TREEFROM _ NEWORIGINAL))
(AND CALLER (push (fetch (SPYRECORD CALLEES) of CALLER)
NEWCOPY))
(RETURN NEWCOPY]
NO-MERGE
(SETQ NEWCOPY (create SPYRECORD
using NEWORIGINAL CALLEES _ NIL TREEFROM _ NEWORIGINAL NAME _
NEW-NAME)) (* ; "create the copy")
(AND MERGEP (PUTHASH NEW-NAME NEWCOPY SPY.HASH)) (* ; "remember it if it is mergable")
(AND CALLER (push (fetch (SPYRECORD CALLEES) of CALLER)
NEWCOPY))
(SPY.MERGE.CALLEES NEWORIGINAL NEWCOPY SPYDATA PARENTS DEPTH)
(* ; "")
(RETURN NEWCOPY])
(SPY.MERGETREE
[LAMBDA (NEWORIGINAL OLDCOPY SPYDATA PARENTS DEPTH) (* ; "Edited 28-Apr-94 13:59 by sybalsky")
(* ;
 "insert call tree from NEWORIGINAL into node starting with OLDCOPY")
(* ;
 "this function is only called once we've decided to merge something after all")
(PROG ((RECURSIVE (FMEMB OLDCOPY PARENTS)))
[COND
((NOT RECURSIVE)
(add (fetch (SPYRECORD SUM) of OLDCOPY)
(fetch (SPYRECORD SUM) of NEWORIGINAL]
(add (fetch (SPYRECORD COUNT) of OLDCOPY)
(fetch (SPYRECORD COUNT) of NEWORIGINAL))
[if RECURSIVE
then (SELECTQ (fetch (SPYRECORD STATUS) of OLDCOPY)
((NORMAL SELFRECURSIVE)
(replace (SPYRECORD TREEFROM) of OLDCOPY
with (LIST (fetch (SPYRECORD TREEFROM) of OLDCOPY)))
(* ; "must be a list")
(replace (SPYRECORD STATUS) of OLDCOPY with 'RECURSIVE))
((RECURSIVE GHOST))
(MERGED (replace (SPYRECORD STATUS) of OLDCOPY with
'RECURSIVE))
(SHOULDNT))
else (* ; "add to TREEFROM")
(replace (SPYRECORD TREEFROM) of OLDCOPY
with (CONS NEWORIGINAL (SELECTQ (fetch (SPYRECORD STATUS) of OLDCOPY
)
((NORMAL SELFRECURSIVE)
(replace (SPYRECORD STATUS) of
OLDCOPY
with 'MERGED)
(LIST (fetch (SPYRECORD TREEFROM)
of OLDCOPY)))
((MERGED RECURSIVE ENDOFLINE GHOST)
(fetch (SPYRECORD TREEFROM) of
OLDCOPY))
(SHOULDNT]
(SPY.MERGE.CALLEES NEWORIGINAL OLDCOPY SPYDATA PARENTS DEPTH)
(RETURN T])
(SPY.NEXT.TREE
[LAMBDA (TREE FN) (* ; "Edited 28-Apr-94 13:59 by sybalsky")
(for X in (fetch (SPYRECORD CALLEES) of TREE)
do (COND
((EQ (fetch (SPYRECORD NAME) of X)
FN)
(RETURN X))) finally (push (fetch (SPYRECORD CALLEES) of TREE)
(SETQ X (create SPYRECORD
NAME _ FN
COUNT _ 0)))
(RETURN X])
(SPY.SUM
[LAMBDA (TREE) (* ; "Edited 28-Apr-94 13:59 by sybalsky")
(replace (SPYRECORD SUM) of TREE
with (PLUS (fetch (SPYRECORD COUNT) of TREE)
(PROG1 (for X in (fetch (SPYRECORD CALLEES) of TREE)
sum (SPY.SUM X))
[SORT (fetch (SPYRECORD CALLEES) of TREE)
(FUNCTION (LAMBDA (X Y)
(IGREATERP (fetch (SPYRECORD SUM) of X)
(fetch (SPYRECORD SUM) of Y])])
(SPY.TITLE
[LAMBDA (X TOPCOUNT SPYDATA) (* ; "Edited 25-Sep-87 16:30 by jop")
(CONCAT "SPY " (fetch (SPYRECORD NAME) of X)
", " TOPCOUNT " samples"])
(SPY.MAKE.TREE
[LAMBDA (TREES SPYDATA WINDOW) (* ; "Edited 28-Apr-94 13:59 by sybalsky")
(PROG (GRAPH IDS W H THRSH TOPCOUNT (*PACKAGE* (fetch (SPYDATA PACKAGE) of SPYDATA))
(*READTABLE* (fetch (SPYDATA READTABLE) of SPYDATA))
(*PRINT-CASE* (fetch (SPYDATA PRINT-CASE) of SPYDATA)))
(OR (FONTP SPY.FONT)
(SETQ SPY.FONT (FONTCREATE SPY.FONT)))
(SETQ TOPCOUNT (for X in TREES sum (fetch (SPYRECORD SUM) of X)))
(SETQ THRSH (QUOTIENT (TIMES TOPCOUNT (fetch (SPYDATA THRESHOLD) of SPYDATA))
100))
(SETQ SPY.NODES)
(SETQ SPY.TOPNODES (for X in TREES collect (SPY.MAKEGRAPHNODES X THRSH
SPYDATA)))
(SETQ TITLE (SPY.TITLE (CAR SPY.TOPNODES)
TOPCOUNT SPYDATA))
(SETQ SPY.WINDOW (SHOWGRAPH (LAYOUTGRAPH (REVERSE SPY.NODES)
SPY.TOPNODES NIL SPY.FONT)
(COND
((WINDOWP WINDOW)
(WINDOWPROP WINDOW 'TITLE TITLE)
WINDOW)
(T TITLE))
NIL NIL NIL NIL (FUNCTION SPY.COPYBUTTON)))
(WINDOWPROP SPY.WINDOW 'ICON SPY.ICON)
(WINDOWPROP SPY.WINDOW 'BUTTONEVENTFN (FUNCTION SPY.GRAPH.EDITOR))
(WINDOWPROP SPY.WINDOW 'RIGHTBUTTONFN (FUNCTION SPY.UPDATE.TITLE))
(WINDOWPROP SPY.WINDOW 'SPYDATA SPYDATA)
(WINDOWPROP SPY.WINDOW 'TREES TREES)
(WINDOWPROP SPY.WINDOW 'SPYTITLE TITLE)
(WINDOWPROP SPY.WINDOW 'TOPCOUNT TOPCOUNT])
(SPY.UPDATE.TITLE
[LAMBDA (W) (* ; "Edited 29-Apr-94 14:03 by sybalsky")
(LET [(NODE (NODELST/AS/MENU (fetch (GRAPH GRAPHNODES) of (WINDOWPROP W 'GRAPH))
(CONS (LASTMOUSEX W)
(LASTMOUSEY W]
(TOTOPW W)
(COND
((NOT (INSIDE? (DSPCLIPPINGREGION NIL W)
(LASTMOUSEX W)
(LASTMOUSEY W)))
(* ;; " display the default window menu")
(DOWINDOWCOM W))
(T [if NODE
then
(* ;;
" change the window title to show the function name, and the individual and cumulative percentages ")
(WINDOWPROP W 'TITLE (CONCAT (fetch (SPYRECORD NAME)
of (fetch (GRAPHNODE NODEID)
of NODE))
" "
(QUOTIENT (TIMES (fetch (SPYRECORD COUNT)
of (fetch
(GRAPHNODE NODEID)
of NODE))
100)
(WINDOWPROP W 'TOPCOUNT))
"%% "
(QUOTIENT (TIMES (fetch (SPYRECORD SUM)
of (fetch
(GRAPHNODE NODEID)
of NODE))
100)
(WINDOWPROP W 'TOPCOUNT))
"%%"))
else
(* ;;
 "change the window title to show the top function name and total number of samples")
(WINDOWPROP W 'TITLE (WINDOWPROP W 'SPYTITLE]
(UNTILMOUSESTATE UP])
(SPY.DELETE
[LAMBDA (NAMES TREES) (* ; "Edited 28-Apr-94 13:59 by sybalsky")
(for X in TREES when (NOT (EQMEMB (fetch (SPYRECORD NAME) of X)
NAMES))
collect (create SPYRECORD using X CALLEES _ (SPY.DELETE NAMES
(fetch (SPYRECORD CALLEES)
of X])
(SPY.DRAWBOX
(LAMBDA (WIDTH HEIGHT BORDERWIDTH BITMAP TEXTURE) (* ; "Edited 9-Sep-87 17:54 by Masinter") (BITBLT NIL NIL NIL BITMAP 0 0 BORDERWIDTH HEIGHT (QUOTE TEXTURE) (QUOTE PAINT) TEXTURE) (BITBLT NIL NIL NIL BITMAP 0 0 WIDTH BORDERWIDTH (QUOTE TEXTURE) (QUOTE PAINT) TEXTURE) (BITBLT NIL NIL NIL BITMAP 0 (DIFFERENCE HEIGHT BORDERWIDTH) WIDTH BORDERWIDTH (QUOTE TEXTURE) (QUOTE PAINT) TEXTURE) (BITBLT NIL NIL NIL BITMAP (DIFFERENCE WIDTH BORDERWIDTH) 0 BORDERWIDTH HEIGHT (QUOTE TEXTURE) (QUOTE PAINT) TEXTURE))
)
(SPY.BUFFER.ENTRY
(LAMBDA (N) (* ; "Edited 9-Sep-87 18:27 by Masinter") (COND (SPY.POINTERS (AND (ILEQ (SETQ N (LLSH N 1)) SPY.BUFFER.SIZE) (\GETBASEPTR SPY.BUFFER N))) ((ILEQ N SPY.BUFFER.SIZE) (\VAG2 0 (\GETBASE SPY.BUFFER N)))))
)
(SPY.BUTTON
(LAMBDA (POS) (* gbn " 2-Jun-85 13:12") (PROG ((REG (if POS then (CREATEREGION (fetch XCOORD of POS) (fetch YCOORD of POS) (WIDTHIFWINDOW (BITMAPWIDTH SPY.CLOSED)) (HEIGHTIFWINDOW (BITMAPHEIGHT SPY.CLOSED))) else (GETBOXREGION (WIDTHIFWINDOW (BITMAPWIDTH SPY.CLOSED)) (HEIGHTIFWINDOW (BITMAPHEIGHT SPY.CLOSED)) NIL NIL NIL "Specify region for window %"Spy Control%"")))) (BITBLT SPY.CLOSED NIL NIL (SETQ SPY.BUTTON (CREATEW REG NIL NIL T))) (WINDOWPROP SPY.BUTTON (QUOTE BUTTONEVENTFN) (FUNCTION (LAMBDA (W) (AND (LASTMOUSESTATE UP) (SPY.TOGGLE)))))))
)
(SPY.END.ENTRY
(LAMBDA NIL (* ejs%: "27-APR-84 11:37") (SPY.ADD.ENTRY NIL)))
(SPY.START
(LAMBDA (FILE) (* lmm "24-Oct-84 22:49") (if (OPENWP SPY.BUTTON) then (BITBLT SPY.OPEN NIL NIL SPY.BUTTON)) (* ejs%: "27-APR-84 11:37") (SPY.INIT FILE) (SETQ \PERIODIC.INTERRUPT.FREQUENCY (QUOTIENT 60 SPY.FREQUENCY)) (SETQ \PERIODIC.INTERRUPT (QUOTE \SPY.INTERRUPT)))
)
(SPY.INIT
(LAMBDA NIL (* ; "Edited 9-Sep-87 23:47 by Masinter") (OR SPY.BUFFER (SETQ SPY.BUFFER (\ALLOCBLOCK (CL:* SPY.BUFFER.SIZE 2)))) (SETQ SPY.BUFFER.THRESHOLD (QUOTIENT SPY.BUFFER.SIZE 2)) (SETQ SPY.NEXT 0) (SETQ SPY.TREE))
)
(\SPY.INTERRUPT
(LAMBDA NIL (* ; "Edited 9-Sep-87 18:32 by Masinter") (SETQ \PERIODIC.INTERRUPT) (* ; "turn off sampling while gathering sample") (PROG ((FRAME (fetch (FX CLINK) (\MYALINK)))) (COND ((IGEQ (if SPY.POINTERS then (LLSH SPY.NEXT 1) else SPY.NEXT) SPY.BUFFER.THRESHOLD) (COND (\INTERRUPTABLE (SPY.DUMP.BUFFER)) (T (* ; "this sample might overflow; just don't do it") (RETURN))))) (SPY.START.ENTRY) SAMPLELOOP (SPY.ADD.ENTRY (fetch (FX FRAMENAME) FRAME)) (COND ((NOT (fetch (FX INVALIDP) (SETQ FRAME (fetch (FX CLINK) FRAME)))) (GO SAMPLELOOP)) (T (SPY.END.ENTRY)))) (SETQ \PERIODIC.INTERRUPT (QUOTE \SPY.INTERRUPT)))
)
(SPY.DUMP.BUFFER
[LAMBDA NIL (* ; "Edited 28-Apr-94 14:00 by sybalsky")
(bind (I _ 0)
NEXTI while (ILESSP I SPY.NEXT)
do (bind [J _ (SETQ NEXTI (for K from I by 1 while (SPY.BUFFER.ENTRY
K)
finally (RETURN K]
TREE
(NAME _ "NO SUCH NAME") first [SETQ TREE (SPY.FIND.TREE
(SPY.BUFFER.ENTRY (add
J -1]
while (IGREATERP J I) do [COND
([NEQ NAME (SETQ NAME (SPY.BUFFER.ENTRY
(add J -1]
(SETQ TREE (SPY.NEXT.TREE TREE NAME)))
(T (replace (SPYRECORD STATUS) of TREE
with 'SELFRECURSIVE]
finally (add (fetch (SPYRECORD COUNT) of TREE)
1))
(SETQ I (ADD1 NEXTI)))
(SETQ SPY.NEXT 0])
(SPY.START.ENTRY
(LAMBDA NIL (* ejs%: "27-APR-84 11:37") (* do nothing at the start of the entry, do this at the end) NIL)
)
(SPY.ADD.ENTRY
(LAMBDA (NAME) (* ; "Edited 9-Sep-87 18:29 by Masinter") (COND (SPY.POINTERS (\PUTBASEPTR SPY.BUFFER (LLSH SPY.NEXT 1) NAME) (COND ((IGEQ (LLSH (add SPY.NEXT 1) 1) SPY.BUFFER.SIZE) (SPY.OVERFLOW)))) (T (OR (LITATOM NAME) (SETQ NAME (QUOTE *FORM*))) (\PUTBASE SPY.BUFFER SPY.NEXT (\LOLOC NAME)) (COND ((IGEQ (add SPY.NEXT 1) SPY.BUFFER.SIZE) (SPY.OVERFLOW))))))
)
(SPY.ORIGINAL
[LAMBDA (TREES) (* ; "Edited 28-Apr-94 14:00 by sybalsky")
(for X in TREES join (SELECTQ (fetch (SPYRECORD STATUS) of X)
((RECURSIVE MERGED ENDOFLINE)
(APPEND (OR (LISTP (fetch (SPYRECORD TREEFROM)
of X))
(SHOULDNT))))
((NORMAL GHOST RECURSIVEGHOST SELFRECURSIVE)
(LIST (OR (fetch (SPYRECORD TREEFROM) of X)
X)))
(SHOULDNT])
(SPY.OVERFLOW
(LAMBDA NIL (* ejs%: "27-APR-84 11:37") (add SPY.NEXT -1) (SETQ SPY.OVERFLOWED T)))
(SPY.MERGE.CALLEES
[LAMBDA (NEWORIGINAL OLDCOPY SPYDATA PARENTS DEPTH) (* ; "Edited 28-Apr-94 14:00 by sybalsky")
(* ;
 "insert copies of the CALLEEs of NEWORIGINAL into OLDTREE's CALLEEs")
(for ORIGCALLEE in (fetch (SPYRECORD CALLEES) of NEWORIGINAL)
do (for COPYCALLEE in (fetch (SPYRECORD CALLEES) of OLDCOPY)
when (EQ (fetch (SPYRECORD NAME) of COPYCALLEE)
(fetch (SPYRECORD NAME) of ORIGCALLEE))
do (* ;
 "found a 'callee' that can merge this one with")
[RETURN (if (EQ (fetch (SPYRECORD STATUS) of COPYCALLEE)
'ENDOFLINE)
then (push (fetch (SPYRECORD TREEFROM) of
COPYCALLEE
)
ORIGCALLEE)
else (SPY.MERGETREE
ORIGCALLEE
(SELECTQ (fetch (SPYRECORD STATUS) of COPYCALLEE)
((NORMAL RECURSIVE SELFRECURSIVE MERGED)
COPYCALLEE)
((GHOST RECURSIVEGHOST)
(OR (GETHASH (fetch (SPYRECORD NAME)
of ORIGCALLEE)
SPY.HASH)
COPYCALLEE))
(SHOULDNT))
SPYDATA
(CONS OLDCOPY PARENTS)
(AND DEPTH (SUB1 DEPTH]
finally (* ; "no old node of same name found")
(if (AND DEPTH (ILEQ DEPTH 0))
then (push (fetch (SPYRECORD CALLEES) of OLDCOPY)
(create SPYRECORD using ORIGCALLEE CALLEES _ NIL
STATUS _ 'ENDOFLINE TREEFROM _
(LIST NEWORIGINAL)))
else (SPY.MERGE1 ORIGCALLEE SPYDATA (CONS OLDCOPY PARENTS)
OLDCOPY
(AND DEPTH (SUB1 DEPTH])

1
library/SYSEDIT Normal file
View File

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

1
library/TABLEBROWSER Normal file
View File

File diff suppressed because one or more lines are too long

1
library/TABLEBROWSERDECLS Normal file
View File

File diff suppressed because one or more lines are too long

150
library/TBDECLS Normal file
View File

@@ -0,0 +1,150 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "27-Sep-94 15:03:22" {DSK}<lispcore>library>TBDECLS.;3 7831
changes to%: (RECORDS TABLEBROWSER TABLEITEM)
previous date%: "20-Jan-93 14:52:38" {DSK}<lispcore>library>TBDECLS.;2)
(* ; "
Copyright (c) 1985, 1988, 1990, 1993, 1994 by Venue. All rights reserved.
")
(PRETTYCOMPRINT TBDECLSCOMS)
(RPAQQ TBDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM)
(CONSTANTS TB.LEFT.MARGIN)))
(DECLARE%: EVAL@COMPILE
(DATATYPE TABLEBROWSER ((TBREADY FLAG)
(TBHEIGHTEXPLICIT FLAG) (* ;
 "True if creator set explicit item height or baseline")
(NIL 6 FLAG)
(TBITEMS POINTER) (* ; "List of items in this browser")
(TB#ITEMS WORD) (* ; "Number of items")
(TB#DELETED WORD) (* ; "Number of items marked deleted")
(TB#LINESPERITEM WORD) (* ;
 "Number of lines occupied by each item, normally 1 (dunno if any other values work)")
(TBFIRSTSELECTEDITEM WORD) (* ;
 "Number of first selected item. If none selected, is > TB#ITEMS")
(TBLASTSELECTEDITEM WORD) (* ;
 "Number of last selected item. If none selected, is 0")
(TBITEMHEIGHT WORD) (* ;
 "Height of an item, i.e., fontheight*linesperitem")
(TBMAXXPOS WORD) (* ;
 "The largest x-position a user printfn has printed to")
(TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font")
(TBFONTASCENT WORD)
(TBBASELINE WORD)
(TBWINDOW POINTER) (* ;
 "Pointer to the display window. Need to snap this link when browser is closed")
(TBLOCK POINTER) (* ;
 "Monitor lock guarding some browser operations")
(TBUSERDATA POINTER) (* ; "Arbitrary user storage")
(TBFONT POINTER) (* ; "Pointer to font used by display")
(TBEXTENT POINTER) (* ;
 "Window's extent, updated as items are added, deleted, or printfn prints farther to right")
(TBUPDATEFROMHERE POINTER) (* ;
 "If changes have occurred while shrunk, this gives the # of first item that needs redisplay")
(TBCOLUMNS POINTER) (* ;
 "Number of columns--not yet implemented")
(TBPRINTFN POINTER) (* ;
 "(Browser Item Window) -- displays Item at current line position in window")
(TBCOPYFN POINTER) (* ;
 "(Browser Item) -- copy selects Item")
(TBFONTCHANGEFN POINTER) (* ;
 "(Browser Window) -- called when tb.set.font changes the font")
(TBCLOSEFN POINTER) (* ;
 "(Browser Window Close/Shrink) -- called when you try to close or shrink window")
(TBAFTERCLOSEFN POINTER) (* ;
 "(Browser Window) -- called to cleanup AFTER a closew")
(TBTITLEEVENTFN POINTER) (* ;
 "(Window Browser) -- handles button event in browser's title")
(TBLINETHICKNESS POINTER) (* ;
 "Thickness of line for deletions (normally 1)")
(TBORIGIN POINTER) (* ;
 "Y position of the top of the first item")
(TBTAILHINT POINTER) (* ;
 "A tail of TBITEMS, used to speed up TB.NTH.ITEM")
(TBHEADINGWINDOW POINTER) (* ;
 "An optional %"header window%" that should be horizontally scrolled in synchrony with this one")
(NIL POINTER)))
(DATATYPE TABLEITEM ((TISELECTED FLAG)
(TIDELETED FLAG)
(TIUNDELETABLE FLAG)
(TIUNSELECTABLE FLAG)
(TIUNCOPYSELECTABLE FLAG)
(NIL 3 FLAG)
(TIDATA POINTER)
(TI# WORD)
(NIL WORD)))
)
(/DECLAREDATATYPE 'TABLEBROWSER
'(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD
WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)
'((TABLEBROWSER 0 (FLAGBITS . 0))
(TABLEBROWSER 0 (FLAGBITS . 16))
(TABLEBROWSER 0 (FLAGBITS . 32))
(TABLEBROWSER 0 (FLAGBITS . 48))
(TABLEBROWSER 0 (FLAGBITS . 64))
(TABLEBROWSER 0 (FLAGBITS . 80))
(TABLEBROWSER 0 (FLAGBITS . 96))
(TABLEBROWSER 0 (FLAGBITS . 112))
(TABLEBROWSER 0 POINTER)
(TABLEBROWSER 2 (BITS . 15))
(TABLEBROWSER 3 (BITS . 15))
(TABLEBROWSER 4 (BITS . 15))
(TABLEBROWSER 5 (BITS . 15))
(TABLEBROWSER 6 (BITS . 15))
(TABLEBROWSER 7 (BITS . 15))
(TABLEBROWSER 8 (BITS . 15))
(TABLEBROWSER 9 (BITS . 15))
(TABLEBROWSER 10 (BITS . 15))
(TABLEBROWSER 11 (BITS . 15))
(TABLEBROWSER 12 POINTER)
(TABLEBROWSER 14 POINTER)
(TABLEBROWSER 16 POINTER)
(TABLEBROWSER 18 POINTER)
(TABLEBROWSER 20 POINTER)
(TABLEBROWSER 22 POINTER)
(TABLEBROWSER 24 POINTER)
(TABLEBROWSER 26 POINTER)
(TABLEBROWSER 28 POINTER)
(TABLEBROWSER 30 POINTER)
(TABLEBROWSER 32 POINTER)
(TABLEBROWSER 34 POINTER)
(TABLEBROWSER 36 POINTER)
(TABLEBROWSER 38 POINTER)
(TABLEBROWSER 40 POINTER)
(TABLEBROWSER 42 POINTER)
(TABLEBROWSER 44 POINTER)
(TABLEBROWSER 46 POINTER))
'48)
(/DECLAREDATATYPE 'TABLEITEM '(FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD)
'((TABLEITEM 0 (FLAGBITS . 0))
(TABLEITEM 0 (FLAGBITS . 16))
(TABLEITEM 0 (FLAGBITS . 32))
(TABLEITEM 0 (FLAGBITS . 48))
(TABLEITEM 0 (FLAGBITS . 64))
(TABLEITEM 0 (FLAGBITS . 80))
(TABLEITEM 0 (FLAGBITS . 96))
(TABLEITEM 0 (FLAGBITS . 112))
(TABLEITEM 0 POINTER)
(TABLEITEM 2 (BITS . 15))
(TABLEITEM 3 (BITS . 15)))
'4)
(DECLARE%: EVAL@COMPILE
(RPAQQ TB.LEFT.MARGIN 8)
(CONSTANTS TB.LEFT.MARGIN)
)
(PUTPROPS TBDECLS COPYRIGHT ("Venue" 1985 1988 1990 1993 1994))
(DECLARE%: DONTCOPY
(FILEMAP (NIL)))
STOP

1655
library/TEDIT Normal file
View File

File diff suppressed because one or more lines are too long

12
library/TEDIT.DATABASE Normal file
View File

@@ -0,0 +1,12 @@
(PROGN (PRIN1 "Use LOADDB to load database files!
" T) (ERROR!))
("21-Feb-99 12:57:02" . {DSK}<users>sybalsky>TEDIT.;1)
FNS (\TEDIT2 COERCETEXTOBJ TEDIT TEDIT.CHARWIDTH TEDIT.COPY TEDIT.DELETE TEDIT.DO.BLUEPENDINGDELETE
TEDIT.INSERT TEDIT.KILL TEDIT.MAPLINES TEDIT.MAPPIECES TEDIT.MOVE TEDIT.QUIT TEDIT.STRINGWIDTH
TEDIT.\INSERT TEXTOBJ TEXTSTREAM \TEDIT.INCLUDE \TEDIT.INSERT.PIECES \TEDIT.MOVE.PIECEMAPFN
\TEDIT.OBJECT.SHOWSEL \TEDIT.RESTARTFN \TEDIT.CHARDELETE \TEDIT.COPY.PIECEMAPFN \TEDIT.DELETE
\TEDIT.DIFFUSE.PARALOOKS \TEDIT.FOREIGN.COPY? \TEDIT.QUIT \TEDIT.WORDDELETE \TEDIT1
\CREATE.TEDIT.RESTART.MENU PLCHAIN PRINTLINE SEEFILE TEDIT.INSERT.OBJECT TEDIT.EDIT.OBJECT
TEDIT.FIND.OBJECT TEDIT.FIND.OBJECT.SUBTREE TEDIT.PUT.OBJECT TEDIT.GET.OBJECT TEDIT.OBJECT.CHANGED
MAKETEDITFORM)

46
library/TEDITABBREV Normal file
View File

@@ -0,0 +1,46 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 6-Aug-2020 14:52:14" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITABBREV.;4 10066
changes to%: (VARS TEDITABBREVCOMS)
(FNS \TEDIT.TRY.ABBREV)
previous date%: "25-Aug-94 10:52:43"
{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITABBREV.;1)
(* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993, 1994, 2020 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT TEDITABBREVCOMS)
(RPAQQ TEDITABBREVCOMS
[(FILES TEDITDCL)
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
(FILES (LOADCOMP)
TEDITDCL))
(FNS \TEDIT.ABBREV.EXPAND \TEDIT.EXPAND.DATE \TEDIT.TRY.ABBREV)
(GLOBALVARS TEDIT.ABBREVS)
(INITVARS (TEDIT.ABBREVS '(("b" . "357,146")
("n" . "357,44")
("m" . "357,45")
("T" . "357,57")
("d" . "357,60")
("D" . "357,61")
("s" . "0,247")
("'" . "0,271")
("`" . "0,251")
("%"" . "0,252")
("~" . "0,272")
("1/4" . "0,274")
("1/2" . "0,275")
("3/4" . "0,276")
("1/3" . "357,375")
("2/3" . "357,376")
("c" . "0,323")
("c/o" . "357,100")
("%%" . "357,100")
("->" . "0,256")
("ra" . "0,256")
("|" . "0,257")

439
library/TEDITCHAT Normal file
View File

@@ -0,0 +1,439 @@
(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10)
(IL:FILECREATED "28-Mar-94 16:05:24" IL:|{PELE:MV:ENVOS}<LISPCORE>LIBRARY>TEDITCHAT.;3| 31193
IL:|changes| IL:|to:| (IL:FNS IL:\\TEXTSTREAMBOUT)
IL:|previous| IL:|date:| "12-Jun-90 18:01:39" IL:|{PELE:MV:ENVOS}<LISPCORE>LIBRARY>TEDITCHAT.;2|
)
; Copyright (c) 1985, 1986, 1990, 1994 by Venue & Xerox Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:TEDITCHATCOMS)
(IL:RPAQQ IL:TEDITCHATCOMS
((IL:COMS (IL:* IL:\; "character routines")
(IL:FNS IL:TEDITCHAT.CHARFN IL:\\TEXTSTREAMBOUT))
(IL:COMS (IL:FNS IL:TEDITSTREAM.INIT IL:TEDITCHAT.MENUFN))
(IL:COMS (IL:* IL:\; "TEDIT update routines")
(IL:FNS IL:TEDIT.DISPLAYTEXT))
(IL:GLOBALVARS IL:TEDITCHAT.MENU IL:CHAT.DRIVERTYPES IL:CHAT.DISPLAYTYPES)
(IL:VARS IL:TEDITCHAT.MENUITEMS (IL:TEDITCHAT.MENU))
(IL:ADDVARS (IL:CHAT.DRIVERTYPES (IL:TEDIT IL:TEDITCHAT.CHARFN IL:NILL)))
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY (IL:FILES (IL:SOURCE)
IL:CHATDECLS))))
(IL:* IL:\; "character routines")
(IL:DEFINEQ
(IL:TEDITCHAT.CHARFN
(IL:LAMBDA (IL:CH IL:CHAT.STATE) (IL:* IL:\; "Edited 12-Jun-90 18:00 by mitani")
(LET* ((IL:TEXTSTREAM (IL:|fetch| (IL:CHAT.STATE IL:TEXTSTREAM) IL:|of| IL:CHAT.STATE))
(IL:SEL (IL:|fetch| (IL:TEXTOBJ IL:SEL) IL:|of| (IL:TEXTOBJ IL:TEXTSTREAM))))
(IL:\\CARET.DOWN (IL:|fetch| (IL:TEXTOBJ IL:DS) IL:|of| (IL:TEXTOBJ IL:TEXTSTREAM))
)
(IL:SELCHARQ IL:CH
(IL:BS (IL:\\TEDIT.CHARDELETE IL:TEXTSTREAM "" IL:SEL)
(IL:MOVETO (IL:|fetch| IL:X0 IL:|of| IL:SEL)
(IL:|fetch| IL:Y0 IL:|of| IL:SEL)
(CAR (IL:|fetch| (IL:TEXTOBJ IL:\\WINDOW) IL:|of| (IL:TEXTOBJ
IL:TEXTSTREAM
)))))
(IL:LF NIL)
(IL:BOUT IL:TEXTSTREAM IL:CH)))))
(IL:\\TEXTSTREAMBOUT
(IL:LAMBDA (STREAM BYTE) (IL:* IL:\; "Edited 28-Mar-94 15:29 by jds")
(IL:* IL:|;;| "Do BOUT to a text stream, which is an insertion at the caret.")
(PROG ((IL:TEXTOBJ (IL:|fetch| (IL:TEXTSTREAM IL:TEXTOBJ) IL:|of| STREAM))
IL:CH# IL:WINDOW IL:TEXTLEN IL:PS IL:PC IL:PSTR IL:OFFST IL:SEL)
(IL:SETQ IL:TEXTLEN (IL:|fetch| (IL:TEXTOBJ IL:TEXTLEN) IL:|of| IL:TEXTOBJ))
(IL:SETQ IL:WINDOW (IL:|fetch| (IL:TEXTOBJ IL:\\WINDOW) IL:|of| IL:TEXTOBJ))
(IL:SETQ IL:SEL (IL:|fetch| (IL:TEXTOBJ IL:SEL) IL:|of| IL:TEXTOBJ))
(COND
((NOT (CAR (IL:|fetch| IL:L1 IL:|of| IL:SEL)))
(RETURN))) (IL:* IL:\;
 "Return if caret out of bounds, ie, user scrolls past end of text")
(IL:SETQ IL:CH# (IL:|fetch| IL:CH# IL:|of| IL:SEL))
(AND IL:WINDOW (IL:\\TEDIT.MARK.LINES.DIRTY IL:TEXTOBJ IL:CH# IL:CH#))
(COND
((IL:IEQP BYTE 13)
(IL:\\INSERTCR BYTE IL:CH# IL:TEXTOBJ))
(T (IL:\\INSERTCH BYTE IL:CH# IL:TEXTOBJ)))
(AND IL:WINDOW
(PROG ((IL:THISLINE (IL:|fetch| (IL:TEXTOBJ IL:THISLINE) IL:|of| IL:TEXTOBJ))
IL:EOLFLAG IL:CHORIG IL:CHWIDTH IL:OXLIM IL:OCHLIM IL:OCR\\END IL:PREVSPACE
IL:FIXEDLINE IL:NEXTLINE IL:LINES IL:NEWLINEFLG IL:DX IL:PREVLINE IL:SAVEWIDTH
IL:OFLOWFN IL:OLHEIGHT IL:DY IL:TABSEEN IL:IMAGECACHE IL:CURLINE IL:FONT
(IL:L1 (CAR (IL:|fetch| IL:L1 IL:|of| IL:SEL)))
(IL:LN (CAR (IL:|fetch| IL:LN IL:|of| IL:SEL)))
(IL:LOOKS (IL:\\TEDIT.APPLY.STYLES (IL:|fetch| (IL:TEXTOBJ IL:CARETLOOKS)
IL:|of| IL:TEXTOBJ)
(IL:|fetch| (IL:TEXTOBJ IL:\\INSERTPC) IL:|of|
IL:TEXTOBJ)
IL:TEXTOBJ)))
(IL:|add| (IL:|fetch| IL:CH# IL:|of| IL:SEL)
1) (IL:* IL:\;
 "These must be here, since SELs are valid even without a window.")
(IL:|replace| IL:CHLIM IL:|of| IL:SEL IL:|with| (IL:|fetch|
IL:CH# IL:|of|
IL:SEL))
(IL:|replace| IL:POINT IL:|of| IL:SEL IL:|with| 'IL:LEFT)
(IL:|replace| IL:DCH IL:|of| IL:SEL IL:|with| 0)
(IL:|replace| IL:SELKIND IL:|of| IL:SEL IL:|with| 'IL:CHAR)
(IL:SETQ IL:CURLINE IL:L1)
(IL:|add| (IL:|fetch| IL:CHARLIM IL:|of| IL:CURLINE)
1)
(IL:|add| (IL:|fetch| IL:CHARTOP IL:|of| IL:CURLINE)
1)
(IL:SETQ IL:FONT (IL:|fetch| IL:CLFONT IL:|of| IL:LOOKS))
(IL:DSPFONT IL:FONT (CAR IL:WINDOW))
(COND
((OR (IL:IGREATERP (IL:PLUS (IL:|fetch| IL:X0 IL:|of| IL:SEL)
(IL:CHARWIDTH BYTE IL:FONT))
(IL:IDIFFERENCE (IL:|fetch| (IL:TEXTOBJ IL:WRIGHT)
IL:|of| IL:TEXTOBJ)
8))
(IL:IEQP BYTE (IL:CHARCODE IL:CR)))
(IL:* IL:\;
 "gone off the edge of the line reformat and add new line")
(IL:TEDIT.UPDATE.SCREEN IL:TEXTOBJ)
(IL:\\FIXSEL IL:SEL IL:TEXTOBJ (CAR IL:WINDOW))
(IL:SETQ IL:L1 (CAR (IL:|fetch| IL:L1 IL:|of| IL:SEL)))
(IL:SETQ IL:LN (CAR (IL:|fetch| IL:LN IL:|of| IL:SEL)))
(COND
((OR (NULL (IL:SELECTQ (IL:|fetch| IL:POINT IL:|of| IL:SEL)
(IL:LEFT IL:L1)
(IL:RIGHT IL:LN)
NIL))
(IL:ILEQ (IL:SELECTQ (IL:|fetch| IL:POINT IL:|of| IL:SEL)
(IL:LEFT (IL:|fetch| IL:YBOT IL:|of| IL:L1))
(IL:RIGHT (IL:|fetch| IL:YBOT IL:|of| IL:LN))
0)
(IL:|fetch| (IL:REGION IL:BOTTOM)
IL:|of| (IL:DSPCLIPPINGREGION NIL (CAR IL:WINDOW)))))
(IL:* IL:\;
 "The caret is off-window in the selection window. Need to scroll it up so the caret is visible.")
(IL:|while| (IL:ILESSP (IL:|fetch| IL:Y0 IL:|of| IL:SEL)
(IL:|fetch| (IL:TEXTOBJ IL:WBOTTOM)
IL:|of| IL:TEXTOBJ))
IL:|do| (IL:* IL:\;
 "The caret just went off-screen. Move it up some.")
(IL:|replace| (IL:TEXTOBJ IL:EDITOPACTIVE) IL:|of|
IL:TEXTOBJ
IL:|with| NIL)
(IL:SCROLLW (CAR IL:WINDOW)
0
(IL:LLSH (COND
((IL:SELECTQ (IL:|fetch| IL:POINT
IL:|of| IL:SEL)
(IL:LEFT IL:L1)
(IL:RIGHT IL:LN)
NIL)
(IL:|fetch| IL:LHEIGHT
IL:|of| (IL:SELECTQ (IL:|fetch|
IL:POINT
IL:|of|
IL:SEL)
(IL:LEFT IL:L1)
(IL:RIGHT IL:LN)
(IL:SHOULDNT))))
(T 12))
1))))))
(T (IL:TEDIT.DISPLAYTEXT IL:TEXTOBJ BYTE (IL:CHARWIDTH BYTE IL:FONT)
IL:CURLINE
(IL:|fetch| IL:X0 IL:|of| IL:SEL)
(CAR IL:WINDOW)
IL:SEL) (IL:* IL:\;
 "Print out the character on the screen")
(IL:|add| (IL:|fetch| IL:X0 IL:|of| IL:SEL)
(IL:CHARWIDTH BYTE IL:FONT))
(IL:* IL:|;;| "And move the selection's notion of our X position to the right to account for that character's width.")
(IL:|replace| IL:XLIM IL:|of| IL:SEL IL:|with| (IL:|fetch|
IL:X0
IL:|of|
IL:SEL))))
(IL:* IL:|;;;| "Fix up the TEXTSTREAM so that the FILEPTR looks like it ought to after the BOUT, even though we've been updating the screen (which usually moves the fileptr....)")
(IL:SETQ IL:PS (IL:|ffetch| (IL:PIECE IL:PSTR) IL:|of|
(IL:SETQ IL:PC
(IL:|fetch| (IL:TEXTOBJ
IL:\\INSERTPC
)
IL:|of| IL:TEXTOBJ)))
) (IL:* IL:\;
 "This piece resides in a STRING. Because it's newly 'typed' material.")
(IL:|replace| (IL:TEXTSTREAM IL:PIECE) IL:|of| STREAM IL:|with|
IL:PC)
(IL:* IL:\;
 "Remember the current piece for others.")
(IL:* IL:\;
 "And which number piece this is.")
(IL:|freplace| (STREAM IL:CPPTR) IL:|of| STREAM
IL:|with| (IL:ADDBASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of|
IL:PS)
(IL:LRSH (IL:SETQ IL:OFFST (IL:|ffetch| (IL:STRINGP
IL:OFFST)
IL:|of| IL:PS))
1))) (IL:* IL:\;
 "Pointer to the actual characters in the string (allowing for substrings.)")
(IL:|freplace| (STREAM IL:CPAGE) IL:|of| STREAM IL:|with| 0)
(IL:|freplace| (STREAM IL:COFFSET) IL:|of| STREAM
IL:|with| (IL:IPLUS (IL:|freplace| (IL:TEXTSTREAM IL:PCSTARTCH)
IL:|of| STREAM IL:|with| (LOGAND 1
IL:OFFST))
(IL:|fetch| (IL:TEXTOBJ IL:\\INSERTLEN) IL:|of|
IL:TEXTOBJ))
)
(IL:|freplace| (IL:TEXTSTREAM IL:PCSTARTPG) IL:|of| STREAM IL:|with|
0)
(IL:* IL:\;
 "Page # within the 'file' where this piece starts")
(IL:|freplace| (STREAM IL:CBUFSIZE) IL:|of| STREAM
IL:|with| (IL:|fetch| (STREAM IL:COFFSET) IL:|of| STREAM))
(IL:|freplace| (STREAM IL:EPAGE) IL:|of| STREAM IL:|with| 1)
(IL:|freplace| (IL:TEXTSTREAM IL:CHARSLEFT) IL:|of| STREAM IL:|with|
0)
(IL:* IL:\;
 "We're, perforce, at the end of the piece.")
(IL:|freplace| (IL:TEXTSTREAM IL:REALFILE) IL:|of| STREAM IL:|with|
NIL)
(IL:* IL:\; "We're not on a file....")
)))))
)
(IL:DEFINEQ
(IL:TEDITSTREAM.INIT
(IL:LAMBDA (IL:WINDOW IL:MENUFN) (IL:* IL:\; "Edited 12-Jun-90 18:01 by mitani")
(IL:* IL:|;;| "Initialize and return TEDIT TEXTSTREAM")
(PROG* ((IL:TEXTSTREAM (IL:OPENTEXTSTREAM NIL IL:WINDOW NIL NIL))
(IL:TEXTOBJ (IL:TEXTOBJ IL:TEXTSTREAM))) (IL:* IL:\;
 "force shift select typein to be put in keyboard buffer")
(IL:TEXTPROP IL:TEXTSTREAM 'IL:COPYBYBKSYSBUF T)
(IL:|replace| (STREAM IL:STRMBOUTFN) IL:|of| IL:TEXTSTREAM IL:|with|
'IL:\\TEXTSTREAMBOUT)
(IL:|replace| SET IL:|of| (IL:|fetch| (IL:TEXTOBJ IL:SEL) IL:|of|
IL:TEXTOBJ)
IL:|with| T)
(IL:|replace| IL:L1 IL:|of| (IL:|fetch| (IL:TEXTOBJ IL:SEL) IL:|of|
IL:TEXTOBJ)
IL:|with| (LIST (IL:|fetch| IL:DESC IL:|of| (IL:|fetch| (IL:TEXTOBJ
IL:THISLINE)
IL:|of| IL:TEXTOBJ))))
(IL:* IL:\;
 "hookup middle button menu instead of TEDIT menu")
(IL:WINDOWPROP IL:WINDOW 'IL:TEDIT.TITLEMENUFN IL:MENUFN)
(RETURN IL:TEXTSTREAM))))
(IL:TEDITCHAT.MENUFN
(IL:LAMBDA (IL:WINDOW) (IL:* IL:|| "20-Oct-86 15:03")
(DECLARE (IL:GLOBALVARS IL:TEDITCHAT.MENU)
(IL:SPECVARS IL:WINDOW IL:STATE)) (IL:* IL:MIDDLEBUTTON)
(PROG ((IL:STATE (IL:WINDOWPROP IL:WINDOW 'IL:CHATSTATE))
IL:COMMAND)
(COND
((NOT IL:STATE) (IL:* IL:N\o IL:|Connection|
 IL:|here;| IL:|try| IL:|to|
 IL:|reestablish|)
(RETURN (COND
((IL:LASTMOUSESTATE IL:MIDDLE)
(IL:CHAT.RECONNECT IL:WINDOW))
(T (IL:TOTOPW IL:WINDOW))))))
(IL:|replace| (IL:CHAT.STATE IL:HELD) IL:|of| IL:STATE IL:|with| T)
(IL:\\CHECKCARET IL:WINDOW)
(IL:SELECTQ (IL:SETQ IL:COMMAND (IL:MENU (OR IL:TEDITCHAT.MENU (IL:SETQ IL:TEDITCHAT.MENU
(IL:|create| IL:MENU
IL:ITEMS IL:_
IL:TEDITCHAT.MENUITEMS
)))))
(IL:|Close| (IL:|replace| (IL:CHAT.STATE IL:RUNNING?) IL:|of| IL:STATE
IL:|with| 'IL:CLOSE) (IL:* IL:|Ask| IL:CHAT.TYPEIN IL:|to|
 IL:|shut| IL:|things| IL:|down.|)
)
(IL:|New| (IL:|replace| (IL:CHAT.STATE IL:RUNNING?) IL:|of| IL:STATE
IL:|with| 'IL:CLOSE)
(IL:WINDOWPROP IL:WINDOW 'IL:KEEPCHAT 'IL:NEW))
(IL:|Suspend| (IL:|replace| (IL:CHAT.STATE IL:RUNNING?) IL:|of| IL:STATE
IL:|with| 'IL:CLOSE)
(IL:WINDOWPROP IL:WINDOW 'IL:KEEPCHAT T))
(IL:|Freeze| (IL:* IL:|Leave| IL:|in| IL:HELD
 IL:|state|)
(RETURN))
(NIL)
(IL:APPLY* IL:COMMAND IL:STATE IL:WINDOW))
(IL:|replace| (IL:CHAT.STATE IL:HELD) IL:|of| IL:STATE IL:|with| NIL))))
)
(IL:* IL:\; "TEDIT update routines")
(IL:DEFINEQ
(IL:TEDIT.DISPLAYTEXT
(IL:LAMBDA (IL:TEXTOBJ IL:CH IL:CHWIDTH IL:LINE IL:XPOINT IL:DS IL:SEL)
(IL:* IL:\; "Edited 12-Jun-90 18:01 by mitani")
(IL:* IL:|This| IL:|function|
 IL:|does| IL:|the| IL:|actual|
 IL:|displaying| IL:|of|
 IL:|typed-in| IL:|text| IL:|on|
 IL:|the| IL:|edit| IL:|window.|)
(PROG ((IL:LOOKS (IL:\\TEDIT.APPLY.STYLES (IL:|fetch| (IL:TEXTOBJ IL:CARETLOOKS) IL:|of|
IL:TEXTOBJ)
(IL:|fetch| (IL:TEXTOBJ IL:\\INSERTPC) IL:|of| IL:TEXTOBJ)
IL:TEXTOBJ))
(IL:TERMSA (IL:|fetch| (IL:TEXTOBJ IL:TXTTERMSA) IL:|of| IL:TEXTOBJ))
IL:DY IL:FONT)
(IL:MOVETO IL:XPOINT (IL:IPLUS (IL:|fetch| IL:YBASE IL:|of| IL:LINE)
(OR (IL:|fetch| IL:CLOFFSET IL:|of| IL:LOOKS)
0))
IL:DS) (IL:* IL:|Set| IL:|the| IL:|display|
 IL:|stream| IL:|position|)
(COND
(IL:TERMSA (IL:* IL:|Special| IL:|terminal|
 IL:|table| IL:|for| IL:|controlling|
 IL:|character| IL:|display.|
 IL:|Use| IL:|it.|)
(IL:RESETLST
(IL:RESETSAVE IL:\\PRIMTERMSA IL:TERMSA)
(IL:|replace| (IL:TEXTSTREAM IL:REALFILE) IL:|of| (IL:|fetch|
(IL:TEXTOBJ
IL:STREAMHINT
)
IL:|of|
IL:TEXTOBJ)
IL:|with| IL:DS)
(COND
((IL:STRINGP IL:CH)
(IL:|for| IL:CHAR IL:|instring| IL:CH
IL:|do| (IL:SELCHARQ IL:CHAR
(IL:TAB (IL:* IL:|Put| IL:|down| IL:|white|)
(IL:BITBLT NIL 0 0 IL:DS IL:XPOINT
(IL:|fetch| IL:YBOT IL:|of|
IL:LINE)
36
(IL:|fetch| IL:LHEIGHT
IL:|of| IL:LINE)
'IL:TEXTURE
'IL:REPLACE IL:WHITESHADE)
(IL:RELMOVETO 36 0 IL:DS))
(IL:CR (IL:BITBLT NIL 0 0 IL:DS IL:XPOINT
(IL:|fetch| IL:YBOT IL:|of|
IL:LINE)
(IL:IMAX 6 (IL:CHARWIDTH IL:CHAR
IL:FONT))
(IL:|fetch| IL:LHEIGHT
IL:|of| IL:LINE)
'IL:TEXTURE
'IL:REPLACE IL:WHITESHADE))
(IL:\\DSPPRINTCHAR (IL:|fetch| (IL:TEXTOBJ
IL:STREAMHINT)
IL:|of| IL:TEXTOBJ)
IL:CHAR))))
(T (IL:SELCHARQ IL:CH
(IL:TAB (IL:* IL:|Put| IL:|down| IL:|white|)
(IL:BITBLT NIL 0 0 IL:DS IL:XPOINT (IL:|fetch|
IL:YBOT
IL:|of| IL:LINE
)
36
(IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE)
'IL:TEXTURE
'IL:REPLACE IL:WHITESHADE)
(IL:RELMOVETO 36 0 IL:DS))
(IL:CR (IL:BITBLT NIL 0 0 IL:DS IL:XPOINT (IL:|fetch| IL:YBOT
IL:|of| IL:LINE)
(IL:IMAX 6 (IL:CHARWIDTH IL:CH IL:FONT))
(IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE)
'IL:TEXTURE
'IL:REPLACE IL:WHITESHADE))
(IL:\\DSPPRINTCHAR (IL:|fetch| (IL:TEXTOBJ IL:STREAMHINT)
IL:|of| IL:TEXTOBJ)
IL:CH))))))
(T (IL:* IL:N\o IL:|special|
 IL:|handling;| IL:|just| IL:|use|
 IL:|native| IL:|character|
 IL:|codes|)
(COND
((IL:STRINGP IL:CH)
(IL:|for| IL:CHAR IL:|instring| IL:CH
IL:|do| (IL:SELCHARQ IL:CHAR
(IL:TAB (IL:* IL:|Put| IL:|down| IL:|white|)
(IL:BITBLT NIL 0 0 IL:DS (IL:DSPXPOSITION NIL IL:DS)
(IL:|fetch| IL:YBOT IL:|of| IL:LINE)
36
(IL:|fetch| IL:LHEIGHT IL:|of|
IL:LINE)
'IL:TEXTURE
'IL:REPLACE IL:WHITESHADE)
(IL:RELMOVETO 36 0 IL:DS))
(IL:CR (IL:BITBLT NIL 0 0 IL:DS (IL:DSPXPOSITION NIL IL:DS)
(IL:|fetch| IL:YBOT IL:|of| IL:LINE)
(IL:IMAX 6 (IL:CHARWIDTH IL:CHAR IL:FONT))
(IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE
)
'IL:TEXTURE
'IL:REPLACE IL:WHITESHADE))
(IL:BLTCHAR IL:CHAR IL:DS))))
(T (IL:SELCHARQ IL:CH
(IL:TAB (IL:* IL:|Put| IL:|down| IL:|white|)
(IL:BITBLT NIL 0 0 IL:DS (IL:DSPXPOSITION NIL IL:DS)
(IL:|fetch| IL:YBOT IL:|of| IL:LINE)
36
(IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE)
'IL:TEXTURE
'IL:REPLACE IL:WHITESHADE)
(IL:RELMOVETO 36 0 IL:DS))
(IL:CR (IL:* IL:|Blank| IL:|out| IL:|the|
 IL:|CR's| IL:|width.|)
(IL:BITBLT NIL 0 0 IL:DS (IL:DSPXPOSITION NIL IL:DS)
(IL:|fetch| IL:YBOT IL:|of| IL:LINE)
(IL:IMAX 6 (IL:CHARWIDTH IL:CH IL:FONT))
(IL:|fetch| IL:LHEIGHT IL:|of| IL:LINE)
'IL:TEXTURE
'IL:REPLACE IL:WHITESHADE))
(IL:BLTCHAR IL:CH IL:DS)))))))))
)
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
(IL:GLOBALVARS IL:TEDITCHAT.MENU IL:CHAT.DRIVERTYPES IL:CHAT.DISPLAYTYPES)
)
(IL:RPAQQ IL:TEDITCHAT.MENUITEMS
((IL:|Close| 'IL:|Close| "Closes the connection and returns")
(IL:|Suspend| 'IL:|Suspend| "Closes the connection but leaves window up")
(IL:|New| 'IL:|New| "Closes this connection and prompts for a new host")
(IL:|Freeze| 'IL:|Freeze| "Holds typeout in this window until you bug it again")
("Dribble" (IL:FUNCTION IL:CHAT.TYPESCRIPT)
"Starts a typescript of window typeout")
("Input" (IL:FUNCTION IL:CHAT.TAKE.INPUT)
"Allows input from a file")
("Option" (IL:FUNCTION IL:DO.CHAT.OPTION)
"Do protocol specific option")))
(IL:RPAQQ IL:TEDITCHAT.MENU NIL)
(IL:ADDTOVAR IL:CHAT.DRIVERTYPES (IL:TEDIT IL:TEDITCHAT.CHARFN IL:NILL))
(IL:DECLARE\: IL:EVAL@COMPILE IL:DONTCOPY
(IL:FILESLOAD (IL:SOURCE)
IL:CHATDECLS)
)
(IL:PUTPROPS IL:TEDITCHAT IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990 1994))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL (1308 15667 (IL:TEDITCHAT.CHARFN 1321 . 2481) (IL:\\TEXTSTREAMBOUT 2483 . 15665)) (
15668 20008 (IL:TEDITSTREAM.INIT 15681 . 17389) (IL:TEDITCHAT.MENUFN 17391 . 20006)) (20054 30055 (
IL:TEDIT.DISPLAYTEXT 20067 . 30053)))))
IL:STOP

1
library/TEDITCOMMAND Normal file
View File

File diff suppressed because one or more lines are too long

493
library/TEDITDCL Normal file
View File

@@ -0,0 +1,493 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "25-Aug-94 10:53:00" {DSK}<king>export>lispcore>library>TEDITDCL.;2 49062
previous date%: "25-Aug-94 10:38:37" {DSK}<king>export>lispcore>library>TEDITDCL.;1)
(* ; "
Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1993, 1994 by Venue. All rights reserved.
")
(PRETTYCOMPRINT TEDITDCLCOMS)
(RPAQQ TEDITDCLCOMS ((* ;;; "This file is the collected record declarations and compile-time necessities for TEDIT.") (* ;; "FROM TEDIT") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))) (* ;; "FROM TEDITSELECTION") (RECORDS SELECTION) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (COPYSELSHADE 30583) (COPYLOOKSSELSHADE 30583) (EDITMOVESHADE -1) (EDITGRAY 32800))) (VARS TEDITFILES) (* ;; "FROM TEDITSCREEN") (RECORDS THISLINE LINEDESCRIPTOR LINECACHE) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (LMInvisibleRun 401) (LMLooksChange 400))) (* ;; "FROM TEXTOFD") (RECORDS EDITMARK) (RECORDS PIECE TEXTOBJ TEXTIMAGEDATA TEXTSTREAM) (OPTIMIZERS TEXTPROP) (COMS (* ;; "Private data structures and constants FROM TEXTOFD") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\PCTBFreePieces 0) (\PCTBLastPieceOffset 1) (\FirstPieceOffset 2) (\SecondPieceOffset 4) (\EltsPerPiece 2)) (MACROS \EDITELT \GETCH \GETCHB \EDITSETA \WORDSETA) (GLOBALVARS \TEXTIMAGEOPS \TEXTOFD \TEXTFDEV))) (* ;;; "FROM TEDITPAGE") (RECORDS PAGEFORMATTINGSTATE PAGEREGION) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITPAPERSIZE) (FUNCTIONS \NEW-COLUMN-START \FIRST-COLUMN-START)) (* ;; "FROM TEDITFIND") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\AlphaNumericFlag 256) (\AlphaFlag 512) (\OneCharPattern 1024) (\AnyStringPattern 1025) (\OneAlphaPattern 1026) (\AnyAlphaPattern 1027) (\OneNonAlphaPattern 1028) (\AnyNonAlphaPattern 1029) (\LeftBracketPattern 1030) (\RightBracketPattern 1031) (\SpecialPattern 1024))) (* ;; " FROM TEDITLOOKS") (RECORDS CHARLOOKS FMTSPEC PENDINGTAB) (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \SMALLPIN \SMALLPOUT ONOFF)) (* ;; "FROM TEDITMENU") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MBUTTON)) (INITRECORDS MBUTTON) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS NWAYBUTTON)) (INITRECORDS NWAYBUTTON) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS MARGINBAR)) (INITRECORDS MARGINBAR) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TAB)) (RECORDS MB.3STATE MB.BUTTON MB.INSERT MB.MARGINBAR MB.NWAY MB.TEXT MB.TOGGLE) (FUNCTIONS WITHOUT-UPDATES) (* ;; "FROM TEDITHISTORY") (RECORDS TEDITHISTORYEVENT) (* ;; "FROM TEDITFILE") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\PieceDescriptorLOOKS 0) (\PieceDescriptorOBJECT 1) (\PieceDescriptorPARA 2) (\PieceDescriptorPAGEFRAME 3) (\PieceDescriptorCHARLOOKSLIST 4) (\PieceDescriptorPARALOOKSLIST 5) (\PieceDescriptorSAFEOBJECT 6))) (* ;; "FROM TEDITCOMMAND") (DECLARE%: EVAL@COMPILE DONTCOPY (MACROS \INSERT\TTY\BUFFER \TEDIT.MOUSESTATE \TEDIT.CHECK)) (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITTERMCODE)) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NONE.TTC 0) (CHARDELETE.TTC 1) (WORDDELETE.TTC 2) (DELETE.TTC 3) (FUNCTIONCALL.TTC 4) (REDO.TTC 5) (UNDO.TTC 6) (CMD.TTC 7) (NEXT.TTC 8) (EXPAND.TTC 9) (PUNCT.TTC 20) (TEXT.TTC 21) (WHITESPACE.TTC 22))) (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MSPACE 153) (NSPACE 152) (THINSPACE 159) (FIGSPACE 154))) (* ;; "FROM TEDITWINDOW") (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS TEDITCARET)) (INITRECORDS TEDITCARET) (* ;; "FROM PCTREE added by Nakamura") (RECORDS PCTNODE) (* ;;; "THE END") (COMS (* ;; "Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character ") (DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (NOTBEFORE.LB 1) (* ; "Must not break before this character (e.g. Japanese right-paren)") (NOTAFTER.LB 2) (* ; "Must not break after this character (e.g. Japanese open-quote)") (BEFORE.LB 4) (* ; "OK to break before this character, provided it's OK to break after the prior char (true of most non-white-space)") (AFTER.LB 8) (* ; "OK to break after this char, if it's OK to break before the next one (true of most white space)") (DISAPPEAR-IF-NOT-SPLIT.LB 16) (* ; "This character shouldn't be rendered if it isn't the last char on the line (non-breaking hyphen has this)") (NEWCHAR-IF-SPLIT.LB 32) (* ; "Look this char up in *TEDIT-SPLITCHAR-HASH* if this IS the last character on a line, and render it as the char we found.")))))
)
(* ;;; "This file is the collected record declarations and compile-time necessities for TEDIT.")
(* ;; "FROM TEDIT")
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ \SCRATCHLEN 64)
(CONSTANTS (\SCRATCHLEN 64))
)
)
(* ;; "FROM TEDITSELECTION")
(DECLARE%: EVAL@COMPILE
(DATATYPE SELECTION ((* ;; "Description of a piece of selected text for TEdit. Text has to be selected before it can be operated on by the user.") Y0 (* ; "Y value of topmost line of selection") X0 (* ; "X value of left edge of selection") DX (* ; "Width of the selection, if it's on one line.") CH# (* ; "CH# of the first selected character") XLIM (* ; "X value of right edge of last selected character") CHLIM (* ; "CH# of the last character in the selection") DCH (* ; "# of characters selected (can be zero, for point selection.)") L1 (* ; "-> line descriptor for the line where the first selected character is") LN (* ; "-> line descriptor for the line which contains the end of the selection") YLIM (* ; "Y value of the bottom of the line that ends the selection") POINT (* ; "Which end should the caret appear at? (LEFT or RIGHT)") (SET FLAG) (* ; "T if this selection is real; NIL if not") (\TEXTOBJ FULLXPOINTER) (* ; "TEXTOBJ that describes the selected text") SELKIND (* ; "What kind of selection? CHAR or WORD or LINE or PARA") HOW (* ; "SHADE used to highlight this selection") HOWHEIGHT (* ; "Height of the highlight (1 usually, full line for delete selection...)") (HASCARET FLAG) (* ; "T if there should be a caret for this selection") SELOBJ (* ; "If this selection is inside an object, which object?") (ONFLG FLAG) (* ; "T if the selection is highlighted on the screen, else NIL") SELOBJINFO (* ; "A Place for the selected object to put info about selection inside itself."))
SET _ NIL HOW _ BLACKSHADE HOWHEIGHT _ 1 HASCARET _ T Y0 _ 0 X0 _ 0 POINT _ (QUOTE LEFT) L1 _ (LIST NIL)
LN _ (LIST NIL))
)
(/DECLAREDATATYPE (QUOTE SELECTION) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER FLAG POINTER FLAG POINTER)) (QUOTE ((SELECTION 0 POINTER) (SELECTION 2 POINTER) (SELECTION 4 POINTER) (SELECTION 6 POINTER) (SELECTION 8 POINTER) (SELECTION 10 POINTER) (SELECTION 12 POINTER) (SELECTION 14 POINTER) (SELECTION 16 POINTER) (SELECTION 18 POINTER) (SELECTION 20 POINTER) (SELECTION 20 (FLAGBITS . 0)) (SELECTION 22 FULLXPOINTER) (SELECTION 24 POINTER) (SELECTION 26 POINTER) (SELECTION 28 POINTER) (SELECTION 28 (FLAGBITS . 0)) (SELECTION 30 POINTER) (SELECTION 30 (FLAGBITS . 0)) (SELECTION 32 POINTER))) (QUOTE 34))
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ COPYSELSHADE 30583)
(RPAQQ COPYLOOKSSELSHADE 30583)
(RPAQQ EDITMOVESHADE -1)
(RPAQQ EDITGRAY 32800)
(CONSTANTS (COPYSELSHADE 30583) (COPYLOOKSSELSHADE 30583) (EDITMOVESHADE -1) (EDITGRAY 32800))
)
)
(RPAQQ TEDITFILES (PCTREE TEXTOFD TEDIT TEDITABBREV TEDITCOMMAND TEDITDCL TEDITFILE TEDITFIND TEDITFNKEYS TEDITHCPY TEDITHISTORY TEDITLOOKS TEDITMENU TEDITPAGE TEDITSCREEN TEDITSELECTION TEDITWINDOW)
)
(* ;; "FROM TEDITSCREEN")
(DECLARE%: EVAL@COMPILE
(DATATYPE THISLINE ((* ;; "Cache for line-related character location info, for selection and line-display code to use.") (DESC FULLXPOINTER) (* ; "Line descriptor for the line this describes now") LEN (* ; "Length of the line in characters") CHARS (* ;; "Array of character codes (or objects) on the line (charcode of 400 => dummy entry for looks change--go get next entry in LOOKS)") WIDTHS (* ; "Array of each character's width in points") LOOKS (* ; "Array of any looks changes within the line. LOOKS (0) = starting character looks for the line") TLSPACEFACTOR (* ; "The SPACEFACTOR to be used in printing this line") TLFIRSTSPACE (* ; "The first space to which SPACEFACTOR is to apply. This is used so that spaces to the left of a TAB have their default width."))
LEN _ 0 CHARS _ (ARRAY 512 (QUOTE POINTER) 0 0) WIDTHS _ (ARRAY 512 (QUOTE POINTER) 0 0) LOOKS _ (ARRAY 512 (QUOTE POINTER) NIL 0)
TLFIRSTSPACE _ 0)
(DATATYPE LINEDESCRIPTOR ((* ;; "Description of a single line of formatted text, either on the display or for a printed page.") YBOT (* ; "Y value for the bottom of the line (below the descent)") YBASE (* ; "Yvalue for the base line the characters sit on") LEFTMARGIN (* ; "Left margin, in screen points") RIGHTMARGIN (* ; "Right margin, in screen points") LXLIM (* ; "X value of right edge of rightmost character on the line (may exceed right margin, if char is a space.)") SPACELEFT (* ; "Space left on the line, ignoring trailing blanks & CRs.") LHEIGHT (* ; "Total height of hte line, Ascent+Descent.") ASCENT (* ; "Ascent of the line above YBASE") DESCENT (* ; "How far line descends below YBASE") LTRUEDESCENT (* ; "The TRUE DESCENT for this line, unadjusted for line leading.") LTRUEASCENT (* ; "The TRUE ASCENT for this line, unadjusted for pre-paragraph leading.") CHAR1 (* ; "CH# of the first character on the line.") CHARLIM (* ; "CH# of the last character on the line") CHARTOP (* ; "CH# of the character which forced the line break (may exceed CHARLIM)") NEXTLINE (* ; "Next line chain pointer") (PREVLINE FULLXPOINTER) (* ; "Previous line chain pointer") LMARK (* ; "One of SOLID, GREY, NIL. Tells what kind of special-line marker should be put in the left margin for this paragraph. (For hardcopy, can also be an indicator for special processing?)") LTEXTOBJ (* ; "A cached TEXTOBJ that this line took its text from. Used in hardcopy to disambiguate when chno's should be updated...") CACHE (* ; "A cached THISLINE, for keeping hardcopy info around while we crunch with the line descriptors to make things fit.") LDOBJ (* ; "The object which lies behind this line of text, for updating, etc.") LFMTSPEC (* ; "The format spec for this line's paragraph (eventually)") (DIRTY FLAG) (* ; "T if this line has changed since it was last formatted.") (CR\END FLAG) (* ; "T if this line ends with a CR.") (DELETED FLAG) (* ; "T if this line has been completely deleted since it was last formatted or displayed. (Used by deletion routines to detect garbage lines)") (LHASPROT FLAG) (* ; "This line contains protected text.") (LHASTABS FLAG) (* ; "If this line has a tab in it, this is the line-relative ch# of the final tab. This is to let us punt properly with tabs in a line.") (1STLN FLAG) (* ; "This line is the first line in a paragraph") (LSTLN FLAG) (* ; "This is the last line in a paragraph"))
CHARLIM _ 1000000 NEXTLINE _ NIL PREVLINE _ NIL DIRTY _ NIL YBOT _ 0 YBASE _ 0 LEFTMARGIN _ 0 DELETED
_ NIL)
(DATATYPE LINECACHE ((* ;; "Image cache for display lines.") LCBITMAP (* ; "The bitmap that will be used by this instance of the cache") (LCNEXTCACHE FULLXPOINTER) (* ; "The next cache in the chain, for screen updates."))
)
)
(/DECLAREDATATYPE (QUOTE THISLINE) (QUOTE (FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((THISLINE 0 FULLXPOINTER) (THISLINE 2 POINTER) (THISLINE 4 POINTER) (THISLINE 6 POINTER) (THISLINE 8 POINTER) (THISLINE 10 POINTER) (THISLINE 12 POINTER))) (QUOTE 14))
(/DECLAREDATATYPE (QUOTE LINEDESCRIPTOR) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG)) (QUOTE ((LINEDESCRIPTOR 0 POINTER) (LINEDESCRIPTOR 2 POINTER) (LINEDESCRIPTOR 4 POINTER) (LINEDESCRIPTOR 6 POINTER) (LINEDESCRIPTOR 8 POINTER) (LINEDESCRIPTOR 10 POINTER) (LINEDESCRIPTOR 12 POINTER) (LINEDESCRIPTOR 14 POINTER) (LINEDESCRIPTOR 16 POINTER) (LINEDESCRIPTOR 18 POINTER) (LINEDESCRIPTOR 20 POINTER) (LINEDESCRIPTOR 22 POINTER) (LINEDESCRIPTOR 24 POINTER) (LINEDESCRIPTOR 26 POINTER) (LINEDESCRIPTOR 28 POINTER) (LINEDESCRIPTOR 30 FULLXPOINTER) (LINEDESCRIPTOR 32 POINTER) (LINEDESCRIPTOR 34 POINTER) (LINEDESCRIPTOR 36 POINTER) (LINEDESCRIPTOR 38 POINTER) (LINEDESCRIPTOR 40 POINTER) (LINEDESCRIPTOR 40 (FLAGBITS . 0)) (LINEDESCRIPTOR 40 (FLAGBITS . 16)) (LINEDESCRIPTOR 40 (FLAGBITS . 32)) (LINEDESCRIPTOR 40 (FLAGBITS . 48)) (LINEDESCRIPTOR 38 (FLAGBITS . 0)) (LINEDESCRIPTOR 38 (FLAGBITS . 16)) (LINEDESCRIPTOR 38 (FLAGBITS . 32)))) (QUOTE 42))
(/DECLAREDATATYPE (QUOTE LINECACHE) (QUOTE (POINTER FULLXPOINTER)) (QUOTE ((LINECACHE 0 POINTER) (LINECACHE 2 FULLXPOINTER))) (QUOTE 4))
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ LMInvisibleRun 401)
(RPAQQ LMLooksChange 400)
(CONSTANTS (LMInvisibleRun 401) (LMLooksChange 400))
)
)
(* ;; "FROM TEXTOFD")
(DECLARE%: EVAL@COMPILE
(RECORD EDITMARK ((* ;; "Used for fast access to a given place in the text--a %"Marker%". It consists of the piece, and the offset within the piece, and the piece number within the piece table. That's everything that's needed to set a text stream up quickly to start reading from a given place.") PC PCOFF . PCNO)
)
)
(DECLARE%: EVAL@COMPILE
(DATATYPE PIECE ((* ; "The piece describes either a string or part of a file. , or a generalized OBJECT.") PSTR (* ; "The string where this piece's text resides, or NIL") PFILE (* ; "The file which contains this piece's text, or NIL") PFPOS (* ; "The FILEPTR of the start of the piece in the file") PLEN (* ; "Length of the piece, in characters.") NEXTPIECE (* ; "-> Next piece in this textobj.") (PREVPIECE FULLXPOINTER) (* ; "-> Prior piece in this text object.") PLOOKS (* ; "Formatting info and formatting events in this piece") POBJ (* ; "The OBJECT this piece describes") (PPARALAST FLAG) (* ; "This piece contains a paragraph break") PPARALOOKS (* ; "Paragraph looks for this piece") (PNEW FLAG) (* ; "This text is new here; used by the tentative edit system, and anyone else interested.") (PFATP FLAG) (* ; "T if the characters in this piece are FAT -- i.e., are 16 bits each.") (PTREENODE XPOINTER) (* ; "Points to the PCTB tree-node that contains this piece."))
PSTR _ NIL PFILE _ NIL PFPOS _ 0 PLEN _ 0 PPARALOOKS _ TEDIT.DEFAULT.FMTSPEC PTREENODE _ NIL)
(DATATYPE TEXTOBJ ((* ;; "This is where TEdit stores its state information, and internal data about the text being edited.") PCTB (* ; "The piece table") TEXTLEN (* ; "# of chars in the text") \INSERTPC (* ; "Piece to hold type-in") \INSERTPCNO (* ; "Piece # of the input piece") \INSERTNEXTCH (* ; "CH# of next char which is typed into that piece.") \INSERTLEFT (* ; "Space left in the type-in piece") \INSERTLEN (* ; "# of characters already in the piece.") \INSERTSTRING (* ; "The string which the piece describes.") \INSERTFIRSTCH (* ; "CH# of first char in the piece.") (\INSERTPCVALID FLAG) (* ; "T if it's OK to use the cached piece. Set to NIL by people who require that the next insertion/deletion use a different piece.") \WINDOW (* ; "The window<s> where this textobj is displayed") MOUSEREGION (* ; "Section of the window the mouse is in.") LINES (* ; "-> to top of chain of line descriptors for displayed text") DS (* ; "Display stream where this textobj is displayed") SEL (* ; "The current selection within the text") SCRATCHSEL (* ; "Scratch space for the selection code") MOVESEL (* ; "Source for the next MOVE of text") SHIFTEDSEL (* ; "Source for the next COPY") DELETESEL (* ; "Text to be deleted imminently") WRIGHT (* ; "Right edge of the window (or subregion) where this is displayed") WTOP (* ; "Top of the window/region") WBOTTOM (* ; "Bottom of the window/region") WLEFT (* ; "Left edge of the window/region") TXTFILE (* ; "The original text file we're editing") (\XDIRTY FLAG) (* ; "T => changed since last saved.") (STREAMHINT FULLXPOINTER) (* ; "-> the TEXTOFD stream which gives access to this textobj") EDITFINISHEDFLG (* ; "T => The guy has asked the editor to go way") CARET (* ; "Describes the flashing caret for the editing window") CARETLOOKS (* ; "Font to be used for inserted text.") WINDOWTITLE (* ; "Original title for this window, of there was one.") THISLINE (* ; "Cache of line-related info, to speed up selection &c") (MENUFLG FLAG) (* ; "T if this TEXTOBJ is a tedit-style menu") FMTSPEC (* ; "Default Formatting Spec to be used when formatting paragraphs") (FORMATTEDP FLAG) (* ; "Flag for paragraph formatting. T if this document is to contain paragraph formatting information.") (TXTREADONLY FLAG) (* ; "This is only available for shift selection.") (TXTEDITING FLAG) (* ; "T => This document is in a window and there is an edit process behind it. For example, it only makes sense to have a caret show up if you are editing.") (TXTNONSCHARS FLAG) (* ; "T => If TEdit rns into a 255, it won't attempt to convert to NS characters. Used for REALLY plain-text manipulation.") TXTTERMSA (* ; "Special instructions for displaying characters on the screen") EDITOPACTIVE (* ; "T if there is an editing operation in progress. Used to interlock the TEdit menu") DEFAULTCHARLOOKS (* ; "The default character looks -- if any -- to be applied to characters coming into the file from outside.") TXTRTBL (* ; "The READTABLE to be used by the command loop for command dispatch") TXTWTBL (* ; "The READTABLE to be used to decide on word breaks") EDITPROPS (* ; "The PROPS that were passed into this edit session") (BLUEPENDINGDELETE FLAG) (* ; "T if the next insertion in this document is to be preceded by a deletion of the then-current selection") TXTHISTORY (* ; "The history list for this edit session.") (SELWINDOW FULLXPOINTER) (* ; "The window in which the last 'real' selection got made for this edit; used to control caret placement") PROMPTWINDOW (* ; "A window to be used for unscheduled interactions; normally a small window above the edit window") DISPLAYCACHE (* ; "The bitmap to be used when building the image of a line for display") DISPLAYCACHEDS (* ; "The DISPLAYSTREAM that is used to build line images") DISPLAYHCPYDS (* ; "The DISPLAYSTREAM used to build line images of lines that are displayed in 'hardcopy' simulation mode") TXTPAGEFRAMES (* ; "A tree of page frames, specifying how the document is to be laid out.") TXTCHARLOOKSLIST (* ; "List of all the CHARLOOKSs in the document, so they can be kept unique") TXTPARALOOKSLIST (* ; "List of all the FMTSPECs in the document, so they can be kept unique") (TXTNEEDSUPDATE FLAG) (* ; "T => Screen invalid, need to run updater") (TXTDON'TUPDATE FLAG) (* ; "T if we're holding off on screen updates until later. Used, e.g., by the menu-SHOW code so that you don't get piecemeal updates, but only one at the end of the SHOW.") TXTRAWINCLUDESTREAM (* ; "NODIRCORE stream used to cache RAW includes (and maybe later, all includes?)") DOCPROPS (* ; "Document properties that are stored with the document (not used yet)") TXTSTYLESHEET (* ; "Style sheet local to this document. Not currently saved as part of the file."))
(ACCESSFNS TEXTOBJ ((\DIRTY (ffetch (TEXTOBJ \XDIRTY) of DATUM) (PROGN (IF (NEQ (FETCH (TEXTOBJ \XDIRTY) OF DATUM) NEWVALUE) THEN (* ; "update the title to reflect the change") (\TEDIT.WINDOW.TITLE DATUM (\TEDIT.ORIGINAL.WINDOW.TITLE (ffetch (TEXTOBJ TXTFILE) of DATUM) NEWVALUE))) (freplace \XDIRTY OF DATUM WITH NEWVALUE)))))
SEL _ (create SELECTION) SCRATCHSEL _ (create SELECTION) MOVESEL _ (create SELECTION HOWHEIGHT _ 32767 HASCARET _ NIL)
SHIFTEDSEL _ (create SELECTION HASCARET _ NIL) DELETESEL _ (create SELECTION HOWHEIGHT _ 32767 HASCARET _ NIL)
\INSERTNEXTCH _ -1 \INSERTPC _ NIL \INSERTLEFT _ 0 \INSERTLEN _ 0 \INSERTSTRING _ NIL \INSERTFIRSTCH _
1000000 TEXTLEN _ 0 WRIGHT _ 0 WTOP _ 0 WLEFT _ 0 WBOTTOM _ 0 TXTFILE _ NIL \XDIRTY _ NIL MOUSEREGION
_ (QUOTE TEXT) THISLINE _ (create THISLINE) MENUFLG _ NIL FMTSPEC _ TEDIT.DEFAULT.FMTSPEC FORMATTEDP _
NIL)
(DATATYPE TEXTIMAGEDATA ((* ;; "Fills the IMAGEDATA field of text streams.") TICURPARALOOKS (* ; "The current paragraph looks") TICURIMAGESTREAM (* ; "The image stream for this hardcopy transduction") TILOOKSUPDATEFN (* ; "The function to call to update looks for this stream") TIPCOFFSET (* ; "The offset into the current piece, as of the last page cross."))
)
(ACCESSFNS TEXTSTREAM ((* ;; "Overlay for the STREAM record to allow mnemonic access to stream fields for Text streams.") (REALFILE (fetch F1 of DATUM) (REPLACE F1 OF DATUM WITH NEWVALUE)) (* ; "The real, underlying file behind the current piece") (CHARSLEFT (fetch F2 of DATUM) (REPLACE F2 OF DATUM WITH NEWVALUE)) (* ;; "The # of characters that will be left in the current piece the next time its file crosses a page boundary") (TEXTOBJ (fetch F3 of DATUM) (REPLACE F3 OF DATUM WITH NEWVALUE)) (* ; "The TEXTOBJ that is editing this text") (PIECE (fetch F5 of DATUM) (REPLACE F5 OF DATUM WITH NEWVALUE)) (* ; "The PIECE we're currently fetching chars from/putting chars into") (PCNO (fetch FW8 of DATUM) (REPLACE FW8 OF DATUM WITH NEWVALUE)) (* ; "The position of that piece in the piece table") (PCSTARTPG (fetch FW6 of DATUM) (REPLACE FW6 OF DATUM WITH NEWVALUE)) (* ; "The underlying file page# that this piece starts on") (PCSTARTCH (fetch FW7 of DATUM) (REPLACE FW7 OF DATUM WITH NEWVALUE)) (* ; "The char within page of the underlying file that this piece starts on -- for backbin & co") (PCOFFSET (fetch TIPCOFFSET of (fetch IMAGEDATA of DATUM)) (REPLACE TIPCOFFSET OF (fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; "The offset into the current piece, as of the last page cross.") (CURRENTLOOKS (fetch F10 of DATUM) (replace F10 of DATUM with NEWVALUE)) (* ; "The CHARLOOKS that are currently applicable to characters being taken from the stream.") (CURRENTPARALOOKS (fetch TICURPARALOOKS of (fetch IMAGEDATA of DATUM)) (REPLACE TICURPARALOOKS OF (fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; "The FMTSPEC that is currently applicable to characters being taken from the stream.") (CURRENTIMAGESTREAM (fetch TICURIMAGESTREAM of (fetch IMAGEDATA of DATUM)) (REPLACE TICURIMAGESTREAM OF (fetch IMAGEDATA of DATUM) with NEWVALUE) (* ; "The image stream that this text is being put onto; used for scaling decisions")) (LOOKSUPDATEFN (fetch TILOOKSUPDATEFN of (fetch IMAGEDATA of DATUM)) (REPLACE TILOOKSUPDATEFN OF (fetch IMAGEDATA of DATUM) with NEWVALUE)) (* ; "Function to be called each time character looks change.") (FATSTREAMP (fetch F4 of DATUM) (REPLACE F4 OF DATUM WITH NEWVALUE)) (* ; "T if the current piece is 16 bit characters."))
(CREATE (create STREAM using \TEXTOFD IMAGEDATA _ (create TEXTIMAGEDATA))))
)
(/DECLAREDATATYPE (QUOTE PIECE) (QUOTE (POINTER POINTER POINTER POINTER POINTER FULLXPOINTER POINTER POINTER FLAG POINTER FLAG FLAG XPOINTER)) (QUOTE ((PIECE 0 POINTER) (PIECE 2 POINTER) (PIECE 4 POINTER) (PIECE 6 POINTER) (PIECE 8 POINTER) (PIECE 10 FULLXPOINTER) (PIECE 12 POINTER) (PIECE 14 POINTER) (PIECE 14 (FLAGBITS . 0)) (PIECE 16 POINTER) (PIECE 16 (FLAGBITS . 0)) (PIECE 16 (FLAGBITS . 16)) (PIECE 18 XPOINTER))) (QUOTE 20))
(/DECLAREDATATYPE (QUOTE TEXTOBJ) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FULLXPOINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER FULLXPOINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG POINTER POINTER POINTER)) (QUOTE ((TEXTOBJ 0 POINTER) (TEXTOBJ 2 POINTER) (TEXTOBJ 4 POINTER) (TEXTOBJ 6 POINTER) (TEXTOBJ 8 POINTER) (TEXTOBJ 10 POINTER) (TEXTOBJ 12 POINTER) (TEXTOBJ 14 POINTER) (TEXTOBJ 16 POINTER) (TEXTOBJ 16 (FLAGBITS . 0)) (TEXTOBJ 18 POINTER) (TEXTOBJ 20 POINTER) (TEXTOBJ 22 POINTER) (TEXTOBJ 24 POINTER) (TEXTOBJ 26 POINTER) (TEXTOBJ 28 POINTER) (TEXTOBJ 30 POINTER) (TEXTOBJ 32 POINTER) (TEXTOBJ 34 POINTER) (TEXTOBJ 36 POINTER) (TEXTOBJ 38 POINTER) (TEXTOBJ 40 POINTER) (TEXTOBJ 42 POINTER) (TEXTOBJ 44 POINTER) (TEXTOBJ 44 (FLAGBITS . 0)) (TEXTOBJ 46 FULLXPOINTER) (TEXTOBJ 48 POINTER) (TEXTOBJ 50 POINTER) (TEXTOBJ 52 POINTER) (TEXTOBJ 54 POINTER) (TEXTOBJ 56 POINTER) (TEXTOBJ 56 (FLAGBITS . 0)) (TEXTOBJ 58 POINTER) (TEXTOBJ 58 (FLAGBITS . 0)) (TEXTOBJ 58 (FLAGBITS . 16)) (TEXTOBJ 58 (FLAGBITS . 32)) (TEXTOBJ 58 (FLAGBITS . 48)) (TEXTOBJ 60 POINTER) (TEXTOBJ 62 POINTER) (TEXTOBJ 64 POINTER) (TEXTOBJ 66 POINTER) (TEXTOBJ 68 POINTER) (TEXTOBJ 70 POINTER) (TEXTOBJ 70 (FLAGBITS . 0)) (TEXTOBJ 72 POINTER) (TEXTOBJ 74 FULLXPOINTER) (TEXTOBJ 76 POINTER) (TEXTOBJ 78 POINTER) (TEXTOBJ 80 POINTER) (TEXTOBJ 82 POINTER) (TEXTOBJ 84 POINTER) (TEXTOBJ 86 POINTER) (TEXTOBJ 88 POINTER) (TEXTOBJ 88 (FLAGBITS . 0)) (TEXTOBJ 88 (FLAGBITS . 16)) (TEXTOBJ 90 POINTER) (TEXTOBJ 92 POINTER) (TEXTOBJ 94 POINTER))) (QUOTE 96))
(/DECLAREDATATYPE (QUOTE TEXTIMAGEDATA) (QUOTE (POINTER POINTER POINTER POINTER)) (QUOTE ((TEXTIMAGEDATA 0 POINTER) (TEXTIMAGEDATA 2 POINTER) (TEXTIMAGEDATA 4 POINTER) (TEXTIMAGEDATA 6 POINTER))) (QUOTE 8))
(DEFOPTIMIZER TEXTPROP (TEXTOBJ PROP &OPTIONAL (VAL NIL WRITING)) (* ;; "compiles calls to TEXTPROP") (COND ((NOT (LISTP PROP)) (* ; "property is not quoted.") (QUOTE IGNOREMACRO)) ((NOT (EQ (CAR PROP) (QUOTE QUOTE))) (* ; "property is not quoted.") (QUOTE IGNOREMACRO)) ((NOT WRITING) (* ; "fetching a TEXTPROP property.") (SELECTQ (CADR PROP) ((READONLY READ-ONLY) (BQUOTE (fetch (TEXTOBJ TXTREADONLY) of (TEXTOBJ (\, TEXTOBJ))))) ((BEING-EDITED ACTIVE) (BQUOTE (fetch (TEXTOBJ TXTEDITING) of (TEXTOBJ (\, TEXTOBJ))))) ((NO-NS-CHARS NONSCHARS NO-NSCHARS) (BQUOTE (fetch (TEXTOBJ TXTNONSCHARS) of (TEXTOBJ (\, TEXTOBJ))))) (BQUOTE (LISTGET (fetch (TEXTOBJ EDITPROPS) of (TEXTOBJ (\, TEXTOBJ))) (\, PROP))))) (T (* ; "storing a window property") (SELECTQ (CADR PROP) ((READONLY READ-ONLY) (BQUOTE (REPLACE (TEXTOBJ TXTREADONLY) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) ((BEING-EDITED ACTIVE) (BQUOTE (REPLACE (TEXTOBJ TXTEDITING) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) ((NO-NS-CHARS NONSCHARS NO-NSCHARS) (BQUOTE (REPLACE (TEXTOBJ TXTNONSCHARS) OF (TEXTOBJ (\, TEXTOBJ)) WITH (\, VAL)))) (BQUOTE (LET* (($$TEXTOBJ$$ (TEXTOBJ (\, TEXTOBJ))) ($$PROPLST$$ (FETCH EDITPROPS OF $$TEXTOBJ$$))) (COND ($$PROPLST$$ (LISTPUT $$PROPLST$$ (\, PROP) (\, VAL))) (T (REPLACE EDITPROPS OF $$TEXTOBJ$$ WITH (LIST (\, PROP) (\, VAL)))))))))))
(* ;; "Private data structures and constants FROM TEXTOFD")
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ \PCTBFreePieces 0)
(RPAQQ \PCTBLastPieceOffset 1)
(RPAQQ \FirstPieceOffset 2)
(RPAQQ \SecondPieceOffset 4)
(RPAQQ \EltsPerPiece 2)
(CONSTANTS (\PCTBFreePieces 0) (\PCTBLastPieceOffset 1) (\FirstPieceOffset 2) (\SecondPieceOffset 4) (\EltsPerPiece 2))
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS \EDITELT DMACRO (OPENLAMBDA (ARR NO) (* This is equivalent to ELT, but bypasses the checking, since we "know" that ARR is an array. Hence, much faster.) (GETBASEPTR (\ADDBASE2 (fetch (ARRAYP BASE) of ARR) NO) 0)))
(PUTPROPS \GETCH MACRO ((TEXTOBJ) (* jds "23-FEB-82 08:56") (* Get the next available character from the text being edited.) (\BIN (fetch STREAMHINT of TEXTOBJ))))
(PUTPROPS \GETCHB MACRO ((TEXTOBJ) (* Get the next prior character in the text being edited.) (\BACKBIN (fetch STREAMHINT of TEXTOBJ))))
(PUTPROPS \EDITSETA DMACRO (OPENLAMBDA (ARR N VAL) (* Equivalent to SETA (for pointer-type arrays) %, but bypasses the bounds and type checking. Hence MUCH faster.) (\RPLPTR (\ADDBASE2 (fetch (ARRAYP BASE) of ARR) N) 0 VAL)))
(PUTPROPS \WORDSETA DMACRO (OPENLAMBDA (A J V) (CHECK (AND (ARRAYP A) (ZEROP (fetch (ARRAYP ORIG) of A)) (EQ \ST.POS16 (fetch (ARRAYP TYP) of A)))) (CHECK (IGREATERP (fetch (ARRAYP LENGTH) of A) J)) (\PUTBASE (fetch (ARRAYP BASE) of A) (IPLUS (fetch (ARRAYP OFFST) of A) J) V)))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \TEXTIMAGEOPS \TEXTOFD \TEXTFDEV)
)
)
(* ;;; "FROM TEDITPAGE")
(DECLARE%: EVAL@COMPILE
(RECORD PAGEFORMATTINGSTATE ((* ;; "Contains the state for a TEdit page-formatting job.") PAGE# (* ; "The current page number. Counted from 1") FIRSTPAGE (* ;; "T if the current page is the 'first page' . Is set initially, and can be set again by the user at will. Gets reset after each page image is printed.") MINPAGE# (* ; "The page # of the first page to be printed, or NIL") MAXPAGE# (* ; "The page # of the last page to be printed, or NIL") STATE (* ; "One of FORMATTING or SEARCHING.") REQUIREDREGIONTYPE (* ; "If STATE is SEARCHING, the kind of box we're looking for. If STATE is :SEARCHING-FOR-EQUIVALENT-PAGE, this is the page count for the matching page.") MAINSTREAM (* ; "The principal textobj/stream source") CHNO (* ; "Our position in that stream") PRESSREGION (* ; "The press code's REGION info.") PAGEHEADINGS (* ; "The list of current values to be printed, indexed by heading type") PAGE#GENERATOR (* ; "List of page numbers; later, maybe, a function to generate page numbers. Used to fill in PAGE#TEXT, below") PAGE#TEXT (* ; "If special page numbers are in use, this is the place to take them from. PAGE# is still used for recto/verso decisions &c") PAGEISRECTO (* ; "T if this is a recto page, NIL if it's a VERSO page.") PAGEFOOTNOTELINES (* ; "A list of extant footnote lines that should appear at the next opportunity") PAGEFLOATINGTOPLINES (* ; "A list of lines that should float to the top of the next available place") PAGECOUNT (* ; "The number of pages we've formatted so far.") PAGELINECACHE (* ; "A cache for pre-created LINEDESCRIPTOR/THISLINE sets, to avoid the overhead of re-allocating them all the time") NEWPAGELAYOUT (* ; "If we switch page layouts in mid-document, this is where the new layout gets cached until we get started again."))
PAGECOUNT _ 0)
(DATATYPE PAGEREGION ((* ;; "Describe a part of a page for page formatting. Can be made into compound descriptions.") REGIONFILLMETHOD (* ; "What kind of a region this is -- TEXT, FOLIO, PAGEHEADING, etc.") REGIONSPEC (* ; "The page-relative region this occupies") REGIONLOCALINFO (* ; "A PLIST for local information") (REGIONPARENT FULLXPOINTER) (* ; "The parent node for this box, for sub-boxes") REGIONSUBBOXES (* ; "The sub-regions of this region") REGIONTYPE (* ; "A user-settable region type"))
)
)
(/DECLAREDATATYPE (QUOTE PAGEREGION) (QUOTE (POINTER POINTER POINTER FULLXPOINTER POINTER POINTER)) (QUOTE ((PAGEREGION 0 POINTER) (PAGEREGION 2 POINTER) (PAGEREGION 4 POINTER) (PAGEREGION 6 FULLXPOINTER) (PAGEREGION 8 POINTER) (PAGEREGION 10 POINTER))) (QUOTE 12))
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD TEDITPAPERSIZE ((* ;; "Describe the size of a sheet of paper (in points), given a paper size-name.") TPSNAME (* ; "The name, as a litatom") TPSWIDTH (* ; "Paper width, in points") TPSHEIGHT (* ; "Paper Height, in points") TPSLANDSCAPE? (* ; "T if we have to rotate things to print them on this paper."))
)
)
(DEFMACRO \NEW-COLUMN-START (LINE FMTSPEC) (BQUOTE (AND (FFETCH (LINEDESCRIPTOR 1STLN) OF (\, LINE)) (EQ (FFETCH (FMTSPEC FMTCOLUMN) OF (\, FMTSPEC)) (QUOTE NEXT)))))
(DEFMACRO \FIRST-COLUMN-START (LINE FMTSPEC) (BQUOTE (AND (FFETCH (LINEDESCRIPTOR 1STLN) OF (\, LINE)) (EQ (FFETCH (FMTSPEC FMTCOLUMN) OF (\, FMTSPEC)) (QUOTE FIRST)))))
)
(* ;; "FROM TEDITFIND")
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ \AlphaNumericFlag 256)
(RPAQQ \AlphaFlag 512)
(RPAQQ \OneCharPattern 1024)
(RPAQQ \AnyStringPattern 1025)
(RPAQQ \OneAlphaPattern 1026)
(RPAQQ \AnyAlphaPattern 1027)
(RPAQQ \OneNonAlphaPattern 1028)
(RPAQQ \AnyNonAlphaPattern 1029)
(RPAQQ \LeftBracketPattern 1030)
(RPAQQ \RightBracketPattern 1031)
(RPAQQ \SpecialPattern 1024)
(CONSTANTS (\AlphaNumericFlag 256) (\AlphaFlag 512) (\OneCharPattern 1024) (\AnyStringPattern 1025) (\OneAlphaPattern 1026) (\AnyAlphaPattern 1027) (\OneNonAlphaPattern 1028) (\AnyNonAlphaPattern 1029) (\LeftBracketPattern 1030) (\RightBracketPattern 1031) (\SpecialPattern 1024))
)
)
(* ;; " FROM TEDITLOOKS")
(DECLARE%: EVAL@COMPILE
(DATATYPE CHARLOOKS ((* ;; "Describes the appearance (%"Looks%") of characters in a TEdit document.") CLFONT (* ; "The font descriptor for these characters") CLNAME (* ;; "Name of the font (e.g., HELVETICA) THIS FIELD IS A HINT, OR FOR USE IN CHARLOOKS-BUILDING CODE. USE FONTPROP TO GET THE RIGHT VALUE FROM CLFONT.") CLSIZE (* ; "Font size, in points") (CLITAL FLAG) (* ; "T if the characters are italic, else NIL") (CLBOLD FLAG) (* ; "T if the characters are bold, else NIL") (CLULINE FLAG) (* ; "T if the characters are to be underscored, else NIL") (CLOLINE FLAG) (* ; "T if the characters are to be overscored, else NIL") (CLSTRIKE FLAG) (* ; "T if the characters are to be struck thru, else nil.") CLOFFSET (* ; "A superscripting offset in points (?) else NIL (SUBSCRIPTING IF NEGATIVE.)") (CLSMALLCAP FLAG) (* ; "T if small caps, else NIL") (CLINVERTED FLAG) (* ; "T if the characters are to be shown white-on-black") (CLPROTECTED FLAG) (* ; "T if chars can't be selected, else NIL") (CLINVISIBLE FLAG) (* ; "T if TEDIT is to ignore these chars; else NIL") (CLSELHERE FLAG) (* ;; "T if TEDIT can put selection after this char (for menu blanks) else NIL; anything typed after this char will NOT BE PROTECTED.") (CLCANCOPY FLAG) (* ;; "T if this text can be selected for copying, even tho protected (it will become unprotected after the copy; for Dribble/TTY interface)") CLSTYLE (* ; "The style to be used in marking these characters; overridden by the other fields") CLUSERINFO (* ; "Any information that an outsider wants to include") CLLEADER (* ; "For creating dotted and other kinds of leader") CLRULES (* ;; "For arbitrarily-places horizontal rules. List of pairs, of (widthinpts . offsetfrombaselineinpts). Should be taken account of in ascent/descent calcs.") (CLMARK FLAG) (* ;; "Used for a mark-&-sweep of looks at PUT time -- T means this set of looks really IS in use in the document"))
CLOFFSET _ 0)
(DATATYPE FMTSPEC ((* ;; "Describe the paragraph formatting for a paragraph in a TEdit document.") 1STLEFTMAR (* ; "Left margin of the first line of the paragraph") LEFTMAR (* ; "Left margin of the rest of the lines in the paragraph") RIGHTMAR (* ; "Right margin for the paragraph") LEADBEFORE (* ; "Leading above the paragraph's first line, in points") LEADAFTER (* ; "Leading below the paragraph's bottom line, in points. NOT IMPLEMENTED.") LINELEAD (* ; "Leading between lines, in points. Actually, this space is added BELOW each line in the para.") FMTBASETOBASE (* ; "The baseline-to-baseline spacing between lines in this paragraph. THIS OVERRIDES THE LINE LEADING") TABSPEC (* ; "The list of tabs for this paragraph, including CAR for a default tab width") QUAD (* ; "How the para is formatted: one of LEFT, RIGHT, CENTERED, JUSTIFIED") FMTSTYLE (* ; "The STYLE that controls this paragraph's appearance") FMTCHARSTYLES (* ; "The characterstyles that control the appearance of characters in this para (maybe? may be part of the fmtstyle.)") FMTUSERINFO (* ; "Space for a PLIST of user info") FMTSPECIALX (* ; "A special horizontal location on the printed page for this para.") FMTSPECIALY (* ; "A special vertical location on the page for this para") (FMTHEADINGKEEP FLAG) (* ; "This para should be kept with the top line or so of the next para..") FMTPARATYPE (* ; "What kind of para this is: TEXT, PAGEHEADING, whatever") FMTPARASUBTYPE (* ; "Sub type of the type, e.g., what KIND of page heading this is.") FMTNEWPAGEBEFORE (* ; "Start a new box (if T) or back up the page formatting tree to make a new box of the type named in the value -- by going the least distance back up the tree, then back down until you find that kind of box.") FMTNEWPAGEAFTER (* ; "Similarly") FMTKEEP (* ; "For information about how this paragraph is to be kept with other paragraphs.") FMTCOLUMN (* ; "For setting up side-by-side paragraphs easily ala BravoX") FMTVERTRULES (* ; "For Keeping track of vertical rules in force") (FMTMARK FLAG) (* ; "Used to keep track of which PARALOOKSs are really being used -- a mark & collect is done just before a PUT, so that only 'real' PARALOOKSs make it into the file") (* ; "Used for a mark&sweep of para looks at PUT time -- T means this looks really IS in use in the document, so it makes sense to save it on the file.") (FMTHARDCOPY FLAG) (* ; "T if this paragraph is to be displayed in hardcopy-format.") FMTREVISED (* ; "T (or perhaps a revision level or revision-mark spec??) if this paragraph is to be marked as changed on output."))
TABSPEC _ (CONS NIL NIL))
(DATATYPE PENDINGTAB ((* ;; "The data structure for a tab, within the line formatter, that we haven't finished dealing with yet, e.g. a centered tab where you need to wait for AFTER the centered text to do the formatting.") PTNEWTX (* ;; "An updated TX, being passed back to the line formatter. This results from the resolution of an old RIGHT, CENTERED, or DECIMAL tab, which changed the width of a prior tab.") PTOLDTAB (* ; "The pending tab") PTTYPE (* ; "Its tab type") PTTABX (* ; "Its nominal X position") (PTWBASE FULLXPOINTER) (* ; "The WBASE for its width, for updating when we've figured out how wide the tab really is") PTOLDTX (* ; "The TX as of when the tab was encountered."))
)
)
(/DECLAREDATATYPE (QUOTE CHARLOOKS) (QUOTE (POINTER POINTER POINTER FLAG FLAG FLAG FLAG FLAG POINTER FLAG FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER POINTER FLAG)) (QUOTE ((CHARLOOKS 0 POINTER) (CHARLOOKS 2 POINTER) (CHARLOOKS 4 POINTER) (CHARLOOKS 4 (FLAGBITS . 0)) (CHARLOOKS 4 (FLAGBITS . 16)) (CHARLOOKS 4 (FLAGBITS . 32)) (CHARLOOKS 4 (FLAGBITS . 48)) (CHARLOOKS 2 (FLAGBITS . 0)) (CHARLOOKS 6 POINTER) (CHARLOOKS 6 (FLAGBITS . 0)) (CHARLOOKS 6 (FLAGBITS . 16)) (CHARLOOKS 6 (FLAGBITS . 32)) (CHARLOOKS 6 (FLAGBITS . 48)) (CHARLOOKS 2 (FLAGBITS . 16)) (CHARLOOKS 2 (FLAGBITS . 32)) (CHARLOOKS 8 POINTER) (CHARLOOKS 10 POINTER) (CHARLOOKS 12 POINTER) (CHARLOOKS 14 POINTER) (CHARLOOKS 14 (FLAGBITS . 0)))) (QUOTE 16))
(/DECLAREDATATYPE (QUOTE FMTSPEC) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG POINTER POINTER POINTER POINTER POINTER POINTER POINTER FLAG FLAG POINTER)) (QUOTE ((FMTSPEC 0 POINTER) (FMTSPEC 2 POINTER) (FMTSPEC 4 POINTER) (FMTSPEC 6 POINTER) (FMTSPEC 8 POINTER) (FMTSPEC 10 POINTER) (FMTSPEC 12 POINTER) (FMTSPEC 14 POINTER) (FMTSPEC 16 POINTER) (FMTSPEC 18 POINTER) (FMTSPEC 20 POINTER) (FMTSPEC 22 POINTER) (FMTSPEC 24 POINTER) (FMTSPEC 26 POINTER) (FMTSPEC 26 (FLAGBITS . 0)) (FMTSPEC 28 POINTER) (FMTSPEC 30 POINTER) (FMTSPEC 32 POINTER) (FMTSPEC 34 POINTER) (FMTSPEC 36 POINTER) (FMTSPEC 38 POINTER) (FMTSPEC 40 POINTER) (FMTSPEC 40 (FLAGBITS . 0)) (FMTSPEC 40 (FLAGBITS . 16)) (FMTSPEC 42 POINTER))) (QUOTE 44))
(/DECLAREDATATYPE (QUOTE PENDINGTAB) (QUOTE (POINTER POINTER POINTER POINTER FULLXPOINTER POINTER)) (QUOTE ((PENDINGTAB 0 POINTER) (PENDINGTAB 2 POINTER) (PENDINGTAB 4 POINTER) (PENDINGTAB 6 POINTER) (PENDINGTAB 8 FULLXPOINTER) (PENDINGTAB 10 POINTER))) (QUOTE 12))
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS \SMALLPIN MACRO (OPENLAMBDA (STREAM) (SIGNED (create WORD HIBYTE _ (\BIN STREAM) LOBYTE _ (\BIN STREAM)) BITSPERWORD)))
(PUTPROPS \SMALLPOUT MACRO (OPENLAMBDA (STREAM W) (\BOUT STREAM (LOGAND 255 (LRSH W 8))) (\BOUT STREAM (LOGAND W 255))))
(PUTPROPS ONOFF MACRO (OPENLAMBDA (VAL) (COND (VAL (QUOTE ON)) (T (QUOTE OFF)))))
)
)
(* ;; "FROM TEDITMENU")
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD MBUTTON NIL (TYPE? (AND (IMAGEOBJP DATUM) (OR (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE MB.DISPLAY)) (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE MB.THREESTATE.DISPLAY)) (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE \TEXTMENU.TOGGLE.DISPLAY)))))
)
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD NWAYBUTTON NIL (TYPE? (AND (IMAGEOBJP DATUM) (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE MB.NB.DISPLAYFN))))
)
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD MARGINBAR (MARL1 MARLN MARR MARTABS MARUNIT MARTABTYPE) (TYPE? (AND (IMAGEOBJP DATUM) (EQ (IMAGEOBJPROP DATUM (QUOTE DISPLAYFN)) (QUOTE MB.MARGINBAR.DISPLAYFN))))
)
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RECORD TAB (TABX . TABKIND))
)
)
(DECLARE%: EVAL@COMPILE
(TYPERECORD MB.3STATE ((* ;; "Describes a 3-state menu button.") MBLABEL (* ; "Label for the button on the screen") MBFONT (* ; "Font the label text should appear in") MBCHANGESTATEFN (* ; "Function to call when the button's state changes") MBINITSTATE (* ; "Button's initial state."))
MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD)))
(TYPERECORD MB.BUTTON (MBLABEL MBBUTTONEVENTFN MBFONT) MBBUTTONEVENTFN _ (QUOTE MB.DEFAULTBUTTON.FN)
MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD)))
(TYPERECORD MB.INSERT (MBINITENTRY))
(TYPERECORD MB.MARGINBAR (ignoredfield))
(TYPERECORD MB.NWAY (MBBUTTONS MBFONT MBCHANGESTATEFN MBINITSTATE MBMAXITEMSPERLINE) MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))
)
(TYPERECORD MB.TEXT (MBSTRING MBFONT))
(TYPERECORD MB.TOGGLE (MBTEXT MBFONT MBCHANGESTATEFN MBINITSTATE) MBFONT _ (FONTCREATE (QUOTE HELVETICA) 8 (QUOTE BOLD))
)
)
(DEFMACRO WITHOUT-UPDATES (TEXTOBJ SCRATCHSEL &BODY BODY) (* ;; "For TEdit windows, run BODY without updating the edit window for TEXTOBJ. This is useful if you're making a log of changes to a document at one time, where the changes are in essence atomic, and you don't need to see intermediate results. It's also a good bit faster than constant updating.") (* ;; "TEXTOBJ is the TEXTOBJ for the document you'll be modifying.") (* ;; "SCRATCHSEL should be the scratch selection (often used in this work)") (BQUOTE (LET ((OLD-UNWIND-FLAG (FETCH (TEXTOBJ TXTDON'TUPDATE) OF (\, TEXTOBJ)))) (CL:UNWIND-PROTECT (PROGN (replace (TEXTOBJ TXTDON'TUPDATE) of (\, TEXTOBJ) with T) (\,@ BODY)) (\SHOWSEL (\, SCRATCHSEL) NIL NIL) (replace SET of (\, SCRATCHSEL) with NIL) (\TEDIT.MARK.LINES.DIRTY (\, TEXTOBJ) 1 (fetch (TEXTOBJ TEXTLEN) of (\, TEXTOBJ))) (replace (TEXTOBJ TXTDON'TUPDATE) of (\, TEXTOBJ) with OLD-UNWIND-FLAG) (TEDIT.UPDATE.SCREEN (\, TEXTOBJ))))))
(* ;; "FROM TEDITHISTORY")
(DECLARE%: EVAL@COMPILE
(RECORD TEDITHISTORYEVENT ((* ;; "Describes one event on the TEdit edit history list.") THACTION (* ; "A LITATOM, specifying what the event was") THPOINT (* ; "Was the selection to the left or right?") THLEN (* ; "The # of chars involved") THCH# (* ; "The starting ch#") THFIRSTPIECE (* ; "First piece involved") THOLDINFO (* ; "Old info, for undo") THAUXINFO (* ; "Auxiliary info about the event, primarily for redo") THTEXTOBJ (* ;; "Place to remember a second textobj, for those like MOVE who need to remember both a source and a destination."))
THPOINT _ (QUOTE LEFT))
)
(* ;; "FROM TEDITFILE")
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ \PieceDescriptorLOOKS 0)
(RPAQQ \PieceDescriptorOBJECT 1)
(RPAQQ \PieceDescriptorPARA 2)
(RPAQQ \PieceDescriptorPAGEFRAME 3)
(RPAQQ \PieceDescriptorCHARLOOKSLIST 4)
(RPAQQ \PieceDescriptorPARALOOKSLIST 5)
(RPAQQ \PieceDescriptorSAFEOBJECT 6)
(CONSTANTS (\PieceDescriptorLOOKS 0) (\PieceDescriptorOBJECT 1) (\PieceDescriptorPARA 2) (\PieceDescriptorPAGEFRAME 3) (\PieceDescriptorCHARLOOKSLIST 4) (\PieceDescriptorPARALOOKSLIST 5) (\PieceDescriptorSAFEOBJECT 6))
)
)
(* ;; "FROM TEDITCOMMAND")
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS \INSERT\TTY\BUFFER MACRO (NIL (\TEDIT.INSERT.TTY.BUFFER ISCRSTRING IPASSSTRING TEXTOBJ SEL)))
(PUTPROPS \TEDIT.MOUSESTATE MACRO (BUTTON (* Test to see if only the specified mouse button is down. DOES NOT call GETMOUSESTATE, so the mouse-button info is the same as the last time it WAS called.) (SELECTQ (CAR BUTTON) (LEFT (QUOTE (IEQP LASTMOUSEBUTTONS 4))) (MIDDLE (QUOTE (IEQP LASTMOUSEBUTTONS 1))) (RIGHT (QUOTE (IEQP LASTMOUSEBUTTONS 2))) (SHOULDNT))))
(PUTPROPS \TEDIT.CHECK MACRO (ARGS (COND ((AND (BOUNDP (QUOTE CHECK)) CHECK) (CONS (QUOTE PROGN) (for I in ARGS as J on ARGS when (NOT (STRINGP I)) collect (LIST (QUOTE OR) I (LIST (QUOTE HELP) "TEdit consistency-check failure [RETURN to continue]: " (COND ((STRINGP (CADR J))) (T (KWOTE I)))))))) (T (CONS COMMENTFLG ARGS)))))
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(ACCESSFNS TEDITTERMCODE ((TTCLASS (LOGAND DATUM 224)) (TTDECODE (LOGAND DATUM 31))))
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ NONE.TTC 0)
(RPAQQ CHARDELETE.TTC 1)
(RPAQQ WORDDELETE.TTC 2)
(RPAQQ DELETE.TTC 3)
(RPAQQ FUNCTIONCALL.TTC 4)
(RPAQQ REDO.TTC 5)
(RPAQQ UNDO.TTC 6)
(RPAQQ CMD.TTC 7)
(RPAQQ NEXT.TTC 8)
(RPAQQ EXPAND.TTC 9)
(RPAQQ PUNCT.TTC 20)
(RPAQQ TEXT.TTC 21)
(RPAQQ WHITESPACE.TTC 22)
(CONSTANTS (NONE.TTC 0) (CHARDELETE.TTC 1) (WORDDELETE.TTC 2) (DELETE.TTC 3) (FUNCTIONCALL.TTC 4) (REDO.TTC 5) (UNDO.TTC 6) (CMD.TTC 7) (NEXT.TTC 8) (EXPAND.TTC 9) (PUNCT.TTC 20) (TEXT.TTC 21) (WHITESPACE.TTC 22))
)
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ MSPACE 153)
(RPAQQ NSPACE 152)
(RPAQQ THINSPACE 159)
(RPAQQ FIGSPACE 154)
(CONSTANTS (MSPACE 153) (NSPACE 152) (THINSPACE 159) (FIGSPACE 154))
)
)
(* ;; "FROM TEDITWINDOW")
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(DATATYPE TEDITCARET (TCNOWTIME (* Used to hold the current time, when checking to see if a transition is due) TCTHENTIME (* Time when the next transition is to take place) TCFORCEDDOWN (* TCFORCEDOWN = T means (Make the caret visible at the next call to \EDIT.FLIPCARET.)) TCUP (* TCUP = T => The caret is NOT VISIBLE. Used to track the current state of the caret) TCCARETDS (* The display stream that the caret appears in) TCCURSORBM (* The CURSOR representing the caret) TCCARETRATE (* %# of MSEC between caret up/down transitions) TCFORCEUP (* T => The caret is not allowed to become visible. Used to keep the caret up during screen updates) TCCARETX (* X position in the window that the caret appears at) TCCARETY (* Y position in the window where the caret appears) TCCARET (* A lisp CARET to be flashed (eventually)))
TCNOWTIME _ (CREATECELL \FIXP) TCTHENTIME _ (CREATECELL \FIXP) TCCURSORBM _ BXCARET TCCARETRATE _ \CARETRATE
TCUP _ T TCCARET _ (\CARET.CREATE BXCARET))
)
(/DECLAREDATATYPE (QUOTE TEDITCARET) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TEDITCARET 0 POINTER) (TEDITCARET 2 POINTER) (TEDITCARET 4 POINTER) (TEDITCARET 6 POINTER) (TEDITCARET 8 POINTER) (TEDITCARET 10 POINTER) (TEDITCARET 12 POINTER) (TEDITCARET 14 POINTER) (TEDITCARET 16 POINTER) (TEDITCARET 18 POINTER) (TEDITCARET 20 POINTER))) (QUOTE 22))
)
(/DECLAREDATATYPE (QUOTE TEDITCARET) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TEDITCARET 0 POINTER) (TEDITCARET 2 POINTER) (TEDITCARET 4 POINTER) (TEDITCARET 6 POINTER) (TEDITCARET 8 POINTER) (TEDITCARET 10 POINTER) (TEDITCARET 12 POINTER) (TEDITCARET 14 POINTER) (TEDITCARET 16 POINTER) (TEDITCARET 18 POINTER) (TEDITCARET 20 POINTER))) (QUOTE 22))
(* ;; "FROM PCTREE added by Nakamura")
(DECLARE%: EVAL@COMPILE
(DATATYPE PCTNODE (CHNUM (* ; "Character #of piece in this node.") PCE (* ; "PIECE ") LO (* ; "Subtree these nodes' ch#are less than this node.") HI (* ; " Subtree these nodes' ch#are more than this node.") BF (* ; "Balance factor.") (* ; "1: Right(HI) Subtree is higher than left(lo) subtree.") (* ; "0: Right subtree and left subtree are same height") (* ; "-1: Right(HI) Subtree is shorter than left(lo) subtree.") RANK (* ; "(# of nodes in left subtree) +1"))
CHNUM _ 0 BF _ 0 RANK _ 1)
)
(/DECLAREDATATYPE (QUOTE PCTNODE) (QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((PCTNODE 0 POINTER) (PCTNODE 2 POINTER) (PCTNODE 4 POINTER) (PCTNODE 6 POINTER) (PCTNODE 8 POINTER) (PCTNODE 10 POINTER))) (QUOTE 12))
(* ;;; "THE END")
(* ;;
"Bits in the CHARTABLE that control line breaking, and what happens when a line is broken on this character "
)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ NOTBEFORE.LB 1)
(RPAQQ NOTAFTER.LB 2)
(RPAQQ BEFORE.LB 4)
(RPAQQ AFTER.LB 8)
(RPAQQ DISAPPEAR-IF-NOT-SPLIT.LB 16)
(RPAQQ NEWCHAR-IF-SPLIT.LB 32)
(CONSTANTS (NOTBEFORE.LB 1) (NOTAFTER.LB 2) (BEFORE.LB 4) (AFTER.LB 8) (DISAPPEAR-IF-NOT-SPLIT.LB 16) (NEWCHAR-IF-SPLIT.LB 32))
)
)
(PUTPROPS TEDITDCL COPYRIGHT ("Venue" 1986 1987 1988 1989 1990 1991 1993 1994))
(DECLARE%: DONTCOPY
(FILEMAP (NIL)))
STOP

1636
library/TEDITFILE Normal file
View File

File diff suppressed because one or more lines are too long

493
library/TEDITFIND Normal file
View File

@@ -0,0 +1,493 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 6-May-2018 17:34:44" 
{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITFIND.;2 40100
changes to%: (FNS TEDIT.FIND)
previous date%: "25-Aug-94 10:53:52"
{DSK}<Users>kaplan>Local>medley3.5>lispcore>library>TEDITFIND.;1)
(* ; "
Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1991, 1994, 2018 by Venue & Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT TEDITFINDCOMS)
(RPAQQ TEDITFINDCOMS
((FILES TEDITDCL)
(DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (\SCRATCHLEN 64))
(FILES (LOADCOMP)
TEDITDCL))
[DECLARE%: DONTEVAL@LOAD DOCOPY (VARS (TEDIT.SEARCH.CODETABLE (\TEDIT.SEARCH.CODETABLE]
(COMS (* Read-table Utilities)
(FNS \TEDIT.SEARCH.CODETABLE)
(GLOBALVARS TEDIT.SEARCH.CODETABLE))
(FNS \TEDIT.BASICFIND TEDIT.FIND TEDIT.NEW.FIND TEDIT.NEXT \TEDIT.FIND.WC \TEDIT.FIND.WC1
\TEDIT.PACK.TARGETLIST \TEDIT.PARSE.SEARCHSTRING \TEDIT.SUBST.FN1 \TEDIT.SUBST.FN2
TEDIT.SUBSTITUTE)))
(FILESLOAD TEDITDCL)
(DECLARE%: EVAL@COMPILE DONTCOPY
(DECLARE%: EVAL@COMPILE
(RPAQQ \SCRATCHLEN 64)
(CONSTANTS (\SCRATCHLEN 64))
)
(FILESLOAD (LOADCOMP)
TEDITDCL)
)
(DECLARE%: DONTEVAL@LOAD DOCOPY
(RPAQ TEDIT.SEARCH.CODETABLE (\TEDIT.SEARCH.CODETABLE))
)
(* Read-table Utilities)
(DEFINEQ
(\TEDIT.SEARCH.CODETABLE
(LAMBDA NIL (* jds "23-OCT-83 00:58")
(* Build the 16-bit-item "syntax class"
 table for searching)
(PROG ((CODETBL (ARRAY 256 'SMALLP 0 0)))
(for I from 0 to 255 do (SETA CODETBL I I))
(* Default is that a char maps to itself, and is punctuation.)
(for CH
in (CHARCODE (A B C D E F G H I J K L M N O P Q R S T U V W X Y Z a b c d e f g h i j k
l m n o p q r s t u v w x y z))
do (SETA CODETBL CH (IPLUS \AlphaNumericFlag \AlphaFlag CH)))
(for CH in (CHARCODE (0 1 2 3 4 5 6 7 8 9)) do (SETA CODETBL CH (IPLUS \AlphaNumericFlag CH
)))
(for CH in (CHARCODE (%# * @ ! & ~ { })) as CODE
in (LIST \OneCharPattern \AnyStringPattern \OneAlphaPattern \OneNonAlphaPattern
\AnyAlphaPattern \AnyNonAlphaPattern \LeftBracketPattern \RightBracketPattern)
do (SETA CODETBL CH CODE))
(RETURN CODETBL))))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS TEDIT.SEARCH.CODETABLE)
)
(DEFINEQ
(\TEDIT.BASICFIND
[LAMBDA (TEXTOBJ STRING CH# CHLIM) (* ; "Edited 30-May-91 20:56 by jds")
(* ;; "Search thru TEXTOBJ, starting where the caret is, for the string STRING, exact match only for now. (Optionally, start the search at character ch#.)")
(PROG ((SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
[TEXTLIM (OR CHLIM (ADD1 (IDIFFERENCE (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ)
(NCHARS STRING]
(TEXTSTREAM (fetch (TEXTOBJ STREAMHINT) of TEXTOBJ))
(FOUND NIL)
(CH#1 (NTHCHARCODE STRING 1))
CH1 ANCHOR PCH# OANCHOR CH)
(replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
(* ;
 "2/12/85 JDS: I don't understand WHY this is here, but I'll assume it's right for now.")
(* ;
 "Prohibit future insertions in the current piece.")
(COND
((OR CH# (fetch (SELECTION SET) of SEL))(* ;
 "There must be a well-defined starting point.")
(RETURN (PROG NIL
(SETQ CH1 (OR CH# (SELECTQ (fetch (SELECTION POINT) of SEL)
(LEFT (fetch (SELECTION CH#) of SEL))
(RIGHT (fetch (SELECTION CHLIM) of SEL))
NIL))) (* ;
 "Find the starting point for the search")
(* ; "DO THE SEARCH")
(COND
((IGREATERP CH1 TEXTLIM) (* ;
 "Starting the search past the last possible starting point. Just punt.")
(RETURN NIL)))
(SETQ ANCHOR (SUB1 CH1))
RETRY
(\SETUPGETCH (ADD1 ANCHOR)
TEXTOBJ)
[for old ANCHOR from (ADD1 ANCHOR) to TEXTLIM
do (SETQ CH (\BIN TEXTSTREAM))
(COND
((EQ CH CH#1)
(RETURN]
(COND
((IGREATERP ANCHOR TEXTLIM)
(RETURN NIL))) (* ;
 "No starting character found before end of string")
(SETQ OANCHOR ANCHOR)
(SETQ FOUND T)
[for old CH1 from (ADD1 ANCHOR) to TEXTLIM as PCH#
from 2 to (NCHARS STRING)
do (SETQ CH (\BIN TEXTSTREAM))
(COND
((NEQ CH (NTHCHARCODE STRING PCH#))
(SETQ FOUND NIL)
(RETURN]
(COND
(FOUND (RETURN ANCHOR))
(T (GO RETRY])
(TEDIT.FIND
[LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* ; "Edited 6-May-2018 17:34 by rmk:")
(* ; "Edited 30-May-91 20:56 by jds")
(* ;; "If WILDCARDS? is NIL then TEDIT.FIND is the old TEDIT.FIND. Else, it returns a list of (SEL.START# SEL.END#) which is the start and end char positions of the selection")
(LET*
[(TEXTOBJ (TEXTOBJ TEXTOBJ))
(TEDIT.WILDCARD.CHARACTERS '("#" "*"))
(REAL-END# (OR END# (fetch (TEXTOBJ TEXTLEN) of TEXTOBJ]
(AND TARGETSTRING (NOT (STRINGP TARGETSTRING))
(SETQ TARGETSTRING (MKSTRING TARGETSTRING)))
(* ;; "RMK: FIND isn't undoable, FIND-AGAIN is armed on meta-g. No point in hiding a previous actual edit by adding the find event (given that the history is not a list, just a single event (TEDITHISTORY)")
(AND NIL (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT
THACTION _ 'Find
THAUXINFO _ TARGETSTRING)))
(replace (TEXTOBJ \INSERTPCVALID) of TEXTOBJ with NIL)
(* ;
 "Any FIND invalidates the type-in cache.")
(COND
[WILDCARDS? (* ;
 "will return a list of start and end of selection or nil if not found")
(PROG (TARGETLIST SEL RESULT RESULT1)
(RETURN (COND
((OR START# (AND (fetch (SELECTION SET) of (SETQ SEL
(fetch (TEXTOBJ
SEL)
of TEXTOBJ)))
(LEQ (SETQ START# (SELECTQ (fetch (SELECTION POINT)
of SEL)
(LEFT (fetch (SELECTION CH#)
of SEL))
(RIGHT (fetch (SELECTION CHLIM)
of SEL))
NIL))
REAL-END#))) (* ; "START# better be >= to END#")
(COND
((AND (for X in [SETQ TARGETLIST
(\TEDIT.PARSE.SEARCHSTRING
(for X in (CHCON TARGETSTRING)
collect (MKSTRING (CHARACTER X]
collect X when (LITATOM X))
(SETQ RESULT1 (\TEDIT.SUBST.FN1 TEXTOBJ TARGETLIST START#
REAL-END#)))
(* ;
 "If there are atoms, they are tedit wildcard chars")
(\TEDIT.FIND.WC TEXTOBJ TARGETLIST RESULT1 REAL-END#))
(T (* ; "no wildcards but bounded search")
(COND
((SETQ RESULT (TEDIT.FIND TEXTOBJ (CAR TARGETLIST)
START# REAL-END# NIL))
(LIST RESULT (SUB1 (IPLUS RESULT (NCHARS (CAR TARGETLIST]
(T (* ;
 "will return just the number of the start char or nil if not found")
(LET ((RESULT (\TEDIT.BASICFIND TEXTOBJ TARGETSTRING START# REAL-END#)))
(COND
((NULL REAL-END#)
RESULT)
((OR (NULL RESULT)
(GREATERP (IPLUS RESULT (SUB1 (NCHARS TARGETSTRING)))
REAL-END#))
NIL)
(T RESULT])
(TEDIT.NEW.FIND
[LAMBDA (TEXTOBJ TARGETSTRING START# END# WILDCARDS?) (* ; "Edited 23-Feb-88 11:13 by jds")
(* ;; "If WILDCARDS? is NIL then TEDIT.NEW.FIND is the old TEDIT.FIND. Else, it returns a list of (SEL.START# SEL.END#) which is the start and end char positions of the selection")
(* ;; "(PROG ((TEXTSTREAM (fetch STREAMHINT of TEXTOBJ)) PATTERN FIRSTPAT PATTERNSTACK POSNSTACK FIRSTCHAR1 FIRSTCHAR2 FIRSTPATNORMAL PATTERNLEN FOUND PATTERNPOS TEXTPOS) (AND TARGETSTRING (NOT (STRINGP TARGETSTRING)) (SETQ TARGETSTRING (MKSTRING TARGETSTRING))) (SETQ PATTERN (\TEDIT.NEW.PARSE.SEARCHSTRING TARGETSTRING)) (OR PATTERN (RETURN)) (SETQ PATTERNLEN (FLENGTH PATTERN)) (\TEDIT.HISTORYADD TEXTOBJ (create TEDITHISTORYEVENT THACTION _ (QUOTE Find) THAUXINFO _ TARGETSTRING)) (COND ((ZEROP (LOGAND \SpecialPattern (SETQ FIRSTPAT (CAR PATTERN)))) (* The pattern starts with an easy first character) (SETQ FIRSTPATNORMAL T) (SETQ FIRSTCHAR1 (LOGAND \CHARMASK FIRSTPAT)) (COND ((ZEROP (LOGAND \AlphaFlag FIRSTPAT)) (* Not alphabetic) (SETQ FIRSTCHAR2 FIRSTCHAR1)) (T (* Is alphabetic) (SETQ FIRSTCHAR2 (LOGAND FIRSTCHAR1 223)))))) (bind (CH# _ START#) while (ILEQ CH# END#) first (\SETUPGETCH START# TEXTOBJ) do (COND (FIRSTPATNORMAL (* The pattern starts with an easy first character) (COND ((AND (NEQ (SETQ CH (\BIN TEXTSTREAM)) FIRSTCHAR1) (NEW CH FIRSTCHAR2)) (GO $$ITERATE))) (SETQ PATTERNPOS 1) (SETQ CH (\BIN TEXTSTREAM))) (T (SETQ PATTERNPOS 0))) (SETQ TEXTPOS (\TEXTMARK TEXTOBJ)) (COND ((IGEQ PATTERNPOS PATTERNLEN) (SETQ FOUND T) (RETURN)))))")
(HELP])
(TEDIT.NEXT
[LAMBDA (STREAM) (* ; "Edited 30-May-91 20:57 by jds")
(PROG ((TEXTOBJ (TEXTOBJ STREAM))
TARGET SEL OPTION FIELDSEL)
(SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))
(SETQ TARGET (TEDIT.FIND TEXTOBJ ">>*<<" NIL NIL T))
(* find the first >>delimited<<
 field)
(SETQ FIELDSEL (MBUTTON.FIND.NEXT.FIELD TEXTOBJ (fetch (SELECTION CH#) of SEL)))
(* find the first menu-type
 insertion field, usually delimited
 with {})
[SETQ OPTION (COND
[(AND TARGET FIELDSEL) (* take the first one)
(COND
((IGREATERP (CAR TARGET)
(fetch (SELECTION CH#) of FIELDSEL))
(* use the {} selection)
'FIELD)
(T 'TARGET]
(TARGET 'TARGET)
(FIELDSEL 'FIELD)
(T 'NEITHER]
(SELECTQ OPTION
(TARGET (* Found another fill-in)
(\SHOWSEL SEL NIL NIL)
(replace (SELECTION CH#) of SEL with (CAR TARGET))
(* Set up SELECTION to be the found
 text)
(replace (SELECTION CHLIM) of SEL with (ADD1 (CADR TARGET)))
(replace (SELECTION DCH) of SEL with (IDIFFERENCE
(ADD1 (CADR TARGET))
(CAR TARGET)))
(replace (SELECTION POINT) of SEL with 'RIGHT)
(\TEDIT.SET.SEL.LOOKS SEL 'PENDINGDEL) (* Always selected normally)
(replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ with T)
(* And never pending a deletion.)
(\FIXSEL SEL TEXTOBJ)
(TEDIT.NORMALIZECARET TEXTOBJ)
(\SHOWSEL SEL NIL T) (* And get it into the window)
)
(FIELD (* Replace the selection for this
 textobj with the scratch sel
 returned from
 MBUTTON.FIND.NEXT.FIELD)
(\SHOWSEL SEL NIL NIL)
(replace (SELECTION CH#) of SEL with (fetch (SELECTION CH#)
of FIELDSEL))
(* Set up SELECTION to be the found
 text)
(replace (SELECTION CHLIM) of SEL with (fetch (SELECTION CHLIM)
of FIELDSEL))
(replace (SELECTION DCH) of SEL with (fetch (SELECTION DCH)
of FIELDSEL))
(replace (SELECTION POINT) of SEL with 'LEFT)
(\TEDIT.SET.SEL.LOOKS SEL 'PENDINGDEL)
(replace (TEXTOBJ BLUEPENDINGDELETE) of TEXTOBJ with T)
(\FIXSEL SEL TEXTOBJ)
(TEDIT.NORMALIZECARET TEXTOBJ)
(\SHOWSEL SEL NIL T) (* And get it into the window)
)
(NEITHER (TEDIT.PROMPTPRINT TEXTOBJ "No more blanks to fill in." T)
(SETQ SEL NIL))
(SHOULDNT "No legal value found in selectq in TEDIT.NEXT"))
(COND
(SEL
(* There really IS a selection made here, so set up the charlooks for it
 properly.)
(replace (TEXTOBJ CARETLOOKS) of TEXTOBJ with (
\TEDIT.GET.INSERT.CHARLOOKS
TEXTOBJ SEL])
(\TEDIT.FIND.WC
[LAMBDA (TEXTOBJ TARGETLIST START# END#) (* ; "Edited 9-Dec-88 09:56 by jds")
(* ;
 "\TEDIT.FIND.WC returns the end char # of the TARGETLIST which may contain wildcards")
(PROG (RESULT RESULT1)
(RETURN (COND
((SETQ RESULT (\TEDIT.FIND.WC1 TEXTOBJ TARGETLIST START# END#))
(* ;; "SUB1 because NEWFIND.WC2 takes that arg as the Lastchar of the selection so far and so will start on the next char after this")
(* ; "DONE!")
(LIST START# (IMAX START# RESULT)))
(T (AND (SETQ RESULT1 (\TEDIT.SUBST.FN1 TEXTOBJ TARGETLIST (ADD1 START#)
END#))
(\TEDIT.FIND.WC TEXTOBJ TARGETLIST RESULT1 END#])
(\TEDIT.FIND.WC1
[LAMBDA (TEXTOBJ TARGETLIST TRIALEND# END#) (* ; "Edited 9-Dec-88 09:52 by jds")
(* ;
 "TRIALEND# is where the next char string should go")
(* ;
 "\TEDIT.FIND.WC1 should return the lastchar# of selection")
(PROG (RESULT RESULT1)
(RETURN (COND
((NULL TARGETLIST) (* ; "DONE!")
(SUB1 TRIALEND#))
[(STRINGP (CAR TARGETLIST))
(COND
((SETQ RESULT (TEDIT.FIND TEXTOBJ (CAR TARGETLIST)
TRIALEND# END# NIL))
(* ; "NOT null")
(\TEDIT.FIND.WC1 TEXTOBJ (CDR TARGETLIST)
(IPLUS RESULT (NCHARS (CAR TARGETLIST)))
END#]
((LITATOM (CAR TARGETLIST))
(COND
[(MEMBER (CAR TARGETLIST)
'(%#)) (* ; "fixed width wildcard")
(COND
((OR (NULL (CDR TARGETLIST))
(EQUAL (CAR (TEDIT.FIND TEXTOBJ (CONCATLIST (
 \TEDIT.PACK.TARGETLIST
(CDR TARGETLIST)))
(ADD1 TRIALEND#)
END# T))
(ADD1 TRIALEND#))) (* ;
 "If the next start after a fixed char is the char after it, OK. else return nil")
(\TEDIT.FIND.WC1 TEXTOBJ (CDR TARGETLIST)
(ADD1 TRIALEND#)
END#]
(T (* ; "variable width wildcard")
(COND
((CDR TARGETLIST)
(SETQ RESULT1 (TEDIT.FIND TEXTOBJ (CONCATLIST (
 \TEDIT.PACK.TARGETLIST
(CDR TARGETLIST)))
TRIALEND# END# T))
(AND RESULT1 (CADR RESULT1)))
(T (* ; "last element of search")
(SUB1 TRIALEND#])
(\TEDIT.PACK.TARGETLIST
[LAMBDA (TARGETLIST) (* ; "Edited 24-Sep-87 09:54 by jds")
(COND
((NULL TARGETLIST)
NIL)
[(MEMBER (CAR TARGETLIST)
'("#" "*"))
(CONS (CONCAT (CAR TARGETLIST)
(CAR TARGETLIST))
(\TEDIT.PACK.TARGETLIST (CDR TARGETLIST]
[(STRINGP (CAR TARGETLIST))
(CONS (CAR TARGETLIST)
(\TEDIT.PACK.TARGETLIST (CDR TARGETLIST]
(T (* ; "wildcard")
(CONS (MKSTRING (CAR TARGETLIST))
(\TEDIT.PACK.TARGETLIST (CDR TARGETLIST])
(\TEDIT.PARSE.SEARCHSTRING
(LAMBDA (LST RESULT) (* jds "31-Jan-84 13:26")
(PROG ((TEDIT.WILDCARD.CHARACTERS '("#" "*")))
(RETURN (COND
((NULL LST)
(COND
(RESULT (LIST RESULT))))
((MEMBER (CAR LST)
TEDIT.WILDCARD.CHARACTERS)
(COND
((NULL RESULT)
(CONS (MKATOM (CAR LST))
(\TEDIT.PARSE.SEARCHSTRING (CDR LST))))
(T (APPEND (LIST RESULT (MKATOM (CAR LST)))
(\TEDIT.PARSE.SEARCHSTRING (CDR LST))))))
((AND (EQUAL (CAR LST)
"'")
(LISTP (CDR LST))
(MEMBER (CADR LST)
TEDIT.WILDCARD.CHARACTERS))(* quoting something a wildcard char)
(\TEDIT.PARSE.SEARCHSTRING (CDDR LST)
(COND
((NULL RESULT)
(MKSTRING (CADR LST)))
(T (CONCAT RESULT (MKSTRING (CADR LST)))))))
(T (\TEDIT.PARSE.SEARCHSTRING (CDR LST)
(COND
((NULL RESULT)
(CAR LST))
(T (CONCAT RESULT (CAR LST)))))))))))
(\TEDIT.SUBST.FN1
[LAMBDA (TEXTOBJ TARGETLIST START# END#) (* ; "Edited 3-Sep-87 11:38 by jds")
(* ;
 "returns the char location that would match the beginning element of a targetlist")
(PROG (RESULT)
(SETQ RESULT (\TEDIT.SUBST.FN2 TEXTOBJ TARGETLIST START# END#))
(RETURN (AND RESULT (IGEQ RESULT START#)
RESULT])
(\TEDIT.SUBST.FN2
[LAMBDA (TEXTOBJ TARGETLIST TRIALSTART# END#) (* ; "Edited 9-Dec-88 09:54 by jds")
(* ;;
 "will return the start char of a wildcarded selection. returns NIL if selection is beyond bounds")
(* ;; "TARGETLIST is (what)?")
(LET (SUB-FIND-RESULT)
(COND
((NULL TARGETLIST)
TRIALSTART#)
((IGREATERP TRIALSTART# END#)
NIL)
[(LITATOM (CAR TARGETLIST))
(COND
((EQ (CAR TARGETLIST)
'%#) (* ; "fixed width wildcard")
(AND (SETQ SUB-FIND-RESULT (\TEDIT.SUBST.FN1 TEXTOBJ (CDR TARGETLIST)
(ADD1 TRIALSTART#)
END#))
(SUB1 SUB-FIND-RESULT)))
(T (* ;
 "variable width wildcard, so forget them")
(\TEDIT.SUBST.FN2 TEXTOBJ (CDR TARGETLIST)
TRIALSTART# END#]
(T (* ; "it's a string")
(TEDIT.FIND TEXTOBJ (CAR TARGETLIST)
TRIALSTART# END# NIL])
(TEDIT.SUBSTITUTE
[LAMBDA (TEXTSTREAM PATTERN REPLACEMENT CONFIRM?) (* ; "Edited 30-Mar-94 16:04 by jds")
(* ;; "Replace all instances of PATTERN with REPLACEMENT. If CONFIRM? is non-NIL, ask before each replacement.")
(PROG ((TEXTOBJ (TEXTOBJ TEXTSTREAM))
(REPLACEDFLG 0)
(YESLIST '("Y" "y" "yes" "YES" "T" "Yes"))
SEARCHSTRING REPLACESTRING ABORTFLG OUTOFRANGEFLG BEGINCHAR# ENDCHAR# STARTCHAR# RANGE
CONFIRMFLG SEL PC# SELCH# SELCHLIM SELPOINT CRSEEN REPLACE-LEN)
(COND
([NULL (SETQ SEARCHSTRING (OR PATTERN (TEDIT.GETINPUT TEXTOBJ "Search string:"
(TEXTPROP TEXTOBJ
'TEDIT.LAST.SUBSTITUTE.STRING)
(CHARCODE (EOL LF ESC]
(* ;
 "If the search pattern is empty, bail out.")
(TEDIT.PROMPTPRINT TEXTOBJ "[Aborted]")
(RETURN)))
[SETQ REPLACESTRING (OR REPLACEMENT (TEDIT.GETINPUT TEXTOBJ "Replace string:"
(TEXTPROP TEXTOBJ
'TEDIT.LAST.REPLACEMENT.STRING)
(CHARCODE (EOL LF ESC]
[COND
((STRINGP REPLACESTRING)
(SETQ REPLACE-LEN (NCHARS REPLACESTRING)))
((LISTP REPLACESTRING) (* ;
 "It's a list of pieces, meaning insert these pieces as the replacement.")
(SETQ REPLACE-LEN (for PC in REPLACESTRING sum (fetch (PIECE PLEN)
of PC]
(SETQ CRSEEN (AND REPLACESTRING (STRINGP REPLACESTRING)
(STRPOS (CHARACTER (CHARCODE CR))
REPLACESTRING)))
[COND
(PATTERN (* ;
 "If a pattern is specd in the call, use the caller's confirm flag.")
(SETQ CONFIRMFLG CONFIRM?))
(T (* ; "Otherwise, ask for one.")
(SETQ CONFIRMFLG (MEMBER (TEDIT.GETINPUT TEXTOBJ "Ask before each replace?" "No"
(CHARCODE (EOL SPACE ESCAPE LF TAB)))
YESLIST]
(TEDIT.PROMPTPRINT TEXTOBJ "Substituting..." T)
(SETQ SEL (fetch (TEXTOBJ SEL) of TEXTOBJ))(* ;
 "STARTCHAR# and ENDCHAR# are the bound of the search")
(\SHOWSEL SEL NIL NIL)
(TEDIT.RESET.EXTEND.PENDING.DELETE SEL) (* ;
 "Turn off any blue pending delete")
(SETQ BEGINCHAR# (SETQ STARTCHAR# (fetch (SELECTION CH#) of SEL)))
[SETQ ENDCHAR# (IPLUS STARTCHAR# (SUB1 (fetch (SELECTION DCH) of SEL]
(while (AND (SETQ RANGE (TEDIT.FIND TEXTOBJ SEARCHSTRING STARTCHAR# ENDCHAR# T))
(NOT ABORTFLG))
do [PROG (PENDING.SEL CHOICE)
(COND
[CONFIRMFLG (SETQ PENDING.SEL (TEDIT.SETSEL TEXTSTREAM (CAR RANGE)
(IDIFFERENCE (CADR RANGE)
(SUB1 (CAR RANGE)))

1
library/TEDITFNKEYS Normal file
View File

File diff suppressed because one or more lines are too long

1569
library/TEDITHCPY Normal file
View File

File diff suppressed because it is too large Load Diff

1
library/TEDITHISTORY Normal file
View File

File diff suppressed because one or more lines are too long

2014
library/TEDITLOOKS Normal file
View File

File diff suppressed because one or more lines are too long

4539
library/TEDITMENU Normal file
View File

File diff suppressed because it is too large Load Diff

1839
library/TEDITPAGE Normal file
View File

File diff suppressed because it is too large Load Diff

2961
library/TEDITSCREEN Normal file
View File

File diff suppressed because one or more lines are too long

2277
library/TEDITSELECTION Normal file
View File

File diff suppressed because it is too large Load Diff

2398
library/TEDITWINDOW Normal file
View File

File diff suppressed because one or more lines are too long

1
library/TELERAID Normal file
View File

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

1
library/TEXEC Normal file
View File

File diff suppressed because one or more lines are too long

1
library/TEXTMODULES Normal file
View File

File diff suppressed because one or more lines are too long

1623
library/TEXTOFD Normal file
View File

File diff suppressed because one or more lines are too long

1
library/TEXTOFD.DATABASE Normal file
View File

File diff suppressed because one or more lines are too long

1
library/TFBRAVO Normal file
View File

File diff suppressed because one or more lines are too long

Some files were not shown because too many files have changed in this diff Show More