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

Eliminate implicit calls to \FILEOUTCHARFN (#529)

Browse Source 
* Eliminate implicit calls to \FILEOUTCHARFN

Also, update DATE to modern readtable (don't know what it does), add LLETHER to EXPORTFILES in FILESETS (may also need the file that exports pup records).

* Further fixups for EXPORTFILES

also fixing/compiling PLAINTEXTSTREAM

* Remove garbage files DATE and PLAINTEXTSTREAM from checkin

Co-authored-by: Larry Masinter <LMM@acm.org>
This commit is contained in:
rmkaplan
2021-10-21 16:25:16 -07:00
committed by GitHub
parent 9b4976e33f
commit c3b5e23cd9
18 changed files with 53 additions and 873 deletions
Download Patch File Download Diff File Expand all files Collapse all files

531
lispusers/DATE
View File

@@ -1,531 +0,0 @@
(FILECREATED "18-Feb-87 15:42:27" {SUMEX-AIM}PS:<TMAX.SOURCES>DATE.;4 19668
previous date: "17-Feb-87 14:29:37" {SUMEX-AIM}<GILMURRAY.LISP>DATE.;7)
(* Copyright (c) 1987 by Leland Stanford Junior University. All rights reserved.)
(PRETTYCOMPRINT DATECOMS)
(RPAQQ DATECOMS ((* Developed under support from NIH grant RR-00785.)
(* Written by Frank Gilmurray and Sami Shaio.)
(FNS DATEOBJ DATEOBJP DATE.DISPLAYFN DATE.IMAGEBOXFN CURRENT.DISPLAY.FONT DATE.PUTFN
DATE.GETFN DATE.BUTTONEVENTINFN DATES.TEMPLATE AMPM DATES.MENU.APPLY
DATES.MENU.WHENSELECTEDFN DATES.SET FINDDAY FINDHOUR FINDMONTH FINDTIME FINDYEAR NUMP
WHICHDATE)
(RECORDS DATEOBJ STREAM FONTCLASS)))
(* Developed under support from NIH grant RR-00785.)
(* Written by Frank Gilmurray and Sami Shaio.)
(DEFINEQ
(DATEOBJ
(LAMBDA (TEMPLATE) (* fsg "23-Jul-86 09:53")
(* Create an instance of a date imageobj.
A dateobj is also defined as a record with a 
datestring field. *)
(LET* ((TEMPLATE.TYPE (OR TEMPLATE '(M D Y F)))
(DATEANDTIME (MKSTRING (DATE)))
(DISPLAYDATE (MKSTRING (DATES.TEMPLATE DATEANDTIME TEMPLATE.TYPE)))
(NEWOBJ (IMAGEOBJCREATE (create DATEOBJ
DATESTRING _ DATEANDTIME
DISPLAY.DATE _ DISPLAYDATE
TEMPLATE.DATE _ TEMPLATE.TYPE)
(IMAGEFNSCREATE (FUNCTION DATE.DISPLAYFN)
(FUNCTION DATE.IMAGEBOXFN)
(FUNCTION DATE.PUTFN)
(FUNCTION DATE.GETFN)
(FUNCTION NILL)
(FUNCTION DATE.BUTTONEVENTINFN)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)
(FUNCTION NILL)))))
(* By convention, every image object will have a type 
property associated with it that will facilitate 
imageobj mapping in a TEdit file.)
(IMAGEOBJPROP NEWOBJ 'TYPE
'DATEOBJ)
NEWOBJ)))
(DATEOBJP
(LAMBDA (IMOBJ) (* ss: "24-Jun-85 16:33")
(* Tests an imageobj to see if it is a date imageobject. By convention, testing functions for an imageobject will 
be named (CONCAT <type of imageobj> "P"))
(AND IMOBJ (EQ (IMAGEOBJPROP IMOBJ 'TYPE)
'DATEOBJ))))
(DATE.DISPLAYFN
(LAMBDA (OBJ STREAM STREAMTYPE HOSTSTREAM) (* fsg "17-Feb-87 09:28")
(* * Display function for date imageobjs.)
(PRIN1 (fetch DISPLAY.DATE of (fetch OBJECTDATUM of OBJ))
STREAM)))
(DATE.IMAGEBOXFN
(LAMBDA (OBJ STREAM CURRENTX RIGHTMARGIN) (* fsg "15-Feb-87 14:05")
(* * Return the ImageBox for the date string. The size is determined by the stream's current font.)
(DSPFONT (CURRENT.DISPLAY.FONT STREAM)
STREAM)
(create IMAGEBOX
XSIZE _(STRINGWIDTH (fetch DISPLAY.DATE of (fetch OBJECTDATUM of OBJ))
STREAM)
YSIZE _(FONTPROP STREAM 'HEIGHT)
YDESC _(FONTPROP STREAM 'DESCENT)
XKERN _ 0)))
(CURRENT.DISPLAY.FONT
(LAMBDA (STREAM) (* fsg "17-Feb-87 10:19")
(* * Return the current font. This function is here instead of TMAX because the DATE code is also used in the 
LetterHead code.)
(LET ((CURRENT.FONT (fetch CLFONT of (with TEXTSTREAM
(TEXTSTREAM (CAR (fetch \WINDOW
of TEXTOBJ)))
CURRENTLOOKS))))
(COND
((TYPENAMEP CURRENT.FONT 'FONTDESCRIPTOR)
CURRENT.FONT)
((TYPENAMEP CURRENT.FONT 'FONTCLASS)
(fetch DISPLAYFD of CURRENT.FONT))
(T (SHOULDNT "Can't get current font"))))))
(DATE.PUTFN
(LAMBDA (DATEOBJ STREAM) (* fsg " 4-Feb-87 09:40")
(PRIN2 (LIST 'Date
(fetch (DATEOBJ TEMPLATE.DATE) of (fetch OBJECTDATUM of DATEOBJ)))
STREAM)))
(DATE.GETFN
(LAMBDA (STREAM) (* fsg " 4-Feb-87 09:42")
(OR (WINDOWPROP (PROCESSPROP (THIS.PROCESS)
'WINDOW)
'IMAGEOBJ.MENUW)
(AND (FGETD 'TSP.FMMENU)
(TSP.FMMENU (TEXTSTREAM (PROCESSPROP (THIS.PROCESS)
'WINDOW)))))
(APPLY 'DATEOBJ
(CDR (READ STREAM)))))
(DATE.BUTTONEVENTINFN
(LAMBDA (DATEOBJ WINDOWSTREAM SELECTION RELX RELY WINDOW HOSTSTREAM BUTTON)
(* fsg "26-Jan-87 10:06")
(AND (MOUSESTATE MIDDLE)
(LET ((DATE.MENU (create MENU
TITLE _ "Date Menu"
ITEMS _ '((Month% Day,% Year (DATES.TEMPLATE DATE
'(M D Y F))
"Insert current date as %"March 8, 1952%"")
(Month/Day/Year (DATES.TEMPLATE DATE '(M D Y A))
"Insert current date as %"3/8/52%"")
(Day% Month,% Year (DATES.TEMPLATE DATE
'(D M Y F))
"Insert current date as %"8 March, 1952%"")
(Day/Month/Year (DATES.TEMPLATE DATE '(D M Y A))
"Insert current date as %"8/3/52%"")
(Time (DATES.TEMPLATE DATE '(T F))
"Insert current time as %"four thirty p.m.%"")
(Numbered% Time (DATES.TEMPLATE DATE '(T A))
"Insert current time as %"4:30 p.m.%"")
(Military% Time (DATES.TEMPLATE DATE '(T E))
"Insert current time as %"16:30%""))
WHENSELECTEDFN _(FUNCTION DATES.MENU.WHENSELECTEDFN))))
(PUTMENUPROP DATE.MENU 'IMAGEOBJ
DATEOBJ)
(MENU DATE.MENU)
'CHANGED))))
(DATES.TEMPLATE
(LAMBDA (DATE TEMPLATE) (* fsg "24-Jul-86 14:43")
(* * comment)
(COND
(TEMPLATE (LET ((VERSION (if (EQUAL (LAST TEMPLATE)
'(A))
then 'ABBREV
else (if (EQUAL (LAST TEMPLATE)
'(F))
then 'FULL
else 'EURO)))
(FUNCLST '((D FINDDAY)
(M FINDMONTH)
(Y FINDYEAR))))
(COND
((EQ (CAR TEMPLATE)
T)
(FINDTIME DATE VERSION))
(T (LET ((CH (if (EQ VERSION 'ABBREV)
then "/"
else " ")))
(CONCAT (APPLY (CADR (ASSOC (CAR TEMPLATE)
FUNCLST))
(LIST DATE VERSION))
CH
(APPLY (CADR (ASSOC (CADR TEMPLATE)
FUNCLST))
(LIST DATE VERSION))
(if (EQUAL CH " ")
then ", "
else CH)
(APPLY (CADR (ASSOC (CADDR TEMPLATE)
FUNCLST))
(LIST DATE VERSION))))))))
(DATE))))
(AMPM
(LAMBDA (HOUR)
(if (OR (LESSP (MKATOM HOUR)
12)
(EQUAL (MKATOM HOUR)
24))
then "a.m."
else "p.m.")))
(DATES.MENU.APPLY
(LAMBDA (ITEM MENU) (* fsg "31-Jul-86 10:18")
(* This function serves the purpose of calculating the stream and the editing window from information stored on the
window containing the menu. It then applies the appropiate function for each ITEM in the menu*)
(SETQ ITEM (COND
((ATOM ITEM)
ITEM)
(T (CAR ITEM))))
(LET* ((DATE.RECORD (fetch OBJECTDATUM of (GETMENUPROP MENU 'IMAGEOBJ)))
(DATE (fetch DATESTRING of DATE.RECORD)))
(COND
((fetch ITEMS of MENU)
(LET ((FUNCALL (CADR (ASSOC ITEM (fetch ITEMS of MENU)))))
(replace DISPLAY.DATE of DATE.RECORD with (EVAL FUNCALL))
(replace TEMPLATE.DATE of DATE.RECORD with (CADAR (LAST FUNCALL)))))))))
(DATES.MENU.WHENSELECTEDFN
(LAMBDA (ITEM MENU MB) (* fsg "28-Jul-86 14:57")
(COND
((OR (EQ MB 'LEFT)
(EQ MB 'MIDDLE))
(DATES.MENU.APPLY ITEM MENU)))))
(DATES.SET
(LAMBDA (PROPERTY VALUE)
(WINDOWPROP (CREATEW)
PROPERTY VALUE)
VALUE))
(FINDDAY
(LAMBDA (OLDDATE VERSION) (* shw: " 1-Jul-85 11:28")
(MKATOM (if (NUMP (SUBSTRING OLDDATE 1 2))
then (SUBSTRING OLDDATE 1 2)
else (SUBSTRING OLDDATE 2 2)))))
(FINDHOUR
(LAMBDA (HOUR) (* ss: " 8-Feb-86 17:49")
(COND
((LESSP (MKATOM HOUR)
13)
(COND
((LESSP (MKATOM HOUR)
10)
(MKSTRING (CADR (UNPACK HOUR))))
(T HOUR)))
(T (MKSTRING (SELECTQ (MKATOM HOUR)
(13 1)
(14 2)
(15 3)
(16 4)
(17 5)
(18 6)
(19 7)
(20 8)
(21 9)
(22 10)
(23 11)
(24 12)
NIL))))))
(FINDMONTH
(LAMBDA (OLDDATE VERSION) (* shw: " 1-Jul-85 11:38")
(PROG ((DATES '((Jan 1 January)
(Feb 2 February)
(Mar 3 March)
(Apr 4 April)
(May 5 May)
(Jun 6 June)
(Jul 7 July)
(Aug 8 August)
(Sep 9 September)
(Oct 10 October)
(Nov 11 November)
(Dec 12 December)))
(OUTPUT NIL))
(if (EQ VERSION 'ABBREV)
then (SETQ OUTPUT (CAR (CDR (ASSOC (MKATOM (SUBSTRING OLDDATE 4 6))
DATES))))
else (SETQ OUTPUT (CAR (CDDR (ASSOC (MKATOM (SUBSTRING OLDDATE 4 6))
DATES)))))
(RETURN OUTPUT))))
(FINDTIME
(LAMBDA (OLDDATE VERSION) (* shw: "24-Jul-85 15:39")
(LET ((HOUR (SUBSTRING OLDDATE 11 12))
(MINUTES (SUBSTRING OLDDATE 14 15)))
(if (EQUAL VERSION 'ABBREV)
then (CONCAT (FINDHOUR HOUR)
":" MINUTES " " (AMPM HOUR))
else (if (EQUAL VERSION 'EURO)
then (SUBSTRING OLDDATE 11 15)
else (CONCAT (SELECTQ (if (LESSP (MKATOM MINUTES)
46)
then (MKATOM (FINDHOUR HOUR))
else (PLUS 1 (MKATOM (FINDHOUR HOUR))))
(1 "one")
(2 "two")
(3 "three")
(4 "four")
(5 "five")
(6 "six")
(7 "seven")
(8 "eight")
(9 "nine")
(10 "ten")
(11 "eleven")
(12 "twelve")
NIL)
" "
(if (AND (GREATERP (MKATOM MINUTES)
15)
(LESSP (MKATOM MINUTES)
45))
then "thirty"
else "o'clock")
" "
(if (AND (GREATERP (MKATOM MINUTES)
44)
(EQUAL (FINDHOUR HOUR)
"11"))
then (if (EQUAL (AMPM HOUR)
"a.m.")
then "p.m."
else "a.m.")
else (AMPM HOUR))))))))
(FINDYEAR
(LAMBDA (OLDDATE VERSION) (* shw: " 1-Jul-85 11:31")
(if (EQ VERSION 'ABBREV)
then (MKATOM (SUBSTRING OLDDATE 8 9))
else (MKATOM (CONCAT "19" (SUBSTRING OLDDATE 8 9))))))
(NUMP
(LAMBDA (N) (* edited: " 4-Apr-86 17:55")
(* changed)
(NOT (NULL (NUMBERP (MKATOM N))))))
(WHICHDATE
(LAMBDA (VAR1 VAR2 YEAR OLDDATE VERSION) (* edited " 1-Jan-00 00:00")
(* * comment)
(PROG (DIVIDER)
(SETQ DIVIDER (if (EQ VERSION 'ABBREV)
then "/"
else " "))
(RETURN (MKATOM (CONCAT (APPLY VAR1 (LIST OLDDATE VERSION))
DIVIDER
(APPLY VAR2 (LIST OLDDATE VERSION))
DIVIDER
(APPLY YEAR (LIST OLDDATE VERSION))))))))
)
[DECLARE: EVAL@COMPILE
(RECORD DATEOBJ (DATESTRING DISPLAY.DATE TEMPLATE.DATE))
(DATATYPE STREAM ( (* First 4 words are fixed for BIN, BOUT opcodes.
Length of whole datatype is multiple of 4, so 
quad-aligned)
(COFFSET WORD) (* Offset in CPPTR of next bin or bout)
(CBUFSIZE WORD) (* Offset past last byte in that buffer)
(BINABLE FLAG) (* BIN punts unless this bit on)
(BOUTABLE FLAG) (* BOUT punts unless this bit on)
(EXTENDABLE FLAG) (* BOUT punts when COFFSET ge CBUFFSIZE unless this 
bit set and COFFSET lt 512)
(NIL BITS 5)
(CBUFPTR POINTER) (* Pointer to current buffer)
(NONDEFAULTDATEFLG FLAG)
(REVALIDATEFLG FLAG)
(MULTIBUFFERHINT FLAG) (* True if stream likes to read and write more than 
one buffer at a time)
(USERCLOSEABLE FLAG) (* Can be closed by CLOSEF;
NIL for terminal, dribble...)
(USERVISIBLE FLAG) (* Listed by OPENP; NIL for terminal, dribble ...)
(ACCESSBITS BITS 3) (* What kind of access file is open for 
(read, write, append))
(FULLFILENAME POINTER) (* Name by which file is known to user)
(DEVICE POINTER) (* FDEV of this guy)
(VALIDATION POINTER) (* A number somehow identifying file, used to 
determine if file has changed in our absence)
(EPAGE WORD)
(EOFFSET WORD) (* Page, byte offset of eof)
(* Following are device-specific fields)
(F1 POINTER)
(F2 POINTER)
(F3 POINTER)
(F4 POINTER)
(F5 POINTER)
(FW6 WORD)
(FW7 WORD) (* Following only filled in for open streams)
(BYTESIZE BYTE)
(BUFFS POINTER)
(CPAGE WORD)
(FW8 WORD)
(MAXBUFFERS WORD)
(CHARPOSITION WORD) (* Used by POSITION etc.)
(DIRTYBITS WORD)
(LINELENGTH WORD)
(EOLCONVENTION BITS 2) (* End-of-line convention)
(CBUFDIRTY FLAG)
(NIL BITS 5)
(OUTCHARFN POINTER)
(ENDOFSTREAMOP POINTER) (* For use of applications programs, not devices)
(OTHERPROPS POINTER)
(IMAGEOPS POINTER) (* Image operations vector)
(IMAGEDATA POINTER) (* Image instance variables--format depends on 
IMAGEOPS value)
(EXTRASTREAMOP POINTER)
(STRMBINFN POINTER) (* Either the BIN fn from the FDEV, or a trap)
(STRMBOUTFN POINTER) (* Either the BIN fn from the FDEV, or a trap)
(CBUFMAXSIZE WORD)
(FW9 WORD)
(F10 POINTER) (* the current character set for this stream.
gbn 4-2-85)
(CHARSET BYTE))
(BLOCKRECORD STREAM ((NIL 2 WORD)
(UCODEFLAGS BYTE)
(NIL POINTER)))
(ACCESSFNS STREAM ((ACCESS \GETACCESS \SETACCESS)
(FULLNAME (OR (fetch (STREAM FULLFILENAME) of DATUM)
DATUM))
(NAMEDP (AND (fetch (STREAM FULLFILENAME) of DATUM)
T))))
(SYNONYM CBUFPTR (CPPTR))
USERCLOSEABLE _ T USERVISIBLE _ T ACCESSBITS _ NoBits BUFFS _ NIL BYTESIZE _ 8
CBUFPTR _ NIL MAXBUFFERS _(PROGN (DECLARE (GLOBALVARS
\STREAM.DEFAULT.MAXBUFFERS))
\STREAM.DEFAULT.MAXBUFFERS)
CHARPOSITION _ 0 LINELENGTH _(PROGN (DECLARE (GLOBALVARS FILELINELENGTH))
FILELINELENGTH)
OUTCHARFN _(FUNCTION \FILEOUTCHARFN)
ENDOFSTREAMOP _(FUNCTION \EOSERROR)
IMAGEOPS _ \NOIMAGEOPS EOLCONVENTION _(SELECTQ (SYSTEMTYPE)
(D CR.EOLC)
(VAX LF.EOLC)
(JERICHO CRLF.EOLC)
CR.EOLC)
STRMBINFN _(FUNCTION \STREAM.NOT.OPEN)
STRMBOUTFN _(FUNCTION \STREAM.NOT.OPEN))
(DATATYPE FONTCLASS ((PRETTYFONT# BYTE)
DISPLAYFD PRESSFD INTERPRESSFD OTHERFDS FONTCLASSNAME))
]
(/DECLAREDATATYPE 'STREAM
'(WORD WORD FLAG FLAG FLAG (BITS 5)
POINTER FLAG FLAG FLAG FLAG FLAG (BITS 3)
POINTER POINTER POINTER WORD WORD POINTER POINTER POINTER POINTER POINTER
WORD WORD BYTE POINTER WORD WORD WORD WORD WORD WORD (BITS 2)
FLAG
(BITS 5)
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER WORD WORD
POINTER BYTE)
'((STREAM 0 (BITS . 15))
(STREAM 1 (BITS . 15))
(STREAM 2 (FLAGBITS . 0))
(STREAM 2 (FLAGBITS . 16))
(STREAM 2 (FLAGBITS . 32))
(STREAM 2 (BITS . 52))
(STREAM 2 POINTER)
(STREAM 4 (FLAGBITS . 0))
(STREAM 4 (FLAGBITS . 16))
(STREAM 4 (FLAGBITS . 32))
(STREAM 4 (FLAGBITS . 48))
(STREAM 4 (FLAGBITS . 64))
(STREAM 4 (BITS . 82))
(STREAM 4 POINTER)
(STREAM 6 POINTER)
(STREAM 8 POINTER)
(STREAM 10 (BITS . 15))
(STREAM 11 (BITS . 15))
(STREAM 12 POINTER)
(STREAM 14 POINTER)
(STREAM 16 POINTER)
(STREAM 18 POINTER)
(STREAM 20 POINTER)
(STREAM 22 (BITS . 15))
(STREAM 23 (BITS . 15))
(STREAM 20 (BITS . 7))
(STREAM 24 POINTER)
(STREAM 26 (BITS . 15))
(STREAM 27 (BITS . 15))
(STREAM 28 (BITS . 15))
(STREAM 29 (BITS . 15))
(STREAM 30 (BITS . 15))
(STREAM 31 (BITS . 15))
(STREAM 24 (BITS . 1))
(STREAM 24 (FLAGBITS . 32))
(STREAM 24 (BITS . 52))
(STREAM 32 POINTER)
(STREAM 34 POINTER)
(STREAM 36 POINTER)
(STREAM 38 POINTER)
(STREAM 40 POINTER)
(STREAM 42 POINTER)
(STREAM 44 POINTER)
(STREAM 46 POINTER)
(STREAM 48 (BITS . 15))
(STREAM 49 (BITS . 15))
(STREAM 50 POINTER)
(STREAM 50 (BITS . 7)))
'52)
(/DECLAREDATATYPE 'FONTCLASS
'(BYTE POINTER POINTER POINTER POINTER POINTER)
'((FONTCLASS 0 (BITS . 7))
(FONTCLASS 0 POINTER)
(FONTCLASS 2 POINTER)
(FONTCLASS 4 POINTER)
(FONTCLASS 6 POINTER)
(FONTCLASS 8 POINTER))
'10)
(PUTPROPS DATE COPYRIGHT ("Leland Stanford Junior University" 1987))
(DECLARE: DONTCOPY
(FILEMAP (NIL (850 12872 (DATEOBJ 862 . 2359) (DATEOBJP 2363 . 2736) (DATE.DISPLAYFN 2740 . 3015) (
DATE.IMAGEBOXFN 3019 . 3575) (CURRENT.DISPLAY.FONT 3579 . 4284) (DATE.PUTFN 4288 . 4541) (DATE.GETFN
4545 . 4956) (DATE.BUTTONEVENTINFN 4960 . 6275) (DATES.TEMPLATE 6279 . 7439) (AMPM 7443 . 7615) (
DATES.MENU.APPLY 7619 . 8538) (DATES.MENU.WHENSELECTEDFN 8542 . 8780) (DATES.SET 8784 . 8895) (FINDDAY
8899 . 9154) (FINDHOUR 9158 . 9662) (FINDMONTH 9666 . 10427) (FINDTIME 10431 . 11846) (FINDYEAR 11850
. 12124) (NUMP 12128 . 12368) (WHICHDATE 12372 . 12869)))))
STOP

282
lispusers/PLAINTEXTSTREAM
View File

@@ -1,282 +0,0 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Jan-98 09:49:00" {DSK}<project>medley2.0>lispusers>PLAINTEXTSTREAM.;48 16624
changes to%: (FNS WRITEPLAINTEXTPAGE PLAINTEXTOUTCHARFN OPENPLAINTEXTSTREAM CLEARPLAINTEXTPAGE
MAKEPLAINTEXTPAGE)
(MACROS PLAINTEXTPARAM)
(VARS PLAINTEXTSTREAMCOMS)
(RECORDS PLAINTEXTIMAGEDATA)
previous date%: "11-Jan-98 23:04:10" {DSK}<project>medley2.0>lispusers>PLAINTEXTSTREAM.;29)
(* ; "
Copyright (c) 1998 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT PLAINTEXTSTREAMCOMS)
(RPAQQ PLAINTEXTSTREAMCOMS
[(ADDVARS (DEFAULTFILETYPELIST (PLAINTEXT . TEXT)
(PT . TEXT)))
(FNS OPENPLAINTEXTSTREAM PLAINTEXTOUTCHARFN PLAINTEXT.TEDIT PLAINTEXT.TEXT)
(FNS WRITEPLAINTEXTPAGE)
(MACROS PLAINTEXTPARAM)
(RECORDS PLAINTEXTIMAGEDATA)
[ADDVARS [PRINTFILETYPES (PLAINTEXT (EXTENSION (PT PLAINTEXT]
(IMAGESTREAMTYPES (PLAINTEXT (OPENSTREAM OPENPLAINTEXTSTREAM)
(FONTCREATE \CREATEDISPLAYFONT)
(FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)
(CREATECHARSET \CREATECHARSET.DISPLAY]
(DECLARE%: EVAL@COMPILE DONTCOPY (P [OR (RECLOOK 'STREAM)
(EVAL (SYSRECLOOK1 'STREAM]
(OR (RECLOOK 'IMAGEOPS)
(EVAL (SYSRECLOOK1 'IMAGEOPS])
(ADDTOVAR DEFAULTFILETYPELIST (PLAINTEXT . TEXT)
(PT . TEXT))
(DEFINEQ
(OPENPLAINTEXTSTREAM
[LAMBDA (FILE OPTIONS) (* ; "Edited 15-Jan-98 00:04 by rmk:")
(* ;; "Assert that scale is one, so that display fonts etc. can be used.")
(LET [(STREAM (OPENSTREAM FILE 'OUTPUT NIL '((SEQUENTIAL T]
(REPLACE (STREAM OUTCHARFN) OF STREAM WITH (FUNCTION PLAINTEXTOUTCHARFN))
[REPLACE (STREAM IMAGEDATA) OF STREAM
WITH (CREATE PLAINTEXTIMAGEDATA
PTPAGE _ (CL:MAKE-ARRAY (ADD1 (TIMES 72 11))
:INITIAL-ELEMENT NIL)
PTXPOSITION _ 0
PTYPOSITION _ (TIMES 72 11)
PTRIGHTMARGIN _ (FIX (TIMES 8.5 72))
PTLEFTMARGIN _ 0
PTCLIPPINGREGION _ (CREATE REGION
LEFT _ 0
BOTTOM _ 0
WIDTH _ (FIX (TIMES 8.5 72))
HEIGHT _ (TIMES 72 11]
[REPLACE (STREAM IMAGEOPS) OF STREAM
WITH (CREATE IMAGEOPS USING (FETCH (STREAM IMAGEOPS) OF STREAM)
IMAGETYPE _ 'PLAINTEXT IMFONT _
[FUNCTION (LAMBDA (STREAM FONT)
(CL:WHEN FONT
[PLAINTEXTPARAM
PTLINEFEED
(IMINUS (FONTPROP FONT 'HEIGHT])
(PLAINTEXTPARAM PTFONT FONT]
IMCLIPPINGREGION _
[FUNCTION (LAMBDA (STREAM REGION)
(CL:WHEN (AND REGION
(NOT (TYPE? REGION
REGION)))
(\ILLEGAL.ARG REGION))
(PLAINTEXTPARAM PTCLIPPINGREGION REGION]
IMXPOSITION _ [FUNCTION (LAMBDA (STREAM POS)
(PLAINTEXTPARAM PTXPOSITION
POS T]
IMYPOSITION _ [FUNCTION (LAMBDA (STREAM POS)
(PLAINTEXTPARAM PTYPOSITION
POS T]
IMMOVETO _ [FUNCTION (LAMBDA (STREAM X Y)
(PLAINTEXTPARAM PTXPOSITION X
T)
(PLAINTEXTPARAM PTYPOSITION Y
T]
IMLEFTMARGIN _ [FUNCTION (LAMBDA (STREAM M)
(PLAINTEXTPARAM
PTLEFTMARGIN M T]
IMRIGHTMARGIN _ [FUNCTION (LAMBDA (STREAM M)
(PLAINTEXTPARAM
PTRIGHTMARGIN M T]
IMLINEFEED _ [FUNCTION (LAMBDA (STREAM DY)
(PLAINTEXTPARAM PTLINEFEED
DY T]
IMSPACEFACTOR _ [FUNCTION (LAMBDA NIL 1]
IMFONTCREATE _ 'DISPLAY IMSTRINGWIDTH _
[FUNCTION (LAMBDA (STREAM STR RDTBL)
(STRINGWIDTH STR
(FETCH PTFONT
OF (FETCH (STREAM
IMAGEDATA)
OF STREAM))
RDTBL RDTBL]
IMCHARWIDTH _ [FUNCTION (LAMBDA (STREAM CHARCODE)
(CHARWIDTH
CHARCODE
(FETCH PTFONT
OF
(FETCH (STREAM
IMAGEDATA)
OF STREAM]
IMCLOSEFN _ (FUNCTION WRITEPLAINTEXTPAGE)
IMCHARSET _ [FUNCTION (LAMBDA (STREAM CHARSET)
(* ;; "If we had another illegal character set value, then we could simply fix it so that the character set didn't match anything, which would cause the character set shift to be put out on the next character")
(COND
((\IOMODEP STREAM
'OUTPUT T)
(\BOUT STREAM
NSCHARSETSHIFT)
(COND
((EQ CHARSET T)
(\BOUT STREAM
NSCHARSETSHIFT
)
(\BOUT STREAM 0))
(T (\BOUT STREAM
CHARSET]
IMDRAWPOLYGON _ (FUNCTION NILL)
IMDRAWPOINT _ (FUNCTION NILL)
IMSCALE _ (FUNCTION (LAMBDA NIL 1]
(DSPFONT '(GACHA 10)
STREAM)
STREAM])
(PLAINTEXTOUTCHARFN
[LAMBDA (STREAM CHARCODE) (* ; "Edited 15-Jan-98 00:06 by rmk:")
(* ;; "Put character data in PAGE entry indexed by current yposition")
(LET ((IMDATA (FETCH IMAGEDATA OF STREAM)))
(SELCHARQ CHARCODE
(CR
(* ;; "Set parameters but don't output--that means we can do lots of moving around, up and down, and still come out OK.")
(REPLACE PTXPOSITION OF IMDATA WITH 0)
(ADD (FETCH PTYPOSITION OF IMDATA)
(FETCH PTLINEFEED OF IMDATA)))
(FORM (WRITEPLAINTEXTPAGE STREAM)
(BOUT STREAM (CHARCODE FORM))
(REPLACE PTXPOSITION OF IMDATA WITH 0)
(REPLACE PTYPOSITION OF IMDATA WITH (TIMES 72 11)))
(LF (ADD (FETCH PTYPOSITION OF IMDATA)
(FETCH PTLINEFEED OF IMDATA)))
(CL:PUSH [LIST (FETCH PTXPOSITION OF IMDATA)
CHARCODE
(ADD (FETCH PTXPOSITION OF IMDATA)
(CHARWIDTH CHARCODE (FETCH PTFONT OF IMDATA]
(CL:SVREF (FETCH PTPAGE OF IMDATA)
(FETCH PTYPOSITION OF IMDATA])
(PLAINTEXT.TEDIT
[LAMBDA (FILE PTFILE) (* ; "Edited 8-Jan-98 06:17 by rmk:")
(* ; "Edited 18-Sep-91 18:16 by jds")
(* ;; "Make a plaintext file from a TEdit document. If FILE is a string, make it into a symbol for the file-name. If it's a STREAM, use that stream.")
[COND
((STRINGP FILE)
(SETQ FILE (MKATOM FILE]
(SETQ FILE (OPENTEXTSTREAM FILE))
(TEDIT.FORMAT.HARDCOPY FILE PTFILE T NIL NIL NIL 'PLAINTEXT)
PTFILE])
(PLAINTEXT.TEXT
[LAMBDA (FILE PTFILE FONTS HEADING TABS) (* ; "Edited 8-Jan-98 06:20 by rmk:")
(* ;;
"The effect of this should be to throw away font change characters and coerce characters to ISO8859")
(TEXTTOIMAGEFILE FILE PTFILE 'PLAINTEXT FONTS HEADING TABS])
)
(DEFINEQ
(WRITEPLAINTEXTPAGE
[LAMBDA (STREAM) (* ; "Edited 15-Jan-98 09:48 by rmk:")
(LET [(PAGE (FETCH PTPAGE OF (FETCH IMAGEDATA OF STREAM]
(* ;;
 "Have to run through y-positions indexed backwards, since have to print higher positions first.")
(FOR YPOS LINE LASTYPOS DIFF (DLF _ (FONTPROP DEFAULTFONT 'HEIGHT))
(DSP _ (CHARWIDTH (CHARCODE SPACE)
DEFAULTFONT)) FROM (SUB1 (CL:ARRAY-DIMENSION PAGE 0)) TO 0
BY -1 FIRST (SETQ LASTYPOS YPOS) WHEN (SETQ LINE (CL:SVREF PAGE YPOS))
DO (SETQ DIFF (- LASTYPOS YPOS))
(CL:WHEN (IGREATERP DIFF DLF) (* ; "Distance is more than a line")
(* ;;
 "Start at 2 because one was already put out at the end of the previous line")
(FOR I FROM 2 TO (IQUOTIENT DIFF DLF)
DO (BOUT STREAM (CHARCODE CR))))
(SORT LINE T) (* ; "To print from left to right")
(FOR C (LASTX _ 0) IN LINE
DO (SETQ DIFF (- (POP C)
LASTX))
(CL:WHEN (IGREATERP DIFF DSP) (* ; "Distance is more than a space")
(FOR I FROM 1 TO (IQUOTIENT DIFF DLF)
DO (BOUT STREAM (CHARCODE SPACE))))
[IF (ILEQ (CAR C)
127)
THEN (BOUT STREAM (CAR C))
ELSE
(* ;; "Should coerce to ISO8859. If get something below 256, use it. Otherwise, try to print charactername")
(LET (STRING)
(SETQ STRING (SELCHARQ (CAR C)
(phi "phi")
(MEMBEROF "memb")
(UC-SIGMA "Sigma")
(46,123 "Pi")
(357,147 "o")
NIL))
(IF STRING
THEN (BOUT STREAM (CHARCODE \))
(FOR I C FROM 1
WHILE (SETQ C (NTHCHARCODE STRING I))
DO (BOUT STREAM C))
(BOUT STREAM (CHARCODE \))
ELSE (BOUT STREAM (CHARCODE ~]
(SETQ LASTX (CADR C)))
(\FILEOUTCHARFN STREAM (CHARCODE CR))
(SETQ LASTYPOS YPOS)
(* ;; "Now clear the entry")
(CL:SETF (CL:SVREF PAGE YPOS)
NIL])
)
(DECLARE%: EVAL@COMPILE
(PUTPROPS PLAINTEXTPARAM MACRO
[(PNAME PVAL NUMBERPFLAG)
(PROG1 (FETCH PNAME OF (FETCH (STREAM IMAGEDATA) OF STREAM))
[LET ((PV PVAL))
(CL:WHEN PV
(REPLACE PNAME OF (FETCH (STREAM IMAGEDATA) OF STREAM)
WITH (COND
('NUMBERPFLAG (OR (NUMBERP PV)
(\ILLEGAL.ARG PV)))
(T PV))))])])
)
(DECLARE%: EVAL@COMPILE
(RECORD PLAINTEXTIMAGEDATA (PTPAGE PTXPOSITION PTYPOSITION PTFONT PTLINEFEED PTRIGHTMARGIN
PTLEFTMARGIN PTCLIPPINGREGION))
)
(ADDTOVAR PRINTFILETYPES (PLAINTEXT (EXTENSION (PT PLAINTEXT))))
(ADDTOVAR IMAGESTREAMTYPES (PLAINTEXT (OPENSTREAM OPENPLAINTEXTSTREAM)
(FONTCREATE \CREATEDISPLAYFONT)
(FONTSAVAILABLE \SEARCHDISPLAYFONTFILES)
(CREATECHARSET \CREATECHARSET.DISPLAY)))
(DECLARE%: EVAL@COMPILE DONTCOPY
[OR (RECLOOK 'STREAM)
(EVAL (SYSRECLOOK1 'STREAM]
[OR (RECLOOK 'IMAGEOPS)
(EVAL (SYSRECLOOK1 'IMAGEOPS]
)
(PUTPROPS PLAINTEXTSTREAM COPYRIGHT ("Xerox Corporation" 1998))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (1746 11976 (OPENPLAINTEXTSTREAM 1756 . 9644) (PLAINTEXTOUTCHARFN 9646 . 11087) (
PLAINTEXT.TEDIT 11089 . 11661) (PLAINTEXT.TEXT 11663 . 11974)) (11977 15294 (WRITEPLAINTEXTPAGE 11987
. 15292)))))
STOP