(FILECREATED "21-Oct-85 12:44:24" {ERIS}<LISPCORE>LISPUSERS>BQUOTE.;14 17117
changes to: (VARS BQUOTECOMS)
(FNS BQUOTE.STOP)
previous date: " 3-Aug-85 17:41:29" {ERIS}<LISPCORE>LISPUSERS>BQUOTE.;13)
(* Copyright (c) 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT BQUOTECOMS)
(RPAQQ BQUOTECOMS ((* * Backquote -- By Kelly Roach. Based on an earlier version by John L. White.
*)
(E (* Forms in this area are made with BQUOTE off for readability. *)
(BQUOTE.PRETTYSTOP))
(INITVARS (\BQUOTE.LEVEL 0))
(MACROS BQUOTE)
(FNS \BQUOTE.MACROFN \BQUOTE.DOT.FIX \COMMA.MACROFN \QUOTE.MACROFN BQUOTE \BQUOTE.UNCOMMA
\BQUOTE.EXPAND \BQUOTE.STANDARD \BQUOTE.SPLICE \BQUOTE.BREAKRESET \BQUOTE.PRINT
BQUOTE.START BQUOTE.PRETTYSTART BQUOTE.STOP BQUOTE.PRETTYSTOP)
(FNS \BQUOTE.HACK.FONTS \BQUOTE.HACK.FONT \BQUOTE.FONT)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (KEYACTION (QUOTE SAME)
(QUOTE ((96 10 NOLOCKSHIFT) . IGNORE)))
(SETQ BREAKRESETFORMS (REMOVE (QUOTE (\BQUOTE.BREAKRESET))
BREAKRESETFORMS))
(ADDTOVAR BREAKRESETFORMS (\BQUOTE.BREAKRESET 0))
(ADDTOVAR RESETFORMS (SETQ \BQUOTE.LEVEL 0))
(\BQUOTE.HACK.FONTS)
(BQUOTE.START)))
(E (BQUOTE.PRETTYSTART))
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML BQUOTE)
(LAMA)))))
(* * Backquote -- By Kelly Roach. Based on an earlier version by John L. White. *)
(RPAQ? \BQUOTE.LEVEL 0)
(DECLARE: EVAL@COMPILE
(PUTPROPS BQUOTE MACRO (SEX (\BQUOTE.EXPAND (\BQUOTE.UNCOMMA (CAR SEX))
1)))
)
(DEFINEQ
(\BQUOTE.MACROFN
(LAMBDA (STREAM RDTBL) (* kbr: "11-Jul-85 15:18")
(* Readmacro function for backquote)
((LAMBDA (\BQUOTE.LEVEL)
(PROG (ANSWER)
(SETQ ANSWER (LIST (QUOTE BQUOTE)
(READ STREAM RDTBL)))
(COND
((EQ \BQUOTE.LEVEL 1)
(\BQUOTE.DOT.FIX ANSWER)))
(RETURN ANSWER)))
(ADD1 \BQUOTE.LEVEL))))
(\BQUOTE.DOT.FIX
(LAMBDA (SEX) (* kbr: "21-Jun-85 09:44")
(* Replaces ". ,X" with (\.%, X) . *)
(* We make ". ,X" behave just like ",@X" but
prettyprint it as ". ,X" *)
(PROG (TAIL)
(COND
((LISTP SEX)
(SETQ TAIL SEX)
(\BQUOTE.DOT.FIX (pop TAIL))
(while TAIL do (COND
((EQ (CAR TAIL)
(QUOTE \%,))
(RPLACA TAIL (CONS (QUOTE \.%,)
(CDR TAIL)))
(RPLACD TAIL NIL)
(RETURN))
((EQ (CAR TAIL)
(QUOTE .%,))
(RPLACA TAIL (CONS (QUOTE \.%,)
(CDR TAIL)))
(RPLACD TAIL NIL)
(RETURN))
(T (\BQUOTE.DOT.FIX (pop TAIL)))))))
(RETURN SEX))))
(\COMMA.MACROFN
(LAMBDA (STREAM RDTBL) (* kbr: "21-Jun-85 09:48")
(* Readmacro function for comma)
(PROG NIL
(* This COND is a bit of a hack that should go away after everybody%'s code respects backquote.
The prime violators right now are comments%, printouts%, and old ASSIST BQUOTEs. *)
(COND
((EQ (GETSYNTAX (PEEKC STREAM)
RDTBL)
(QUOTE SEPRCHAR))
(RETURN (QUOTE %,)))
((EQ \BQUOTE.LEVEL 0)
(COND
((EQ (PEEKC STREAM)
(QUOTE @))
(READC STREAM)
(RETURN (QUOTE %,@)))
((EQ (PEEKC STREAM)
(QUOTE %.))
(READC STREAM)
(RETURN (QUOTE %,.)))
((NOT (EQ (PEEKC STREAM)
(QUOTE %,)))
(RETURN (QUOTE %,)))
(T (READC STREAM)
(COND
((NOT (EQ (PEEKC STREAM)
(QUOTE %,)))
(RETURN (QUOTE %,%,)))
(T (READC STREAM)
(RETURN (QUOTE %,%,%,)))))))) (* This part is the definition we should evolve to.
*)
((LAMBDA (\BQUOTE.LEVEL)
(COND
((ILESSP \BQUOTE.LEVEL 0)
(ERROR "Too many commas" "")))
(RETURN (LIST (SELECTQ (PEEKC STREAM)
(@ (READC STREAM)
(QUOTE \%,@))
(%. (READC STREAM)
(QUOTE \%,.))
(QUOTE \%,))
(READ STREAM RDTBL))))
(SUB1 \BQUOTE.LEVEL)))))
(\QUOTE.MACROFN
(LAMBDA (STREAM RDTBL) (* kbr: "18-Jun-85 17:36")
(* Superior to old READ%' wrt intervening whitespace
between quote char and form.
*)
(LIST (QUOTE QUOTE)
(READ STREAM RDTBL))))
(BQUOTE
(NLAMBDA (SEX) (* kbr: " 3-Aug-85 17:39")
(DECLARE (LOCALVARS . T))
(EVAL (\BQUOTE.EXPAND (\BQUOTE.UNCOMMA SEX)
1))))
(\BQUOTE.UNCOMMA
(LAMBDA (SEX) (* kbr: " 3-Aug-85 16:04")
(* Coerces obsolete ASSIST backquotes.
*)
(PROG (MARKER)
(COND
((NOT (LISTP SEX))
(RETURN SEX)))
(SETQ MARKER (CDR (FASSOC (CAR SEX)
(QUOTE ((, . \,)
(,@ . \,@)
(,! . \,@)
(., . \.,)
(,. . \,.))))))
(COND
(MARKER (RPLACA SEX (LIST MARKER (\BQUOTE.UNCOMMA (CADR SEX))))
(RPLACD SEX (\BQUOTE.UNCOMMA (CDDR SEX))))
(T (\BQUOTE.UNCOMMA (CAR SEX))
(\BQUOTE.UNCOMMA (CDR SEX))))
(RETURN SEX))))
(\BQUOTE.EXPAND
(LAMBDA (SEX LEVEL) (* kbr: "11-Jul-85 14:36")
(* Backquote expanding function *)
(COND
((ILESSP LEVEL 0) (* Perhaps the user hand constructed a malformed
backquoted form. *)
(ERROR "Too many commas" SEX))
((EQ LEVEL 0)
(COND
((LISTP SEX)
(SELECTQ (CAR SEX)
(BQUOTE (\BQUOTE.EXPAND (CADR SEX)
1))
(CONS (\BQUOTE.EXPAND (CAR SEX)
0)
(\BQUOTE.EXPAND (CDR SEX)
0))))
(T SEX)))
((EQ LEVEL 1)
(COND
((LISTP SEX)
(SELECTQ (CAR SEX)
(\%, (CADR SEX))
(\%,@ (ERROR ",@ in illegal context" SEX))
(\.%, (ERROR ". , in illegal context" SEX))
(\%,. (ERROR ",. in illegal context" SEX))
(BQUOTE (\BQUOTE.STANDARD SEX 2))
(COND
((AND (LISTP (CAR SEX))
(FMEMB (CAAR SEX)
(QUOTE (\%,@ \.%, \%,.))))
(\BQUOTE.SPLICE SEX))
(T (\BQUOTE.STANDARD SEX 1)))))
(T (KWOTE SEX))))
(T (* LEVEL > 1.0 *)
(COND
((LISTP SEX)
(SELECTQ (CAR SEX)
((\%, \%,@ \.%, \%,.)
(\BQUOTE.STANDARD SEX (SUB1 LEVEL)))
(BQUOTE (\BQUOTE.STANDARD SEX (ADD1 LEVEL)))
(\BQUOTE.STANDARD SEX LEVEL)))
(T (KWOTE SEX)))))))
(\BQUOTE.STANDARD
(LAMBDA (SEX LEVEL) (* kbr: "18-Feb-84 14:01")
(* Standard case. *)
(PROG (A D D.LISTP D.QUOTEDP ANSWER)
(SETQ A (CAR SEX))
(SETQ D (CDR SEX))
(SETQ A (\BQUOTE.EXPAND A LEVEL))
(SETQ D (\BQUOTE.EXPAND D LEVEL))
(SETQ D.LISTP (LISTP D))
(SETQ D.QUOTEDP (AND D.LISTP (EQ (CAR D)
(QUOTE QUOTE))))
(COND
((AND D.LISTP (EQ (CAR D)
(QUOTE LIST))) (* (CONS X (LIST . Y)) => (LIST X . Y) *)
(SETQ ANSWER (CONS (QUOTE LIST)
(CONS A (CDR D)))))
((AND D.QUOTEDP (EQ (CADR D)
NIL)) (* (CONS X NIL) => (LIST X) *)
(SETQ ANSWER (LIST (QUOTE LIST)
A)))
((AND D.QUOTEDP (LISTP A)
(EQ (CAR A)
(QUOTE QUOTE))) (* (CONS (QUOTE X) (QUOTE Y)) =>
(QUOTE (X . Y)) *)
(SETQ ANSWER (LIST (QUOTE QUOTE)
(CONS (CADR A)
(CADR D)))))
(T (SETQ ANSWER (LIST (QUOTE CONS)
A D))))
(RETURN ANSWER))))
(\BQUOTE.SPLICE
(LAMBDA (SEX) (* kbr: "21-Jun-85 09:58")
(* Splice-in cases. ",@" ",."
".," use APPEND. *)
(PROG (A A1 A2 D ANSWER)
(SETQ A (CAR SEX))
(SETQ A1 (CAR A))
(SETQ A2 (CADR A))
(SETQ D (CDR SEX))
(SETQ D (\BQUOTE.EXPAND D 1))
(COND
((EQUAL D (QUOTE (QUOTE NIL))) (* (APPEND X (QUOTE NIL)) => X *)
(SETQ ANSWER A2))
(T (COND
((AND (LISTP D)
(EQ (CAR D)
(QUOTE APPEND))) (* (APPEND X (APPEND . Y)) =>
(APPEND X . Y) *)
(SETQ ANSWER (CONS (QUOTE APPEND)
(CONS A2 (CDR D)))))
(T (SETQ ANSWER (LIST (QUOTE APPEND)
A2 D))))))
(RETURN ANSWER))))
(\BQUOTE.BREAKRESET
(LAMBDA (LEVEL) (* kbr: "18-Feb-84 14:01")
(* Placed on BREAKRESETFORMS in case of break while
backquoting. *)
(PROG1 \BQUOTE.LEVEL (SETQ \BQUOTE.LEVEL LEVEL))))
(\BQUOTE.PRINT
(LAMBDA (SEX) (* kbr: "11-Jul-85 15:20")
(* PRETTYPRINTMACRO to pretty print form SEX.
*)
(COND
((AND (EQLENGTH SEX 2)
(NULL (CDDR SEX))) (* OK to prettyprint this SEX.
*)
(PRIN1 (SELECTQ (CAR SEX)
(QUOTE (QUOTE %'))
(BQUOTE (QUOTE %`))
(\%, (QUOTE %,))
(\%,@ (QUOTE %,@))
(\.%, (QUOTE .% %,))
(\%,. (QUOTE %,.% ))
(SHOULDNT))) (* Let PRETTYPRINT handle (CADR SEX) *)
(OR (CADR SEX)
(PRIN2 NIL)))
(T (* SEX is not a 2 element list.
Must use ordinairy printing to guarantee SEX can be
faithfully READ back in. *)
(PRIN1 "(")
(\PRETTYBLOCK/SUBPRINT SEX NIL NIL)
(PRIN1 ")")
NIL))))
(BQUOTE.START
(LAMBDA NIL
(DECLARE (USEDFREE \BQUOTE.LEVEL)) (* kbr: "21-Jun-85 09:17")
(PROG NIL
(SETQ \BQUOTE.LEVEL 0) (* Fix up readtables a bit. *)
(* Note: Using NOESCQUOTE is a bad idea because it
leads to ambiguity. Both atom "'FOO" and list
"(QUOTE FOO)" would print as "'FOO" . *)
(for RDTBL in (QUOTE (\ORIGREADTABLE NIL T DEDITRDTBL EDITRDTBL FILERDTBL))
when (BOUNDP RDTBL)
do (SETQ RDTBL (EVALV RDTBL))
(SETSYNTAX (QUOTE %')
(QUOTE (MACRO FIRST NONIMMEDIATE ESCQUOTE \QUOTE.MACROFN))
RDTBL)
(SETSYNTAX (QUOTE %`)
(QUOTE (MACRO FIRST NONIMMEDIATE ESCQUOTE \BQUOTE.MACROFN))
RDTBL)
(SETSYNTAX (QUOTE %,)
(QUOTE (MACRO FIRST NONIMMEDIATE ESCQUOTE \COMMA.MACROFN))
RDTBL)) (* Pretty print macros. *)
(BQUOTE.PRETTYSTART))))
(BQUOTE.PRETTYSTART
(LAMBDA NIL (* kbr: "11-Jul-85 15:20")
(ADDTOVAR PRETTYPRINTMACROS (\%,. . \BQUOTE.PRINT)
(\.%, . \BQUOTE.PRINT)
(\%,@ . \BQUOTE.PRINT)
(\%, . \BQUOTE.PRINT)
(BQUOTE . \BQUOTE.PRINT)
(QUOTE . \BQUOTE.PRINT))))
(BQUOTE.STOP
(LAMBDA NIL (* kbr: "21-Oct-85 12:34")
(PROG NIL (* Fix up readtables a bit.
*)
(SETSYNTAX (QUOTE ')
(QUOTE OTHER)
FILERDTBL)
(for RDTBL in (QUOTE (FILERDTBL)) when (BOUNDP RDTBL)
do (SETQ RDTBL (EVALV RDTBL))
(SETSYNTAX (QUOTE `)
(QUOTE OTHER)
RDTBL)
(SETSYNTAX (QUOTE ,)
(QUOTE OTHER)
RDTBL)) (* Pretty print macros. *)
(BQUOTE.PRETTYSTOP))))
(BQUOTE.PRETTYSTOP
(LAMBDA NIL (* kbr: "21-Jun-85 09:16")
(SETQ PRETTYPRINTMACROS (for BUCKET in PRETTYPRINTMACROS
when (NOT (EQ (CDR BUCKET)
(FUNCTION \BQUOTE.PRINT)))
collect BUCKET))))
)
(DEFINEQ
(\BQUOTE.HACK.FONTS
(LAMBDA NIL (* kbr: "18-Jun-85 22:00")
(* Touches up quote and backquote on GACHA fonts.
*)
(PROG NIL (* This hack is pretty gross and isn%'t perfect.
*)
(\BQUOTE.HACK.FONT (QUOTE GACHA)
8)
(\BQUOTE.HACK.FONT (QUOTE GACHA)
10)
(\BQUOTE.HACK.FONT (QUOTE GACHA)
12)
(FONTPROFILE FONTPROFILE)
(for W in (OPENWINDOWS) do (DSPFONT (\BQUOTE.FONT (DSPFONT NIL W))
W))
(MAP.PROCESSES (FUNCTION (LAMBDA (P)
(COND
((AND (HASTTYWINDOWP P)
(DSPFONT (\BQUOTE.FONT (DSPFONT NIL (PROCESS.TTY P)))
(PROCESS.TTY P))))))))
(for VAR in (QUOTE (BACKTRACEFONT LAFITEDISPLAYFONT LAFITEEDITORFONT MENUFONT
TEDIT.DEFAULT.FONT))
when (AND (BOUNDP VAR)
(FONTP (GETATOMVAL VAR))
(EQ (FONTPROP (GETATOMVAL VAR)
(QUOTE FAMILY))
(QUOTE GACHA)))
do (SETATOMVAL VAR (\BQUOTE.FONT (GETATOMVAL VAR)))))))
(\BQUOTE.HACK.FONT
(LAMBDA (FAMILY SIZE) (* kbr: "15-Dec-84 14:34")
(PROG (BQUOTEFAMILY FONT)
(RESETLST (RESETSAVE DISPLAYFONTDIRECTORIES LISPUSERSDIRECTORIES)
(SETQ BQUOTEFAMILY (PACK* (QUOTE BQUOTE)
FAMILY))
(SETQ FONT (FONTCREATE BQUOTEFAMILY SIZE (QUOTE MRR)))
(replace (FONTDESCRIPTOR FONTFAMILY) of FONT with FAMILY)
(SETFONTDESCRIPTOR FAMILY SIZE (QUOTE MRR)
0
(QUOTE DISPLAY)
FONT)
(SETFONTDESCRIPTOR FAMILY SIZE (QUOTE BRR)
0
(QUOTE DISPLAY)
NIL)
(SETFONTDESCRIPTOR BQUOTEFAMILY SIZE (QUOTE MRR)
0
(QUOTE DISPLAY)
NIL)))))
(\BQUOTE.FONT
(LAMBDA (FONT) (* kbr: "21-Feb-84 11:24")
(* Used to get new font corresponding to FONT.
*)
(FONTCREATE (FONTPROP FONT (QUOTE FAMILY))
(FONTPROP FONT (QUOTE SIZE))
(FONTPROP FONT (QUOTE FACE))
(FONTPROP FONT (QUOTE ROTATION))
(FONTPROP FONT (QUOTE DEVICE)))))
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(KEYACTION (QUOTE SAME)
(QUOTE ((96 10 NOLOCKSHIFT) . IGNORE)))
(SETQ BREAKRESETFORMS (REMOVE (QUOTE (\BQUOTE.BREAKRESET))
BREAKRESETFORMS))
(ADDTOVAR BREAKRESETFORMS (\BQUOTE.BREAKRESET 0))
(ADDTOVAR RESETFORMS (SETQ \BQUOTE.LEVEL 0))
(\BQUOTE.HACK.FONTS)
(BQUOTE.START)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML BQUOTE)
(ADDTOVAR LAMA )
)
(PUTPROPS BQUOTE COPYRIGHT ("Xerox Corporation" 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1644 13910 (\BQUOTE.MACROFN 1654 . 2144) (\BQUOTE.DOT.FIX 2146 . 3137) (\COMMA.MACROFN
3139 . 4768) (\QUOTE.MACROFN 4770 . 5126) (BQUOTE 5128 . 5337) (\BQUOTE.UNCOMMA 5339 . 6132) (
\BQUOTE.EXPAND 6134 . 7760) (\BQUOTE.STANDARD 7762 . 9111) (\BQUOTE.SPLICE 9113 . 10120) (
\BQUOTE.BREAKRESET 10122 . 10450) (\BQUOTE.PRINT 10452 . 11498) (BQUOTE.START 11500 . 12605) (
BQUOTE.PRETTYSTART 12607 . 12944) (BQUOTE.STOP 12946 . 13592) (BQUOTE.PRETTYSTOP 13594 . 13908)) (
13911 16578 (\BQUOTE.HACK.FONTS 13921 . 15286) (\BQUOTE.HACK.FONT 15288 . 16110) (\BQUOTE.FONT 16112
. 16576)))))
STOP