Compare commits
11 Commits
nhb-remove
...
nhb-fix-et
| Author | SHA1 | Date | |
|---|---|---|---|
|
d79f1ae819 | ||
|
53b13dc8ed | ||
|
f937e2ca98 | ||
|
|
53d6387e93 | ||
|
|
de0ba95497 | ||
|
|
b0f92834e2 | ||
|
|
b45dea97c7 | ||
|
|
1bf3f50d98 | ||
|
|
09b6b1e854 | ||
|
|
6e00dcf458 | ||
|
|
16fa8c6a24 |
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "27-Dec-2025 15:02:04" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;24| 7235
|
||||
(FILECREATED " 3-Feb-2026 11:59:42"
|
||||
|{DSK}<Users>briggs>Projects>medley>internal>loadups>LOADUP-LISP.;12| 7475
|
||||
|
||||
:EDIT-BY |rmk|
|
||||
:EDIT-BY |nhb|
|
||||
|
||||
:CHANGES-TO (FNS LOADUP-LISP)
|
||||
|
||||
:PREVIOUS-DATE "16-Oct-2025 16:55:27" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;22|)
|
||||
:PREVIOUS-DATE "28-Jan-2026 14:30:48" |{DSK}<tmp>new-LOADUP-LISP.;1|)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LOADUP-LISPCOMS)
|
||||
@@ -19,7 +20,9 @@
|
||||
(DEFINEQ
|
||||
|
||||
(LOADUP-LISP
|
||||
(LAMBDA (DRIBBLEFILE) (* \; "Edited 27-Dec-2025 15:02 by rmk")
|
||||
(LAMBDA (DRIBBLEFILE) (* \; "Edited 3-Feb-2026 11:59 by nhb")
|
||||
(* \; "Edited 28-Jan-2026 14:30 by lmm")
|
||||
(* \; "Edited 27-Dec-2025 15:02 by rmk")
|
||||
(* \; "Edited 16-Oct-2025 16:55 by rmk")
|
||||
(* \; "Edited 18-Aug-2025 12:08 by rmk")
|
||||
(* \; "Edited 15-Jun-2025 14:39 by rmk")
|
||||
@@ -71,7 +74,7 @@
|
||||
(LOADUP '(STACKFNS CMLMVS MACROS MACROAUX UNWINDMACROS))
|
||||
(LOADUP '(COMMON XCLC-RUNTIME CMLTYPES CL-ERROR))
|
||||
(LOADUP '(AFONT EDIT WEDIT PRETTY DSPRINTDEF NEWPRINTDEF SPELLFILE PRINTFN LOADFNS DMISC
|
||||
DIRECTORY SPELLFILE FILEPKG RESOURCE))
|
||||
DIRECTORY FILEPKG RESOURCE))
|
||||
|
||||
(* |;;| "needed for makesys")
|
||||
|
||||
@@ -133,6 +136,7 @@
|
||||
|
||||
(LOADUP '(PUP 10MBDRIVER LEAF LLETHER DPUPFTP LOCALFILE DSKDISPLAY COURIER LLNS TRSERVER SPP
|
||||
NSPRINT AUTHENTICATION BSP CLEARINGHOUSE NSFILING MAIKOETHER))
|
||||
(RESTART.ETHER)
|
||||
(DRIBBLE)
|
||||
(SETQ MAKESYSNAME :MEDLEY)))
|
||||
)
|
||||
@@ -145,5 +149,5 @@
|
||||
(GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST)
|
||||
)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (640 7029 (LOADUP-LISP 650 . 7027)))))
|
||||
(FILEMAP (NIL (652 7269 (LOADUP-LISP 662 . 7267)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,187 +0,0 @@
|
||||
(FILECREATED " 6-Feb-87 10:18:07" {DSK}<LISPFILES2>H.ALFA>BLOCKS.HKB;2 4571
|
||||
|
||||
changes to: (VARS *functions1* *predicates1* *variables1* *temp-foo* *temp-pred*)
|
||||
|
||||
previous date: " 3-Nov-86 11:06:40" {DSK}<LISPFILES2>H>BLOCKS.HKB;9)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT BLOCKSCOMS)
|
||||
|
||||
(RPAQQ BLOCKSCOMS (*functions1* *predicates1* *variables1* *temp-foo* *temp-pred*))
|
||||
|
||||
(RPAQQ *functions1* (HRPRINT LISTMEMB MEMBER fail true noteq))
|
||||
|
||||
(RPAQQ *predicates1* (color-of showworld SPLIT putdown pickup please ART PREP GoOnNp PARTIC
|
||||
OPTPARTIC VP VERB NP1 NP NOM BLOCK on clear puton))
|
||||
|
||||
(RPAQQ *variables1* (:d :c :color :bl :a4 :a3 :a2 :a1 :e :q :s :m :string :e4 :e3 :e2 :e1 :rest1
|
||||
:block2 :q4 :q3 :q2 :q1 :block1 :rest :block :oper :vf :b :a :w2 :w1 :x1
|
||||
:y1 :u :r :v :z :i :h :j :l :w :y :x :k :p))
|
||||
|
||||
(RPAQQ *temp-foo* [[LAMBDA (y)
|
||||
(PRINTOUT T y T]
|
||||
[LAMBDA (x y)
|
||||
(PROG ((temp x))
|
||||
loop
|
||||
(COND ((NULL temp)
|
||||
(RETURN T))
|
||||
(T (COND ([OR (MEMBER (CAR temp)
|
||||
y)
|
||||
(EQ (CAR temp (QUOTE one]
|
||||
(SETQ temp (CDR temp))
|
||||
(GO loop))
|
||||
(T (RETURN NIL]
|
||||
[LAMBDA (x y)
|
||||
(MEMBER x y]
|
||||
[LAMBDA NIL NIL]
|
||||
[LAMBDA NIL T]
|
||||
(LAMBDA (x y)
|
||||
(NOT (EQ x y])
|
||||
|
||||
(RPAQQ *temp-pred* [(((color-of :block :color)
|
||||
<
|
||||
(BLOCK :block :color :a :b :c :d)))
|
||||
(((showworld)
|
||||
<
|
||||
(on :x :y)
|
||||
(HRPRINT (on :x :y))
|
||||
(fail)))
|
||||
(((SPLIT (:a . :b)
|
||||
:a :b)))
|
||||
(((putdown :x)
|
||||
<
|
||||
(puton :x table)))
|
||||
(((pickup :x)
|
||||
<
|
||||
(puton :x hand)))
|
||||
(((please :string)
|
||||
<
|
||||
(VP :string)))
|
||||
(((ART the))
|
||||
((ART a))
|
||||
((ART an)))
|
||||
(((PREP on on)))
|
||||
(((GoOnNp (:x . :y)
|
||||
:v :rest)
|
||||
<
|
||||
(PREP :x :x1)
|
||||
(NP :y :v :rest)))
|
||||
(((PARTIC down))
|
||||
((PARTIC up))
|
||||
((PARTIC to)))
|
||||
(((OPTPARTIC NIL :x))
|
||||
((OPTPARTIC (:x . :y)
|
||||
:z)
|
||||
<
|
||||
(PARTIC :x)))
|
||||
(((VP (:x :y . :z))
|
||||
<
|
||||
(VERB :x :vf :oper)
|
||||
(PARTIC :y)
|
||||
(MEMBER :y :vf)
|
||||
(NP :z :block NIL)
|
||||
(:oper :block))
|
||||
((VP (:x . :y))
|
||||
<
|
||||
(VERB :x :vf :oper)
|
||||
(MEMBER one :vf)
|
||||
(NP :y :block :rest)
|
||||
(OPTPARTIC :rest :vf)
|
||||
(:oper :block))
|
||||
((VP (:x . :y))
|
||||
<
|
||||
(VERB :x :vf :oper)
|
||||
(MEMBER two :vf)
|
||||
(NP :y :block1 :rest)
|
||||
(BLOCK :block1 :q1 :q2 :q3 :q4 stackable)
|
||||
(GoOnNp :rest :block2 :rest1)
|
||||
(BLOCK :block2 :e1 :e2 :e3 supportive :e4)
|
||||
(:oper :block1 :block2)))
|
||||
(((VERB pickup (one)
|
||||
pickup))
|
||||
((VERB pick (up one)
|
||||
pickup))
|
||||
((VERB put (two)
|
||||
puton))
|
||||
((VERB stack (two)
|
||||
puton))
|
||||
((VERB put (down one)
|
||||
putdown)))
|
||||
(((NP1 (:x :y . :z)
|
||||
:w :u :r)
|
||||
<
|
||||
(PREP :y :y1)
|
||||
(NOM :x :x1)
|
||||
(NP :z :v :r)
|
||||
(:y1 :w :v)
|
||||
(BLOCK . :w1)
|
||||
(LISTMEMB (:x1 . :u)
|
||||
:w1)
|
||||
(SPLIT :w1 :w :w2))
|
||||
((NP1 (:x . :y)
|
||||
:v :u :r)
|
||||
<
|
||||
(NOM :x :x1)
|
||||
(NP1 :y :v (:x1 . :u)
|
||||
:r))
|
||||
((NP1 (:x . :y)
|
||||
:w :u :y)
|
||||
<
|
||||
(NOM :x :x1)
|
||||
(BLOCK . :w1)
|
||||
(LISTMEMB (:x1 . :u)
|
||||
:w1)
|
||||
(SPLIT :w1 :w :w2)))
|
||||
(((NP (:x . :y)
|
||||
:v :r)
|
||||
<
|
||||
(ART :x)
|
||||
(NP1 :y :v NIL :r))
|
||||
((NP :x :v :r)
|
||||
<
|
||||
(NP1 :x :v NIL :r)))
|
||||
(((NOM red red))
|
||||
((NOM block cube))
|
||||
((NOM cube cube))
|
||||
((NOM cube1 cube1))
|
||||
((NOM cube2 cube2))
|
||||
((NOM cube3 cube3))
|
||||
((NOM big large))
|
||||
((NOM small small))
|
||||
((NOM blue blue))
|
||||
((NOM white white))
|
||||
((NOM green green))
|
||||
((NOM pyramid1 pyramid))
|
||||
((NOM pyramid pyramid))
|
||||
((NOM sphere sphere)))
|
||||
(((BLOCK pyramid1 white pyramid 3 NIL stackable))
|
||||
((BLOCK cube2 blue cube 5 supportive stackable))
|
||||
((BLOCK cube3 green cube 1 supportive stackable))
|
||||
((BLOCK cube1 red cube 10 supportive stackable))
|
||||
((BLOCK sphere black sphere 3 NIL stackable))
|
||||
((BLOCK table NIL NIL NIL supportive NIL))
|
||||
((BLOCK hand NIL NIL NIL supportive NIL)))
|
||||
(((on cube3 hand))
|
||||
((on sphere table))
|
||||
((on cube1 table))
|
||||
((on cube2 table))
|
||||
((on pyramid1 table)))
|
||||
(((clear table))
|
||||
((clear :x)
|
||||
<
|
||||
(on :y :x)
|
||||
(puton :y table))
|
||||
((clear :x)))
|
||||
(((puton :x :y)
|
||||
<
|
||||
(noteq :x table)
|
||||
(clear :x)
|
||||
(noteq :y pyramid)
|
||||
(noteq :y sphere)
|
||||
(clear :y)
|
||||
(on :x :w)
|
||||
(delete (on :x :w))
|
||||
(assert (on :x :y])
|
||||
(DECLARE: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
@@ -1 +0,0 @@
|
||||
(FILECREATED "31-Aug-94 15:04:16" ("compiled on " {DSK}<lispcore>lispusers>BLOCKS-HKB.;1)
"28-Jul-94 17:28:46" bcompl'd in "Medley 28-Jul-94 ..." dated "28-Jul-94 17:35:29")
(FILECREATED " 6-Feb-87 10:18:07" {DSK}<LISPFILES2>H.ALFA>BLOCKS.HKB;2 4571 changes to: (VARS
*functions1* *predicates1* *variables1* *temp-foo* *temp-pred*) previous date: " 3-Nov-86 11:06:40"
{DSK}<LISPFILES2>H>BLOCKS.HKB;9)
(PRETTYCOMPRINT BLOCKSCOMS)
(RPAQQ BLOCKSCOMS (*functions1* *predicates1* *variables1* *temp-foo* *temp-pred*))
(RPAQQ *functions1* (HRPRINT LISTMEMB MEMBER fail true noteq))
(RPAQQ *predicates1* (color-of showworld SPLIT putdown pickup please ART PREP GoOnNp PARTIC OPTPARTIC
VP VERB NP1 NP NOM BLOCK on clear puton))
(RPAQQ *variables1* (:d :c :color :bl :a4 :a3 :a2 :a1 :e :q :s :m :string :e4 :e3 :e2 :e1 :rest1
:block2 :q4 :q3 :q2 :q1 :block1 :rest :block :oper :vf :b :a :w2 :w1 :x1 :y1 :u :r :v :z :i :h :j :l
:w :y :x :k :p))
(RPAQQ *temp-foo* ((LAMBDA (y) (PRINTOUT T y T)) (LAMBDA (x y) (PROG ((temp x)) loop (COND ((NULL temp
) (RETURN T)) (T (COND ((OR (MEMBER (CAR temp) y) (EQ (CAR temp (QUOTE one)))) (SETQ temp (CDR temp))
(GO loop)) (T (RETURN NIL))))))) (LAMBDA (x y) (MEMBER x y)) (LAMBDA NIL NIL) (LAMBDA NIL T) (LAMBDA (
x y) (NOT (EQ x y)))))
(RPAQQ *temp-pred* ((((color-of :block :color) < (BLOCK :block :color :a :b :c :d))) (((showworld) < (
on :x :y) (HRPRINT (on :x :y)) (fail))) (((SPLIT (:a . :b) :a :b))) (((putdown :x) < (puton :x table))
) (((pickup :x) < (puton :x hand))) (((please :string) < (VP :string))) (((ART the)) ((ART a)) ((ART
an))) (((PREP on on))) (((GoOnNp (:x . :y) :v :rest) < (PREP :x :x1) (NP :y :v :rest))) (((PARTIC down
)) ((PARTIC up)) ((PARTIC to))) (((OPTPARTIC NIL :x)) ((OPTPARTIC (:x . :y) :z) < (PARTIC :x))) (((VP
(:x :y . :z)) < (VERB :x :vf :oper) (PARTIC :y) (MEMBER :y :vf) (NP :z :block NIL) (:oper :block)) ((
VP (:x . :y)) < (VERB :x :vf :oper) (MEMBER one :vf) (NP :y :block :rest) (OPTPARTIC :rest :vf) (:oper
:block)) ((VP (:x . :y)) < (VERB :x :vf :oper) (MEMBER two :vf) (NP :y :block1 :rest) (BLOCK :block1
:q1 :q2 :q3 :q4 stackable) (GoOnNp :rest :block2 :rest1) (BLOCK :block2 :e1 :e2 :e3 supportive :e4) (
:oper :block1 :block2))) (((VERB pickup (one) pickup)) ((VERB pick (up one) pickup)) ((VERB put (two)
puton)) ((VERB stack (two) puton)) ((VERB put (down one) putdown))) (((NP1 (:x :y . :z) :w :u :r) < (
PREP :y :y1) (NOM :x :x1) (NP :z :v :r) (:y1 :w :v) (BLOCK . :w1) (LISTMEMB (:x1 . :u) :w1) (SPLIT :w1
:w :w2)) ((NP1 (:x . :y) :v :u :r) < (NOM :x :x1) (NP1 :y :v (:x1 . :u) :r)) ((NP1 (:x . :y) :w :u :y
) < (NOM :x :x1) (BLOCK . :w1) (LISTMEMB (:x1 . :u) :w1) (SPLIT :w1 :w :w2))) (((NP (:x . :y) :v :r) <
(ART :x) (NP1 :y :v NIL :r)) ((NP :x :v :r) < (NP1 :x :v NIL :r))) (((NOM red red)) ((NOM block cube)
) ((NOM cube cube)) ((NOM cube1 cube1)) ((NOM cube2 cube2)) ((NOM cube3 cube3)) ((NOM big large)) ((
NOM small small)) ((NOM blue blue)) ((NOM white white)) ((NOM green green)) ((NOM pyramid1 pyramid)) (
(NOM pyramid pyramid)) ((NOM sphere sphere))) (((BLOCK pyramid1 white pyramid 3 NIL stackable)) ((
BLOCK cube2 blue cube 5 supportive stackable)) ((BLOCK cube3 green cube 1 supportive stackable)) ((
BLOCK cube1 red cube 10 supportive stackable)) ((BLOCK sphere black sphere 3 NIL stackable)) ((BLOCK
table NIL NIL NIL supportive NIL)) ((BLOCK hand NIL NIL NIL supportive NIL))) (((on cube3 hand)) ((on
sphere table)) ((on cube1 table)) ((on cube2 table)) ((on pyramid1 table))) (((clear table)) ((clear
:x) < (on :y :x) (puton :y table)) ((clear :x))) (((puton :x :y) < (noteq :x table) (clear :x) (noteq
:y pyramid) (noteq :y sphere) (clear :y) (on :x :w) (delete (on :x :w)) (assert (on :x :y))))))
NIL
|
||||
275
lispusers/HPGL
275
lispusers/HPGL
@@ -1,20 +1,19 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED "20-Jul-88 17:47:02" |{MCS:MCS:STANFORD}<LANE>HPGL.;24| 45342
|
||||
|
||||
changes to%: (FNS \DRAWLINE.HPGL \FONT.HPGL \INIT.HPGL HARDCOPYW.HPGL)
|
||||
(FILECREATED "29-Jan-2026 21:10:52" {WMEDLEY}<lispusers>HPGL.;9 43562
|
||||
|
||||
previous date%: "20-Jul-88 17:34:42" |{MCS:MCS:STANFORD}<LANE>HPGL.;23|)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS OPENHPGLSTREAM)
|
||||
|
||||
:PREVIOUS-DATE "29-Jan-2026 11:02:32" {WMEDLEY}<lispusers>HPGL.;7)
|
||||
|
||||
(* "
|
||||
Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT HPGLCOMS)
|
||||
|
||||
(RPAQQ HPGLCOMS
|
||||
(RPAQQ HPGLCOMS
|
||||
((* * User Functions)
|
||||
(FNS MAKEHPGL OPENHPGLSTREAM HARDCOPYW.HPGL)
|
||||
(FNS OPENHPGLSTREAM HARDCOPYW.HPGL)
|
||||
(* * ImageOp Functions)
|
||||
(FNS \BITBLT.HPGL \BLTSHADE.HPGL \CLOSEFN.HPGL \COLOR.HPGL \DRAWARC.HPGL \DRAWCIRCLE.HPGL
|
||||
\DRAWCURVE.HPGL \DRAWLINE.HPGL \DRAWPOLYGON.HPGL \FILLCIRCLE.HPGL \FONT.HPGL
|
||||
@@ -36,20 +35,11 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY (FILES UTILISOPRS)
|
||||
(ALISTS (PRINTOUTMACROS !, !; !!;))
|
||||
(RECORDS PLOTTERDATA))
|
||||
(ALISTS (PRINTFILETYPES HPGL))
|
||||
[ADDVARS (PRINTERTYPES ((PLOTTER HPGL)
|
||||
(CANPRINT (HPGL))
|
||||
(STATUS TRUE)
|
||||
(BITMAPFILE (HARDCOPYW.HPGL FILE BITMAP SCALEFACTOR REGION ROTATION
|
||||
TITLE))
|
||||
(PROPERTIES NILL)))
|
||||
[PRINTFILETYPES (HPGL (EXTENSION (HPGL PLOT))
|
||||
(CONVERSION (TEXT MAKEHPGL TEDIT
|
||||
(LAMBDA (FILE PFILE)
|
||||
(SETQ FILE (OPENTEXTSTREAM FILE))
|
||||
(TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL
|
||||
NIL NIL 'HPGL)
|
||||
(CLOSEF? FILE)
|
||||
PFILE]
|
||||
(IMAGESTREAMTYPES (HPGL (OPENSTREAM OPENHPGLSTREAM)
|
||||
(FONTCREATE \FONTCREATE.HPGL)
|
||||
(FONTSAVAILABLE \SEARCH.HPGL.FONTS)
|
||||
@@ -64,39 +54,36 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(MAKEHPGL
|
||||
[LAMBDA (FILE PFILE FONTS HEADING TABS) (* cdl "12-Jun-85 11:22")
|
||||
(TEXTTOIMAGEFILE FILE PFILE 'HPGL FONTS HEADING TABS])
|
||||
|
||||
(OPENHPGLSTREAM
|
||||
[LAMBDA (FILE OPTIONS) (* ; "Edited 8-Sep-87 08:50 by cdl")
|
||||
[LAMBDA (FILE OPTIONS) (* ; "Edited 29-Jan-2026 21:10 by rmk")
|
||||
(* ; "Edited 28-Jan-2026 01:00 by rmk")
|
||||
(* ; "Edited 8-Sep-87 08:50 by cdl")
|
||||
(* DECLARATIONS%: (RECORD PAIR
|
||||
(KEY VALUE)))
|
||||
(KEY VALUE)))
|
||||
(LET (HPGLSTREAM POSITION (STREAM (OPENSTREAM FILE 'OUTPUT))
|
||||
(SCALE (create POSITION
|
||||
XCOORD _ SCREENWIDTH
|
||||
YCOORD _ SCREENHEIGHT)))
|
||||
(if (AND (SETQ POSITION (LISTGET OPTIONS 'SCALE))
|
||||
(POSITIONP POSITION))
|
||||
(POSITIONP POSITION))
|
||||
then (SETQ SCALE POSITION))
|
||||
(SETQ HPGLSTREAM (create STREAM
|
||||
IMAGEOPS _ \HPGLIMAGEOPS
|
||||
IMAGEDATA _ (create PLOTTERDATA
|
||||
PD.STREAM _ STREAM
|
||||
PD.SCALE _ SCALE
|
||||
PD.RIGHTMARGIN _ (with POSITION SCALE XCOORD)
|
||||
)
|
||||
PD.RIGHTMARGIN _ (with POSITION SCALE XCOORD))
|
||||
OUTCHARFN _ (FUNCTION \OUTCHAR.HPGL)
|
||||
CBUFPTR _ NIL
|
||||
CBUFSIZE _ 0
|
||||
DEVICE _ \NULLFDEV using STREAM))
|
||||
(with STREAM STREAM (SETQ LINELENGTH MAX.SMALLP))
|
||||
(with POSITION SCALE
|
||||
(printout STREAM "DF" !; "SC" "0" !, XCOORD !, "0" !, YCOORD !; "DT" !!; !;))
|
||||
(printout STREAM "DF" !; "SC" "0" !, XCOORD !, "0" !, YCOORD !; "DT" !!; !;))
|
||||
[bind ENTRY for PAIR on OPTIONS by (CDDR PAIR)
|
||||
do (with PAIR PAIR (if (SETQ ENTRY (ASSOC KEY HPGL.OPTIONS))
|
||||
then (printout STREAM (CDR ENTRY)
|
||||
VALUE !;]
|
||||
then (printout STREAM (CDR ENTRY)
|
||||
VALUE !;]
|
||||
(DSPFONT DEFAULTFONT HPGLSTREAM)
|
||||
(DSPRESET HPGLSTREAM)
|
||||
HPGLSTREAM])
|
||||
@@ -513,37 +500,38 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
T])
|
||||
|
||||
(\FONTCREATE.HPGL
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION) (* ; "Edited 4-Sep-87 15:13 by cdl")
|
||||
(if (ASSOC FAMILY HPGL.FONTS)
|
||||
then (LET ((WIDTHSBLOCK (\CREATECSINFOELEMENT))
|
||||
(FONTDESCRIPTOR (create FONTDESCRIPTOR
|
||||
FONTDEVICE _ 'HPGL
|
||||
FONTFAMILY _ FAMILY
|
||||
FONTSIZE _ SIZE
|
||||
FONTFACE _ FACE
|
||||
ROTATION _ ROTATION
|
||||
\SFHeight _ SIZE
|
||||
\SFAscent _ SIZE
|
||||
\SFDescent _ 0)))
|
||||
(bind (WIDTH _ (FIX (QUOTIENT (TIMES 3 SIZE)
|
||||
4))) for N from 0 to 254
|
||||
do (\FSETWIDTH WIDTHSBLOCK N WIDTH))
|
||||
(with FONTDESCRIPTOR FONTDESCRIPTOR
|
||||
(\SETCHARSETINFO FONTCHARSETVECTOR 0
|
||||
(create CHARSETINFO
|
||||
WIDTHS _ WIDTHSBLOCK
|
||||
IMAGEWIDTHS _ WIDTHSBLOCK
|
||||
CHARSETASCENT _ SIZE
|
||||
CHARSETDESCENT _ 0)))
|
||||
FONTDESCRIPTOR)
|
||||
else (FONTCREATE (CAAR HPGL.FONTS)
|
||||
SIZE FACE ROTATION 'HPGL])
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 28-Jan-2026 00:58 by rmk")
|
||||
(* ; "Edited 4-Sep-87 15:13 by cdl")
|
||||
(if (ASSOC (fetch (FONTSPEC FSFAMILY) of FONTSPEC)
|
||||
HPGL.FONTS)
|
||||
then (LET* ((SIZE (fetch (FONTSPEC FSSIZE) of FONTSPEC))
|
||||
(WIDTHSBLOCK (\CREATECSINFOELEMENT))
|
||||
(FONTDESCRIPTOR (create FONTDESCRIPTOR
|
||||
FONTDEVICE _ 'HPGL
|
||||
FONTFAMILY _ (fetch (FONTSPEC FSFAMILY) of FONTSPEC)
|
||||
FONTSIZE _ SIZE
|
||||
FONTFACE _ (fetch (FONTSPEC FSFACE) of FONTSPEC)
|
||||
ROTATION _ (fetch (FONTSPEC FSROTATION) of FONTSPEC)
|
||||
\SFHeight _ SIZE
|
||||
\SFAscent _ SIZE
|
||||
\SFDescent _ 0)))
|
||||
(for N (WIDTH _ (FIX (QUOTIENT (TIMES 3 SIZE)
|
||||
4))) from 0 to \MAXTHINCHAR
|
||||
do (\FSETWIDTH WIDTHSBLOCK N WIDTH))
|
||||
(\SETCHARSETINFO FONTDESCRIPTOR 0
|
||||
(create CHARSETINFO
|
||||
WIDTHS _ WIDTHSBLOCK
|
||||
IMAGEWIDTHS _ WIDTHSBLOCK
|
||||
CHARSETASCENT _ SIZE
|
||||
CHARSETDESCENT _ 0))
|
||||
FONTDESCRIPTOR)
|
||||
else (FONTCREATE (create FONTSPEC using FONTSPEC FSFAMILY _ (CAAR HPGL.FONTS])
|
||||
|
||||
(\INIT.HPGL
|
||||
[LAMBDA NIL (* ; "Edited 20-Jul-88 17:04 by cdl")
|
||||
[LAMBDA NIL (* ; "Edited 20-Jul-88 17:04 by cdl")
|
||||
(* DECLARATIONS%: (RECORD CLASS
|
||||
(FONTCLASSNAME PRETTYFONT# DISPLAYFD
|
||||
PRESSFD INTERPRESSFD . OTHERFDS)))
|
||||
(FONTCLASSNAME PRETTYFONT# DISPLAYFD
|
||||
PRESSFD INTERPRESSFD . OTHERFDS)))
|
||||
(DECLARE (GLOBALVARS FONTDEFS FONTNAME))
|
||||
(SETQ \NULLFDEV (create FDEV
|
||||
CLOSEFILE _ (FUNCTION NILL)))
|
||||
@@ -579,16 +567,14 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
IMROTATE _ (FUNCTION \ROTATE.HPGL)))
|
||||
(for FONTSET in FONTDEFS
|
||||
do [for CLASS in (CDR (ASSOC 'FONTPROFILE (CDR FONTSET)))
|
||||
unless (with CLASS CLASS (OR (NULL DISPLAYFD)
|
||||
(NULL INTERPRESSFD)
|
||||
(ASSOC 'HPGL OTHERFDS)))
|
||||
do (with CLASS CLASS (push
|
||||
OTHERFDS
|
||||
(LIST 'HPGL (CONS 'STANDARD
|
||||
(CDR (if (LISTP DISPLAYFD)
|
||||
then DISPLAYFD
|
||||
else (FONTUNPARSE
|
||||
DISPLAYFD]
|
||||
unless (with CLASS CLASS (OR (NULL DISPLAYFD)
|
||||
(NULL INTERPRESSFD)
|
||||
(ASSOC 'HPGL OTHERFDS)))
|
||||
do (with CLASS CLASS (push OTHERFDS (LIST 'HPGL (CONS 'STANDARD
|
||||
(CDR (if (LISTP DISPLAYFD)
|
||||
then DISPLAYFD
|
||||
else (FONTUNPARSE DISPLAYFD
|
||||
]
|
||||
finally (FONTSET FONTNAME])
|
||||
|
||||
(\OUTCHAR.HPGL
|
||||
@@ -603,10 +589,13 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
(push PD.TEXT CHARCODE])
|
||||
|
||||
(\SEARCH.HPGL.FONTS
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE) (* cdl " 1-May-85 09:34")
|
||||
(if (EQ DEVICE 'HPGL)
|
||||
then (if (FASSOC FAMILY HPGL.FONTS)
|
||||
then (LIST (LIST FAMILY SIZE FACE ROTATION DEVICE])
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 28-Jan-2026 00:53 by rmk")
|
||||
(* cdl " 1-May-85 09:34")
|
||||
(CL:WHEN (AND (EQ (fetch (FONTSPEC FSDEVICE) of FONTSPEC)
|
||||
'HPGL)
|
||||
(FASSOC (fetch (FONTSPEC FSFAMILY) of FONTSPEC)
|
||||
HPGL.FONTS)) (* ; "Make a copy?")
|
||||
(create FONTSPEC using FONTSPEC))])
|
||||
|
||||
(\FILL.HPGL
|
||||
[LAMBDA (STREAM TEXTURE) (* ; "Edited 8-Dec-87 16:56 by cdl")
|
||||
@@ -679,41 +668,43 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
(* * etc.)
|
||||
|
||||
|
||||
(RPAQQ HPGL.FONTS ((STANDARD . 0)
|
||||
(9825 . 1)
|
||||
(FRENCH . 2)
|
||||
(SCANDINAVIAN . 3)
|
||||
(SPANISH . 4)
|
||||
(JISASCII . 6)
|
||||
(ROMAN . 7)
|
||||
(KATAKANA . 8)
|
||||
(IRV . 9)
|
||||
(SWEDISH . 30)
|
||||
(SWEDISH2 . 31)
|
||||
(NORWAY . 32)
|
||||
(GERMAN . 33)
|
||||
(FRENCH2 . 34)
|
||||
(BRITISH . 35)
|
||||
(ITALIAN . 36)
|
||||
(SPANISH2 . 37)
|
||||
(PORTUGUESE . 38)
|
||||
(NORWAY2 . 39)))
|
||||
(RPAQQ HPGL.FONTS
|
||||
((STANDARD . 0)
|
||||
(9825 . 1)
|
||||
(FRENCH . 2)
|
||||
(SCANDINAVIAN . 3)
|
||||
(SPANISH . 4)
|
||||
(JISASCII . 6)
|
||||
(ROMAN . 7)
|
||||
(KATAKANA . 8)
|
||||
(IRV . 9)
|
||||
(SWEDISH . 30)
|
||||
(SWEDISH2 . 31)
|
||||
(NORWAY . 32)
|
||||
(GERMAN . 33)
|
||||
(FRENCH2 . 34)
|
||||
(BRITISH . 35)
|
||||
(ITALIAN . 36)
|
||||
(SPANISH2 . 37)
|
||||
(PORTUGUESE . 38)
|
||||
(NORWAY2 . 39)))
|
||||
|
||||
(RPAQQ HPGL.OPTIONS ((ROTATE . "RO")
|
||||
(VELOCITY . "VS")
|
||||
(PAPER . "PS")
|
||||
(TERMINATOR . "DT")))
|
||||
(VELOCITY . "VS")
|
||||
(PAPER . "PS")
|
||||
(TERMINATOR . "DT")))
|
||||
|
||||
(RPAQQ HPGL.FONT.EXPANSIONS ((REGULAR . 200.0)
|
||||
(COMPRESSED . 100.0)
|
||||
(EXPANDED . 400.0)))
|
||||
(COMPRESSED . 100.0)
|
||||
(EXPANDED . 400.0)))
|
||||
|
||||
(RPAQQ HPGL.DASHING ((1 1 49)
|
||||
(2 25)
|
||||
(3 35 15)
|
||||
(4 39 5 1 5)
|
||||
(5 35 5 5 5)
|
||||
(6 25 5 5 5 5 5)))
|
||||
(RPAQQ HPGL.DASHING
|
||||
((1 1 49)
|
||||
(2 25)
|
||||
(3 35 15)
|
||||
(4 39 5 1 5)
|
||||
(5 35 5 5 5)
|
||||
(6 25 5 5 5 5 5)))
|
||||
|
||||
(RPAQQ SKETCHINCOLORFLG T)
|
||||
|
||||
@@ -742,63 +733,55 @@ Copyright (c) 1985, 1986, 1987, 1988 by Stanford University. All rights reserve
|
||||
(FILESLOAD UTILISOPRS)
|
||||
|
||||
|
||||
(ADDTOVAR PRINTOUTMACROS [!, (LAMBDA (COMS)
|
||||
(CONS '(PRIN1 HPGL.SEPARATOR NIL)
|
||||
(CDR COMS]
|
||||
[!; (LAMBDA (COMS)
|
||||
(CONS '(PRIN1 HPGL.TERMINATOR NIL)
|
||||
(CDR COMS]
|
||||
[!!; (LAMBDA (COMS)
|
||||
(CONS '(PRIN1 HPGL.TEXT.TERMINATOR NIL)
|
||||
(CDR COMS])
|
||||
(ADDTOVAR PRINTOUTMACROS
|
||||
[!, (LAMBDA (COMS)
|
||||
(CONS '(PRIN1 HPGL.SEPARATOR NIL)
|
||||
(CDR COMS]
|
||||
[!; (LAMBDA (COMS)
|
||||
(CONS '(PRIN1 HPGL.TERMINATOR NIL)
|
||||
(CDR COMS]
|
||||
[!!; (LAMBDA (COMS)
|
||||
(CONS '(PRIN1 HPGL.TEXT.TERMINATOR NIL)
|
||||
(CDR COMS])
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RECORD PLOTTERDATA (PD.STREAM PD.POSITION PD.FONT PD.TEXT PD.COLOR PD.SCALE PD.LEFTMARGIN
|
||||
PD.RIGHTMARGIN PD.DASHING PD.ROTATION)
|
||||
PD.POSITION _ (create POSITION)
|
||||
PD.COLOR _ 0 PD.LEFTMARGIN _ 0 PD.ROTATION _ 0)
|
||||
PD.RIGHTMARGIN PD.DASHING PD.ROTATION)
|
||||
PD.POSITION _ (create POSITION)
|
||||
PD.COLOR _ 0 PD.LEFTMARGIN _ 0 PD.ROTATION _ 0)
|
||||
)
|
||||
)
|
||||
|
||||
(ADDTOVAR PRINTFILETYPES (HPGL (EXTENSION (HPGL PLOT))
|
||||
(BITMAPFILE (HARDCOPYW.HPGL FILE BITMAP SCALEFACTOR REGION ROTATION
|
||||
TITLE))))
|
||||
|
||||
(ADDTOVAR PRINTERTYPES ((PLOTTER HPGL)
|
||||
(CANPRINT (HPGL))
|
||||
(STATUS TRUE)
|
||||
(BITMAPFILE (HARDCOPYW.HPGL FILE BITMAP SCALEFACTOR REGION ROTATION TITLE
|
||||
))
|
||||
(PROPERTIES NILL)))
|
||||
|
||||
(ADDTOVAR PRINTFILETYPES [HPGL (EXTENSION (HPGL PLOT))
|
||||
(CONVERSION (TEXT MAKEHPGL TEDIT
|
||||
(LAMBDA (FILE PFILE)
|
||||
(SETQ FILE (OPENTEXTSTREAM FILE))
|
||||
(TEDIT.FORMAT.HARDCOPY FILE PFILE T NIL
|
||||
NIL NIL 'HPGL)
|
||||
(CLOSEF? FILE)
|
||||
PFILE])
|
||||
(CANPRINT (HPGL))
|
||||
(STATUS TRUE)
|
||||
(PROPERTIES NILL)))
|
||||
|
||||
(ADDTOVAR IMAGESTREAMTYPES (HPGL (OPENSTREAM OPENHPGLSTREAM)
|
||||
(FONTCREATE \FONTCREATE.HPGL)
|
||||
(FONTSAVAILABLE \SEARCH.HPGL.FONTS)
|
||||
(CREATECHARSET NILL)))
|
||||
(FONTCREATE \FONTCREATE.HPGL)
|
||||
(FONTSAVAILABLE \SEARCH.HPGL.FONTS)
|
||||
(CREATECHARSET NILL)))
|
||||
|
||||
[if (FGETD (FUNCTION SK.DASHING.LABEL))
|
||||
then (for ENTRY in HPGL.DASHING do (push SK.DASHING.PATTERNS
|
||||
(LIST (SK.DASHING.LABEL (CDR ENTRY))
|
||||
(CDR ENTRY]
|
||||
then (for ENTRY in HPGL.DASHING do (push SK.DASHING.PATTERNS (LIST (SK.DASHING.LABEL (CDR ENTRY))
|
||||
(CDR ENTRY]
|
||||
|
||||
(\INIT.HPGL)
|
||||
(PUTPROPS HPGL COPYRIGHT ("Stanford University" 1985 1986 1987 1988))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3583 6000 (MAKEHPGL 3593 . 3756) (OPENHPGLSTREAM 3758 . 5715) (HARDCOPYW.HPGL 5717 .
|
||||
5998)) (6031 29802 (\BITBLT.HPGL 6041 . 8018) (\BLTSHADE.HPGL 8020 . 9173) (\CLOSEFN.HPGL 9175 . 9503)
|
||||
(\COLOR.HPGL 9505 . 11429) (\DRAWARC.HPGL 11431 . 12940) (\DRAWCIRCLE.HPGL 12942 . 14285) (
|
||||
\DRAWCURVE.HPGL 14287 . 15076) (\DRAWLINE.HPGL 15078 . 17236) (\DRAWPOLYGON.HPGL 17238 . 18904) (
|
||||
\FILLCIRCLE.HPGL 18906 . 19622) (\FONT.HPGL 19624 . 23275) (\LEFTMARGIN.HPGL 23277 . 23578) (
|
||||
\LINEFEED.HPGL 23580 . 23823) (\MOVETO.HPGL 23825 . 24303) (\RESET.HPGL 24305 . 24674) (
|
||||
\RIGHTMARGIN.HPGL 24676 . 24980) (\ROTATE.HPGL 24982 . 25356) (\SCALEDBITBLT.HPGL 25358 . 27641) (
|
||||
\STRINGWIDTH.HPGL 27643 . 27826) (\CLIPPINGREGION.HPGL 27828 . 28133) (\TERPRI.HPGL 28135 . 28492) (
|
||||
\XPOSITION.HPGL 28494 . 29156) (\YPOSITION.HPGL 29158 . 29800)) (29834 40881 (\DUMPSTRING.HPGL 29844
|
||||
. 30316) (\FONTCREATE.HPGL 30318 . 31926) (\INIT.HPGL 31928 . 35493) (\OUTCHAR.HPGL 35495 . 36108) (
|
||||
\SEARCH.HPGL.FONTS 36110 . 36383) (\FILL.HPGL 36385 . 39041) (\DASHING.HPGL 39043 . 40879)))))
|
||||
(FILEMAP (NIL (2696 5094 (OPENHPGLSTREAM 2706 . 4809) (HARDCOPYW.HPGL 4811 . 5092)) (5125 28896 (
|
||||
\BITBLT.HPGL 5135 . 7112) (\BLTSHADE.HPGL 7114 . 8267) (\CLOSEFN.HPGL 8269 . 8597) (\COLOR.HPGL 8599
|
||||
. 10523) (\DRAWARC.HPGL 10525 . 12034) (\DRAWCIRCLE.HPGL 12036 . 13379) (\DRAWCURVE.HPGL 13381 .
|
||||
14170) (\DRAWLINE.HPGL 14172 . 16330) (\DRAWPOLYGON.HPGL 16332 . 17998) (\FILLCIRCLE.HPGL 18000 .
|
||||
18716) (\FONT.HPGL 18718 . 22369) (\LEFTMARGIN.HPGL 22371 . 22672) (\LINEFEED.HPGL 22674 . 22917) (
|
||||
\MOVETO.HPGL 22919 . 23397) (\RESET.HPGL 23399 . 23768) (\RIGHTMARGIN.HPGL 23770 . 24074) (
|
||||
\ROTATE.HPGL 24076 . 24450) (\SCALEDBITBLT.HPGL 24452 . 26735) (\STRINGWIDTH.HPGL 26737 . 26920) (
|
||||
\CLIPPINGREGION.HPGL 26922 . 27227) (\TERPRI.HPGL 27229 . 27586) (\XPOSITION.HPGL 27588 . 28250) (
|
||||
\YPOSITION.HPGL 28252 . 28894)) (28928 40323 (\DUMPSTRING.HPGL 28938 . 29410) (\FONTCREATE.HPGL 29412
|
||||
. 31221) (\INIT.HPGL 31223 . 34674) (\OUTCHAR.HPGL 34676 . 35289) (\SEARCH.HPGL.FONTS 35291 . 35825)
|
||||
(\FILL.HPGL 35827 . 38483) (\DASHING.HPGL 38485 . 40321)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
164
sources/APRINT
164
sources/APRINT
@@ -1,21 +1,18 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 9-Jun-2021 22:50:15"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>APRINT.;11 79264
|
||||
|
||||
changes to%: (VARS APRINTCOMS)
|
||||
(FILECREATED "22-Jan-2026 16:13:45" {WMEDLEY}<sources>APRINT.;5 78925
|
||||
|
||||
previous date%: "10-May-2021 15:46:22"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>git-medley>sources>APRINT.;10)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS APRINTCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 9-Jun-2021 22:50:15" {WMEDLEY}<sources>APRINT.;1)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT APRINTCOMS)
|
||||
|
||||
(RPAQQ APRINTCOMS
|
||||
[(COMS (* ; "User-level print functions")
|
||||
[(COMS (* ; "User-level print functions")
|
||||
(FNS PRIN1 PRIN2 PRIN3 PRIN4 PRINT PRINTCCODE \PRINTCCODE PRINTLEVEL RADIX SPACES
|
||||
TERPRI FRESHLINE DEFPRINT LINELENGTH))
|
||||
(INITVARS (PLVLFILEFLG NIL)
|
||||
@@ -38,8 +35,9 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(*KEYWORD-PACKAGE* NIL)
|
||||
(*INTERLISP-PRIN1-CASE* ':UPCASE)
|
||||
(\DEFPRINTFNS NIL))
|
||||
(COMS (* ; "PRINT internals")
|
||||
(COMS (* ; "PRINT internals")
|
||||
(FNS PRINT-CIRCLE-LOOKUP PRINT-CIRCLE-LABEL-P PRINT-CIRCLE-SCAN PRINT-CIRCLE-ENTER)
|
||||
(FNS OCTALSTRING)
|
||||
(FNS \PRINDATUM \PRINT-USING-DEFPRINT \PRINT-USING-ADDRESS \ELIDE.PRINT.ELEMENT
|
||||
\ELIDE.ELEMENT.CHAR \ELIDE.PRINT.TAIL \ELIDE.TAIL.STRING \CKPOSBOUT \CKPOSSOUT
|
||||
\CONVERTNUMBER \LITPRIN \LITPRIN.INTERNAL \SYMBOL.ESCAPE.COUNT \NUMERIC.PNAMEP
|
||||
@@ -49,23 +47,24 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(EXPORT (MACROS .SPACECHECK. \CHECKRADIX)))
|
||||
(FNS \INVALID.RADIX)
|
||||
(SPECVARS \THISFILELINELENGTH))
|
||||
(COMS (* ; "Internal printing")
|
||||
(COMS (* ; "Internal printing")
|
||||
(FNS \MAPPNAME \MAPPNAME.INTERNAL PNAMESTREAMP)
|
||||
(DECLARE%: DONTCOPY (RESOURCES \MAPPNAMESTREAM)
|
||||
(MACROS PNAMESTREAMP))
|
||||
(INITRESOURCES \MAPPNAMESTREAM)
|
||||
[INITVARS (\PNAMEDEVICE (NCREATE 'FDEV (\GETDEVICEFROMHOSTNAME 'NULL T]
|
||||
(GLOBALVARS \PNAMEDEVICE))
|
||||
(COMS (* ; "Obsolete")
|
||||
(COMS (* ; "Obsolete")
|
||||
(FNS \MAPCHARS))
|
||||
(DECLARE%: EVAL@COMPILE DOCOPY
|
||||
(ADDVARS (SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE*
|
||||
*PRINT-CASE* *PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH*
|
||||
*PRINT-PRETTY* *PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE*)))
|
||||
(COMS (* ; "PRINTNUM and friends")
|
||||
(COMS (* ; "PRINTNUM and friends")
|
||||
(FNS PRINTNUM FLTFMT \CHECKFLTFMT PRINTNUM-TO-STRING)
|
||||
(MACROS NUMFORMATCODE)
|
||||
(INITVARS (NILNUMPRINTFLG)))
|
||||
(PROPS (APRINT FILETYPE))
|
||||
(LOCALVARS . T)
|
||||
(GLOBALVARS \LINELENGTH \FLOATFORMAT PRXFLG \DEFPRINTFNS)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
@@ -401,6 +400,13 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(OCTALSTRING
|
||||
[LAMBDA (N) (* bvm%: "21-JUL-81 12:16")
|
||||
(GLOBALRESOURCE (\NUMSTR \NUMSTR1)
|
||||
(CONCAT (\CONVERTNUMBER N 8 NIL NIL \NUMSTR \NUMSTR1])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(\PRINDATUM
|
||||
[LAMBDA (OBJECT STREAM CPL) (* ; "Edited 11-Feb-91 14:34 by jds")
|
||||
(DECLARE (USEDFREE *READTABLE* *PRINT-RADIX* *PRINT-BASE* *PRINT-ESCAPE*))
|
||||
@@ -1117,75 +1123,72 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS .FILELINELENGTH. MACRO ((STRM)
|
||||
(LET ((L (fetch (STREAM LINELENGTH) of STRM)))
|
||||
(SELECTC L
|
||||
(0 (* Some default)
|
||||
\LINELENGTH)
|
||||
(MAX.SMALLP
|
||||
(* Infinite)
|
||||
NIL)
|
||||
L))))
|
||||
(LET ((L (fetch (STREAM LINELENGTH) of STRM)))
|
||||
(SELECTC L
|
||||
(0 (* Some default)
|
||||
\LINELENGTH)
|
||||
(MAX.SMALLP (* Infinite)
|
||||
NIL)
|
||||
L))))
|
||||
)
|
||||
|
||||
|
||||
(DEFMACRO \PRINDATUM-LISTP ()
|
||||
|
||||
(* ;; "This is a hokey macro call to save the function call. Read it as though it were inline code in \prindatum")
|
||||
(* ;; "This is a hokey macro call to save the function call. Read it as though it were inline code in \prindatum")
|
||||
|
||||
`[LET (LABEL FIRSTTIME)
|
||||
(OR CPL (SETQ CPL 0))
|
||||
(if *PRINT-CIRCLE-HASHTABLE*
|
||||
then
|
||||
(* ;; "*PRINT-CIRCLE-HASHTABLE* is only non-nil when *print-circle*.")
|
||||
|
||||
(* ;; "*PRINT-CIRCLE-HASHTABLE* is only non-nil when *print-circle*.")
|
||||
|
||||
(CL:MULTIPLE-VALUE-SETQ (LABEL FIRSTTIME)
|
||||
(PRINT-CIRCLE-LOOKUP OBJECT)))
|
||||
(CL:MULTIPLE-VALUE-SETQ (LABEL FIRSTTIME)
|
||||
(PRINT-CIRCLE-LOOKUP OBJECT)))
|
||||
[if LABEL
|
||||
then (\CKPOSSOUT STREAM LABEL)
|
||||
(CL:WHEN FIRSTTIME
|
||||
(\CKPOSBOUT STREAM (CHARCODE SPACE)))]
|
||||
(CL:WHEN FIRSTTIME
|
||||
(\CKPOSBOUT STREAM (CHARCODE SPACE)))]
|
||||
(COND
|
||||
((AND LABEL (NOT FIRSTTIME)) (* ;
|
||||
"Second reference --- just print label")
|
||||
((AND LABEL (NOT FIRSTTIME)) (* ;
|
||||
"Second reference --- just print label")
|
||||
NIL)
|
||||
((AND *PRINT-LEVEL* (ILEQ *PRINT-LEVEL* CPL))
|
||||
(\ELIDE.PRINT.ELEMENT STREAM))
|
||||
(T (PROG (CDRCNT)
|
||||
[COND
|
||||
(*PRINT-LENGTH* (SETQ CDRCNT (COND
|
||||
((fetch (READTABLEP COMMONLISP)
|
||||
of *READTABLE*)
|
||||
((fetch (READTABLEP COMMONLISP) of
|
||||
*READTABLE*
|
||||
)
|
||||
0)
|
||||
(T (* ;
|
||||
"Interlisp print depth is triangular, Common Lisp isn't")
|
||||
(T (* ;
|
||||
"Interlisp print depth is triangular, Common Lisp isn't")
|
||||
[COND
|
||||
((IGEQ CPL *PRINT-LENGTH*)
|
||||
(* ;
|
||||
"We would just print '(--)' so it's nicer to print '&'")
|
||||
(RETURN (\ELIDE.PRINT.ELEMENT
|
||||
STREAM]
|
||||
(* ;
|
||||
"We would just print '(--)' so it's nicer to print '&'")
|
||||
(RETURN (\ELIDE.PRINT.ELEMENT STREAM]
|
||||
CPL]
|
||||
(add CPL 1) (* ;
|
||||
"Recursive calls will be at 1 greater depth")
|
||||
(add CPL 1) (* ;
|
||||
"Recursive calls will be at 1 greater depth")
|
||||
(\CKPOSBOUT STREAM (CHARCODE %())
|
||||
LP [COND
|
||||
((AND CDRCNT (IGREATERP (add CDRCNT 1)
|
||||
*PRINT-LENGTH*)) (* ;
|
||||
"have printed as many elements as allowed")
|
||||
*PRINT-LENGTH*)) (* ;
|
||||
"have printed as many elements as allowed")
|
||||
(\ELIDE.PRINT.TAIL STREAM T))
|
||||
(T (\PRINDATUM (CAR OBJECT)
|
||||
STREAM CPL)
|
||||
(COND
|
||||
((LISTP (SETQ OBJECT (CDR OBJECT)))
|
||||
(\CKPOSBOUT STREAM (CHARCODE SPACE))
|
||||
(if (AND *PRINT-CIRCLE-HASHTABLE* (PRINT-CIRCLE-LABEL-P OBJECT
|
||||
))
|
||||
then (* ; "Must print as a dotted tail")
|
||||
(\CKPOSSOUT STREAM ". ")
|
||||
(\PRINDATUM OBJECT STREAM CPL)
|
||||
(if (AND *PRINT-CIRCLE-HASHTABLE* (PRINT-CIRCLE-LABEL-P OBJECT))
|
||||
then (* ; "Must print as a dotted tail")
|
||||
(\CKPOSSOUT STREAM ". ")
|
||||
(\PRINDATUM OBJECT STREAM CPL)
|
||||
else (GO LP)))
|
||||
(OBJECT (* ; "Dotted tail")
|
||||
(OBJECT (* ; "Dotted tail")
|
||||
(\CKPOSSOUT STREAM " . ")
|
||||
(\PRINDATUM OBJECT STREAM]
|
||||
(\CKPOSBOUT STREAM (CHARCODE ")"])
|
||||
@@ -1193,20 +1196,18 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS .SPACECHECK. MACRO ((STRM N)
|
||||
(AND \THISFILELINELENGTH (IGREATERP (IPLUS N
|
||||
(fetch
|
||||
CHARPOSITION
|
||||
of STRM))
|
||||
\THISFILELINELENGTH)
|
||||
(FRESHLINE STRM))))
|
||||
(AND \THISFILELINELENGTH (IGREATERP (IPLUS N (fetch CHARPOSITION
|
||||
of STRM))
|
||||
\THISFILELINELENGTH)
|
||||
(FRESHLINE STRM))))
|
||||
|
||||
(PUTPROPS \CHECKRADIX MACRO [LAMBDA (R)
|
||||
(COND
|
||||
((OR (NOT (SMALLP R))
|
||||
(ILESSP R 1)
|
||||
(IGREATERP R 36))
|
||||
(\INVALID.RADIX R))
|
||||
(T R])
|
||||
(COND
|
||||
((OR (NOT (SMALLP R))
|
||||
(ILESSP R 1)
|
||||
(IGREATERP R 36))
|
||||
(\INVALID.RADIX R))
|
||||
(T R])
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
@@ -1280,8 +1281,8 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PNAMESTREAMP DMACRO ((STRM)
|
||||
(EQ (fetch (STREAM DEVICE) of STRM)
|
||||
\PNAMEDEVICE)))
|
||||
(EQ (fetch (STREAM DEVICE) of STRM)
|
||||
\PNAMEDEVICE)))
|
||||
)
|
||||
)
|
||||
|
||||
@@ -1312,8 +1313,8 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DOCOPY
|
||||
|
||||
(ADDTOVAR SYSSPECVARS *PRINT-BASE* *READ-BASE* *PRINT-RADIX* *PRINT-ESCAPE* *PRINT-CASE*
|
||||
*PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-PRETTY*
|
||||
*PRINT-CIRCLE* *PRINT-ARRAY* *PACKAGE*)
|
||||
*PRINT-GENSYM* *PRINT-LEVEL* *PRINT-LENGTH* *PRINT-PRETTY* *PRINT-CIRCLE*
|
||||
*PRINT-ARRAY* *PACKAGE*)
|
||||
)
|
||||
|
||||
|
||||
@@ -1455,6 +1456,8 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(RPAQ? NILNUMPRINTFLG )
|
||||
|
||||
(PUTPROPS APRINT FILETYPE TCOMPL)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(LOCALVARS . T)
|
||||
@@ -1471,22 +1474,21 @@ Copyright (c) 1982-1988, 1990-1991, 2020-2021 by Venue & Xerox Corporation.
|
||||
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(PUTPROPS APRINT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991
|
||||
2020 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3743 13280 (PRIN1 3753 . 5238) (PRIN2 5240 . 6433) (PRIN3 6435 . 7469) (PRIN4 7471 .
|
||||
8654) (PRINT 8656 . 8892) (PRINTCCODE 8894 . 9167) (\PRINTCCODE 9169 . 9638) (PRINTLEVEL 9640 . 10346)
|
||||
(RADIX 10348 . 10530) (SPACES 10532 . 10878) (TERPRI 10880 . 11065) (FRESHLINE 11067 . 11744) (
|
||||
DEFPRINT 11746 . 12318) (LINELENGTH 12320 . 13278)) (13942 18274 (PRINT-CIRCLE-LOOKUP 13952 . 15118) (
|
||||
PRINT-CIRCLE-LABEL-P 15120 . 15596) (PRINT-CIRCLE-SCAN 15598 . 17560) (PRINT-CIRCLE-ENTER 17562 .
|
||||
18272)) (18275 62434 (\PRINDATUM 18285 . 21227) (\PRINT-USING-DEFPRINT 21229 . 22601) (
|
||||
\PRINT-USING-ADDRESS 22603 . 23579) (\ELIDE.PRINT.ELEMENT 23581 . 23751) (\ELIDE.ELEMENT.CHAR 23753 .
|
||||
24036) (\ELIDE.PRINT.TAIL 24038 . 24462) (\ELIDE.TAIL.STRING 24464 . 24685) (\CKPOSBOUT 24687 . 24852)
|
||||
(\CKPOSSOUT 24854 . 25068) (\CONVERTNUMBER 25070 . 29559) (\LITPRIN 29561 . 36096) (\LITPRIN.INTERNAL
|
||||
36098 . 44453) (\SYMBOL.ESCAPE.COUNT 44455 . 51223) (\NUMERIC.PNAMEP 51225 . 57808) (\PRINSTACKP
|
||||
57810 . 59115) (\PRINTADDR 59117 . 60214) (\PRINSTRING 60216 . 61712) (\SOUT 61714 . 62432)) (67877
|
||||
68045 (\INVALID.RADIX 67887 . 68043)) (68149 70224 (\MAPPNAME 68159 . 69154) (\MAPPNAME.INTERNAL 69156
|
||||
. 69867) (PNAMESTREAMP 69869 . 70222)) (70907 71295 (\MAPCHARS 70917 . 71293)) (71626 78665 (PRINTNUM
|
||||
71636 . 74693) (FLTFMT 74695 . 75085) (\CHECKFLTFMT 75087 . 75655) (PRINTNUM-TO-STRING 75657 . 78663)
|
||||
))))
|
||||
(FILEMAP (NIL (3664 13201 (PRIN1 3674 . 5159) (PRIN2 5161 . 6354) (PRIN3 6356 . 7390) (PRIN4 7392 .
|
||||
8575) (PRINT 8577 . 8813) (PRINTCCODE 8815 . 9088) (\PRINTCCODE 9090 . 9559) (PRINTLEVEL 9561 . 10267)
|
||||
(RADIX 10269 . 10451) (SPACES 10453 . 10799) (TERPRI 10801 . 10986) (FRESHLINE 10988 . 11665) (
|
||||
DEFPRINT 11667 . 12239) (LINELENGTH 12241 . 13199)) (13863 18195 (PRINT-CIRCLE-LOOKUP 13873 . 15039) (
|
||||
PRINT-CIRCLE-LABEL-P 15041 . 15517) (PRINT-CIRCLE-SCAN 15519 . 17481) (PRINT-CIRCLE-ENTER 17483 .
|
||||
18193)) (18196 18426 (OCTALSTRING 18206 . 18424)) (18427 62586 (\PRINDATUM 18437 . 21379) (
|
||||
\PRINT-USING-DEFPRINT 21381 . 22753) (\PRINT-USING-ADDRESS 22755 . 23731) (\ELIDE.PRINT.ELEMENT 23733
|
||||
. 23903) (\ELIDE.ELEMENT.CHAR 23905 . 24188) (\ELIDE.PRINT.TAIL 24190 . 24614) (\ELIDE.TAIL.STRING
|
||||
24616 . 24837) (\CKPOSBOUT 24839 . 25004) (\CKPOSSOUT 25006 . 25220) (\CONVERTNUMBER 25222 . 29711) (
|
||||
\LITPRIN 29713 . 36248) (\LITPRIN.INTERNAL 36250 . 44605) (\SYMBOL.ESCAPE.COUNT 44607 . 51375) (
|
||||
\NUMERIC.PNAMEP 51377 . 57960) (\PRINSTACKP 57962 . 59267) (\PRINTADDR 59269 . 60366) (\PRINSTRING
|
||||
60368 . 61864) (\SOUT 61866 . 62584)) (63167 66808 (\PRINDATUM-LISTP 63167 . 66808)) (67634 67802 (
|
||||
\INVALID.RADIX 67644 . 67800)) (67906 69981 (\MAPPNAME 67916 . 68911) (\MAPPNAME.INTERNAL 68913 .
|
||||
69624) (PNAMESTREAMP 69626 . 69979)) (70648 71036 (\MAPCHARS 70658 . 71034)) (71358 78397 (PRINTNUM
|
||||
71368 . 74425) (FLTFMT 74427 . 74817) (\CHECKFLTFMT 74819 . 75387) (PRINTNUM-TO-STRING 75389 . 78395))
|
||||
)))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "24-Apr-2025 08:43:01" {WMEDLEY}<sources>EXTERNALFORMAT.;91 38905
|
||||
(FILECREATED "29-Jan-2026 21:09:02" {WMEDLEY}<sources>EXTERNALFORMAT.;92 39722
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS EXTERNALFORMATCOMS)
|
||||
:CHANGES-TO (FNS \EXTERNALFORMAT)
|
||||
|
||||
:PREVIOUS-DATE "19-Mar-2024 18:24:39" {WMEDLEY}<sources>EXTERNALFORMAT.;90)
|
||||
:PREVIOUS-DATE "24-Apr-2025 08:43:01" {WMEDLEY}<sources>EXTERNALFORMAT.;91)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT EXTERNALFORMATCOMS)
|
||||
@@ -131,7 +131,11 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\EXTERNALFORMAT
|
||||
[LAMBDA (STREAM NEWFORMAT/NAME)
|
||||
[LAMBDA (STREAM NEWFORMAT/NAME CREATING) (* ; "Edited 29-Jan-2026 21:05 by rmk")
|
||||
|
||||
(* ;; "CREATING is T from STREAM declaration, tries to not override the fields that are specified in the create expression")
|
||||
|
||||
(* ;; "Edited 29-Jan-2026 21:01 by rmk")
|
||||
|
||||
(* ;; "Edited 2-Jul-2022 19:17 by rmk: Fast case: NEWFORMAT/NAME is an external format")
|
||||
|
||||
@@ -177,14 +181,20 @@
|
||||
(CL:WHEN (ffetch (EXTERNALFORMAT EOLVALID) of EXTFORMAT)
|
||||
(freplace (STREAM EOLCONVENTION) of STREAM with (ffetch (EXTERNALFORMAT EOL)
|
||||
of EXTFORMAT)))
|
||||
(freplace (STREAM OUTCHARFN) of STREAM with (ffetch (EXTERNALFORMAT OUTCHARFN)
|
||||
of EXTFORMAT))
|
||||
(freplace (STREAM INCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT INCCODEFN)
|
||||
of EXTFORMAT))
|
||||
(freplace (STREAM PEEKCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT PEEKCCODEFN)
|
||||
of EXTFORMAT))
|
||||
(freplace (STREAM BACKCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT BACKCCODEFN)
|
||||
of EXTFORMAT)))])
|
||||
(CL:UNLESS (AND CREATING (ffetch (STREAM OUTCHARFN) of STREAM))
|
||||
(freplace (STREAM OUTCHARFN) of STREAM with (ffetch (EXTERNALFORMAT OUTCHARFN)
|
||||
of EXTFORMAT)))
|
||||
(CL:UNLESS (AND CREATING (ffetch (STREAM INCCODEFN) of STREAM))
|
||||
(freplace (STREAM INCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT INCCODEFN)
|
||||
of EXTFORMAT)))
|
||||
(CL:UNLESS (AND CREATING (ffetch (STREAM PEEKCCODEFN) of STREAM))
|
||||
(freplace (STREAM PEEKCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT
|
||||
PEEKCCODEFN)
|
||||
of EXTFORMAT)))
|
||||
(CL:UNLESS (AND CREATING (ffetch (STREAM BACKCCODEFN) of STREAM))
|
||||
(freplace (STREAM BACKCCODEFN) of STREAM with (ffetch (EXTERNALFORMAT
|
||||
BACKCCODEFN)
|
||||
of EXTFORMAT))))])
|
||||
(ffetch (EXTERNALFORMAT NAME) of (fetch (STREAM EXTERNALFORMAT) of STREAM])
|
||||
|
||||
(MAKE-EXTERNALFORMAT
|
||||
@@ -737,13 +747,13 @@
|
||||
(\CREATE.THROUGH.EXTERNALFORMAT)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (6710 13543 (\EXTERNALFORMAT 6720 . 10498) (MAKE-EXTERNALFORMAT 10500 . 13070) (
|
||||
\EXTERNALFORMAT.DEFPRINT 13072 . 13541)) (13544 16585 (\INSTALL.EXTERNALFORMAT 13554 . 15003) (
|
||||
\REMOVE.EXTERNALFORMAT 15005 . 15836) (FIND-FORMAT 15838 . 16583)) (16586 16998 (SYSTEM-EXTERNALFORMAT
|
||||
16596 . 16996)) (17347 33324 (\OUTCHAR 17357 . 18574) (\INCCODE 18576 . 19729) (\BACKCCODE 19731 .
|
||||
21410) (\BACKCCODE.EOLC 21412 . 23602) (\PEEKCCODE 23604 . 23929) (\PEEKCCODE.EOLC 23931 . 24310) (
|
||||
\INCCODE.EOLC 24312 . 26111) (\FORMATBYTESTREAM 26113 . 28557) (\FORMATBYTESTRING 28559 . 30259) (
|
||||
\CHECKEOLC.CRLF 30261 . 33322)) (34606 36842 (\NULLDEVICE 34616 . 36518) (\NULL.OPENFILE 36520 . 36840
|
||||
)) (36982 38809 (\CREATE.THROUGH.EXTERNALFORMAT 36992 . 37778) (\THROUGHIN 37780 . 38200) (
|
||||
\THROUGHBACKCCODE 38202 . 38469) (\THROUGHOUTCHARFN 38471 . 38807)))))
|
||||
(FILEMAP (NIL (6706 14360 (\EXTERNALFORMAT 6716 . 11315) (MAKE-EXTERNALFORMAT 11317 . 13887) (
|
||||
\EXTERNALFORMAT.DEFPRINT 13889 . 14358)) (14361 17402 (\INSTALL.EXTERNALFORMAT 14371 . 15820) (
|
||||
\REMOVE.EXTERNALFORMAT 15822 . 16653) (FIND-FORMAT 16655 . 17400)) (17403 17815 (SYSTEM-EXTERNALFORMAT
|
||||
17413 . 17813)) (18164 34141 (\OUTCHAR 18174 . 19391) (\INCCODE 19393 . 20546) (\BACKCCODE 20548 .
|
||||
22227) (\BACKCCODE.EOLC 22229 . 24419) (\PEEKCCODE 24421 . 24746) (\PEEKCCODE.EOLC 24748 . 25127) (
|
||||
\INCCODE.EOLC 25129 . 26928) (\FORMATBYTESTREAM 26930 . 29374) (\FORMATBYTESTRING 29376 . 31076) (
|
||||
\CHECKEOLC.CRLF 31078 . 34139)) (35423 37659 (\NULLDEVICE 35433 . 37335) (\NULL.OPENFILE 37337 . 37657
|
||||
)) (37799 39626 (\CREATE.THROUGH.EXTERNALFORMAT 37809 . 38595) (\THROUGHIN 38597 . 39017) (
|
||||
\THROUGHBACKCCODE 39019 . 39286) (\THROUGHOUTCHARFN 39288 . 39624)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
459
sources/FONT
459
sources/FONT
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "31-Dec-2025 22:41:44" {WMEDLEY}<sources>FONT.;655 285234
|
||||
(FILECREATED "26-Jan-2026 16:37:58" {WMEDLEY}<sources>FONT.;664 276319
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS FONTCOMS)
|
||||
(FNS \CREATEFONT FONTPROP)
|
||||
|
||||
:PREVIOUS-DATE "25-Dec-2025 10:58:30" {WMEDLEY}<sources>FONT.;654)
|
||||
:PREVIOUS-DATE "22-Jan-2026 14:25:36" {WMEDLEY}<sources>FONT.;659)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT FONTCOMS)
|
||||
@@ -46,16 +47,7 @@
|
||||
(FNS MOVECHARBITMAP MOVEFONTCHARS \MOVEFONTCHAR \MOVEFONTCHARS.SOURCEDATA \MAKESLUGCHAR
|
||||
SLUGCHARP.DISPLAY)
|
||||
(MACROS UPDATEINFOELEMENT))
|
||||
(COMS
|
||||
(* ;; "\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories. That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places. ")
|
||||
|
||||
(FNS FONTFILES \FINDFONTFILE \FONTFILENAMES \FONTFILENAME \FONTFILENAME.OLD
|
||||
\FONTFILENAME.NEW FONTSPECFROMFILENAME \FONTINFOFROMFILENAME.OLD)
|
||||
(* (* ; "Do we still want old fonts?")
|
||||
(ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE)))
|
||||
(INITVARS (*OLD-FONT-EXTENSIONS* NIL))
|
||||
(INITVARS (*USEOLDFONTDIRECTORIES* NIL))
|
||||
(GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*))
|
||||
(FNS FONTFILES \FINDFONTFILE \FONTFILENAMES \FONTFILENAME FONTSPECFROMFILENAME)
|
||||
(FNS FONTCOPY FONTP FONTUNPARSE SETFONTDESCRIPTOR \STREAMCHARWIDTH \COERCECHARSET
|
||||
\BUILDSLUGCSINFO \FONTSYMBOL \DEVICESYMBOL \FONTFACE \FONTFACE.COLOR SETFONTCHARENCODING
|
||||
)
|
||||
@@ -1179,7 +1171,8 @@
|
||||
(fetch (FONTDESCRIPTOR \SFHeight) of (FONTCREATE FONTSPEC])
|
||||
|
||||
(FONTPROP
|
||||
[LAMBDA (FONT PROP) (* ; "Edited 2-Dec-2025 16:01 by rmk")
|
||||
[LAMBDA (FONT PROP) (* ; "Edited 25-Jan-2026 20:08 by rmk")
|
||||
(* ; "Edited 2-Dec-2025 16:01 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 22:21 by rmk")
|
||||
(* ; "Edited 12-Aug-2025 21:10 by rmk")
|
||||
(* ; "Edited 10-Aug-2025 13:28 by rmk")
|
||||
@@ -1256,6 +1249,7 @@
|
||||
\MAXCHARSET
|
||||
eachtime (SETQ CSINFO (\GETBASEPTR CSVECTOR (UNFOLD CS 2))) when CSINFO
|
||||
unless (fetch (CHARSETINFO CSSLUGP) of CSINFO) collect CS))
|
||||
(AVGCHARWIDTH (ffetch (FONTDESCRIPTOR FONTAVGCHARWIDTH) of FONT))
|
||||
(FONTTOMCCSFN (ffetch FONTTOMCCSFN of FONT))
|
||||
(\ILLEGAL.ARG PROP])
|
||||
|
||||
@@ -1820,13 +1814,6 @@
|
||||
(freplace (CHARSETINFO FIELD) of DCSINFO with DBLOCK))
|
||||
(\FSETWIDTH DBLOCK DTHINCODE NEWVAL))])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"\FINDFONTFILE \FONTFILENAME \SEARCHFONTFILES \FONTINFOFROMFILENAME are redefined to deal with character-set directories. That behavior is conditioned on the setting of the global variable *USEOLDFONTDIRECTORIES*, T at PARC, maybe NIL most other places. "
|
||||
)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(FONTFILES
|
||||
@@ -1853,6 +1840,7 @@
|
||||
|
||||
(\FINDFONTFILE
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE CHARSET DIRLST EXTLST)
|
||||
(* ; "Edited 22-Jan-2026 08:54 by rmk")
|
||||
(* ; "Edited 3-Dec-2025 23:38 by rmk")
|
||||
(* ; "Edited 9-Jun-2025 09:40 by rmk")
|
||||
(* ; "Edited 15-May-2025 22:41 by rmk")
|
||||
@@ -1864,13 +1852,9 @@
|
||||
(CL:UNLESS DIRLST
|
||||
(SETQ DIRLST (CONS NIL)))
|
||||
|
||||
(* ;; "Find any font file on any directory with any naming convention with any extension. Note that ROTATION and DEVICE are just place holders. DEVICE is irrelevant because DIRLST already incorporates the device information. The variable *OLD-FONT-EXTENSIONS* can be set to suppress using the old-style lookup. If set to a list of extensions, just those will be looked up with old-style conventions.")
|
||||
(* ;; "Find any font file on any directory with any naming convention with any extension. Note that ROTATION and DEVICE are just place holders. DEVICE is irrelevant because DIRLST already incorporates the device information. ")
|
||||
|
||||
(for EXT FONTFILE inside EXTLST join (SETQ FONTFILE (if (FMEMB EXT *OLD-FONT-EXTENSIONS*)
|
||||
then (\FONTFILENAME.OLD FAMILY SIZE FACE
|
||||
EXT CHARSET)
|
||||
else (\FONTFILENAME FAMILY SIZE FACE EXT
|
||||
CHARSET)))
|
||||
(for EXT FONTFILE inside EXTLST join (SETQ FONTFILE (\FONTFILENAME FAMILY SIZE FACE EXT CHARSET))
|
||||
(for DIR FOUND inside DIRLST
|
||||
when (SETQ FOUND (INFILEP (PACKFILENAME.STRING
|
||||
'DIRECTORY DIR 'BODY FONTFILE)
|
||||
@@ -1883,165 +1867,61 @@
|
||||
(RETURN (CAR $$VAL)))])
|
||||
|
||||
(\FONTFILENAMES
|
||||
[LAMBDA (FAMILY SIZE FACE DEVICE EXTENSIONS) (* ; "Edited 7-Oct-2025 12:21 by rmk")
|
||||
[LAMBDA (FAMILY SIZE FACE DEVICE EXTENSIONS) (* ; "Edited 22-Jan-2026 09:01 by rmk")
|
||||
(* ; "Edited 7-Oct-2025 12:21 by rmk")
|
||||
(* ; "Edited 17-May-2025 12:15 by rmk")
|
||||
(APPEND [for EXT inside EXTENSIONS collect (IF (FMEMB EXT *OLD-FONT-EXTENSIONS*)
|
||||
THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT
|
||||
'NOCHARSET)
|
||||
ELSE (\FONTFILENAME FAMILY SIZE FACE EXT
|
||||
'NOCHARSET]
|
||||
(for EXT inside EXTENSIONS collect (IF (FMEMB EXT *OLD-FONT-EXTENSIONS*)
|
||||
THEN (\FONTFILENAME.OLD FAMILY SIZE FACE EXT 0)
|
||||
ELSE (\FONTFILENAME FAMILY SIZE FACE EXT 0])
|
||||
(APPEND (for EXT inside EXTENSIONS collect (\FONTFILENAME FAMILY SIZE FACE EXT 'NOCHARSET))
|
||||
(for EXT inside EXTENSIONS collect (\FONTFILENAME FAMILY SIZE FACE EXT 0])
|
||||
|
||||
(\FONTFILENAME
|
||||
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 11-Jul-2025 09:39 by rmk")
|
||||
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 22-Jan-2026 14:25 by rmk")
|
||||
(* ; "Edited 11-Jul-2025 09:39 by rmk")
|
||||
(* ; "Edited 15-May-2025 15:51 by rmk")
|
||||
(* ; "Edited 5-Mar-93 16:10 by rmk:")
|
||||
|
||||
(* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported. New name is of the form %"familysize-face-Ccharset.ext%", e.g., MODERN12-MRR-C357.WD")
|
||||
|
||||
(* ;; "**bvm 10/5/89 Slight change: partition fonts into subdirectories by charset, e.g., all Charset zero fonts are in subdirectory C0>. This significantly speeds up any font operation that requires any local directory work (e.g., NFS servers on both Sun and D machine), and FONTSAVAILABLE on any device (since it doesn't have to wade thru all those charsets). This behavior is conditioned on the value of *USEOLDFONTDIRECTORIES*")
|
||||
(* ;; "FAMILY can be a FONTSPEC")
|
||||
|
||||
(DECLARE (SPECVARS FAMILY SIZE FACE))
|
||||
(SETQ FACE (\FONTFACE FACE)) (* ; "Validate face")
|
||||
(LET* ([SIZEPATT (COND
|
||||
((EQ SIZE '*)
|
||||
SIZE)
|
||||
((FIXP SIZE)
|
||||
(if (< SIZE 10)
|
||||
then (CONCAT 0 SIZE)
|
||||
else SIZE))
|
||||
(T (\ILLEGAL.ARG SIZE]
|
||||
(CSETNAME (COND
|
||||
((OR (NULL CHARSET)
|
||||
(EQ CHARSET 0)) (* ; "Charset defaults to zero.")
|
||||
"0")
|
||||
((FIXP CHARSET)
|
||||
(LET ((*PRINT-BASE* 8)
|
||||
(*PRINT-RADIX* NIL)) (* ; "Longhand for (cl:write-to-string charset :radix nil :base 8), which is twice as slow, due to lousy keyword handling")
|
||||
(\PRINDATUM.TO.STRING CHARSET)))
|
||||
((EQ CHARSET 'NOCHARSET) (* ; "Don't want the charset indicated")
|
||||
NIL)
|
||||
(T (* ; "Somebody made the string already?")
|
||||
CHARSET)))
|
||||
[FACESPEC (LIST (CHCON1 (fetch (FONTFACE WEIGHT) of FACE))
|
||||
(CHCON1 (fetch (FONTFACE SLOPE) of FACE))
|
||||
(CHCON1 (fetch (FONTFACE EXPANSION) of FACE]
|
||||
(TAIL FACESPEC))
|
||||
[if (OR (EQ (CAR TAIL)
|
||||
(CHARCODE *))
|
||||
(EQ (CAR (SETQ TAIL (CDR TAIL)))
|
||||
(CHARCODE *)))
|
||||
then (* ;
|
||||
"Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower.")
|
||||
(while (EQ (CADR TAIL)
|
||||
(CHARCODE *)) do (RPLACD TAIL (CDDR TAIL]
|
||||
(LET (ROTATION DEVICE SIZEPATT CSETNAME FACESPEC STARPOS FILENAME)
|
||||
(DECLARE (SPECVARS ROTATION DEVICE))
|
||||
(CL:WHEN (type? FONTSPEC FAMILY)
|
||||
(SPREADFONTSPEC FAMILY))
|
||||
(SETQ SIZEPATT (CL:IF (OR (EQ SIZE '*)
|
||||
(>= SIZE 10))
|
||||
SIZE
|
||||
(CONCAT "0" SIZE)))
|
||||
(SETQ CSETNAME (if (FIXP CHARSET)
|
||||
then (OCTALSTRING CHARSET)
|
||||
elseif (MEMB CHARSET '(NIL NOCHARSET))
|
||||
then (* ; "Don't want the charset indicated")
|
||||
NIL
|
||||
else (* ; "Somebody made the string already?")
|
||||
CHARSET))
|
||||
|
||||
(* ;; "Fortunately, CONCAT ignores packages.")
|
||||
(* ;; "Fortunately, PACKFILENAME ignores packages")
|
||||
|
||||
(PACKFILENAME.STRING 'NAME (CONCAT (if *USEOLDFONTDIRECTORIES*
|
||||
then ""
|
||||
elseif CSETNAME
|
||||
then (CONCAT (PROGN
|
||||
(* ;
|
||||
"Lowercase because it's in a directory name, so maybe Unix will find it sooner?")
|
||||
"c")
|
||||
CSETNAME ">")
|
||||
else "")
|
||||
FAMILY SIZEPATT "-" (CONCATCODES FACESPEC)
|
||||
(CL:IF CSETNAME
|
||||
(CONCAT "-C" CSETNAME)
|
||||
""))
|
||||
'EXTENSION EXTENSION])
|
||||
(SETQ FILENAME (PACKFILENAME.STRING 'NAME (CONCAT (CL:IF CSETNAME
|
||||
(CONCAT "c" CSETNAME ">")
|
||||
"")
|
||||
FAMILY SIZEPATT "-" (FONTFACETOATOM FACE)
|
||||
(CL:IF CSETNAME
|
||||
(CONCAT "-C" CSETNAME)
|
||||
""))
|
||||
'EXTENSION EXTENSION))
|
||||
|
||||
(\FONTFILENAME.OLD
|
||||
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 23-Sep-92 18:22 by jds")
|
||||
(* ;;
|
||||
" Avoid adjacent wildcards because some devices (notably old DSK) get exponentially slower.")
|
||||
|
||||
(* ;; "Returns old style font file names. They were ambiguous because you could not ask for e.g. FACE (MEDIUM * REGULAR) because it maps to FamilySize-*-Charset, which also matches (BOLD * COMPRESSED), etc. Keep this function around though for user's who don't rename their files.")
|
||||
(* ;
|
||||
"Returns the name of the file that should contain the information for a font.")
|
||||
(SETQ FACE (\FONTFACE FACE)) (* ; "Force legal canonical face")
|
||||
(SETQ FACE (COND
|
||||
((AND (EQ (CAR FACE)
|
||||
'*)
|
||||
(EQ (CADR FACE)
|
||||
'*))
|
||||
|
||||
(* ;; "Avoid adjacent wildcards because DSK gets slower exponentially (can take loooong tiiiiiime). No need to check compression.")
|
||||
|
||||
'*)
|
||||
(T FACE)))
|
||||
(PACKFILENAME.STRING 'NAME [PROGN
|
||||
(* ;; "DISPLAYFONT AC WD and the default case")
|
||||
|
||||
(CONCAT (CDR (SASSOC FAMILY *DISPLAY-FONT-NAME-MAP*))
|
||||
(COND
|
||||
((EQ SIZE '*)
|
||||
SIZE)
|
||||
((FIXP SIZE)
|
||||
(COND
|
||||
((< SIZE 10)
|
||||
(CONCAT 0 SIZE))
|
||||
(T SIZE)))
|
||||
(T (\ILLEGAL.ARG SIZE)))
|
||||
[COND
|
||||
((EQ FACE '*)
|
||||
'*)
|
||||
(T (SELECTQ (fetch WEIGHT of FACE)
|
||||
(BOLD (SELECTQ (fetch SLOPE of FACE)
|
||||
(ITALIC "D")
|
||||
"B"))
|
||||
(SELECTQ (fetch SLOPE of FACE)
|
||||
(ITALIC "I")
|
||||
"R"]
|
||||
(COND
|
||||
((FIXP CHARSET)
|
||||
(LET ((*PRINT-BASE* 8))
|
||||
(CL:FORMAT NIL "~O" CHARSET)))
|
||||
(T "000"]
|
||||
'EXTENSION EXTENSION])
|
||||
|
||||
(\FONTFILENAME.NEW
|
||||
[LAMBDA (FAMILY SIZE FACE EXTENSION CHARSET) (* ; "Edited 30-Mar-87 20:00 by FS")
|
||||
|
||||
(* ;; "Strike file naming convention (w/o dashes, no charset) no longer supported.")
|
||||
|
||||
(LET (NAME SIZEPATT)
|
||||
(SETQ FACE (\FONTFACE FACE)) (* ; "Validate face")
|
||||
[SETQ SIZEPATT (COND
|
||||
((EQ SIZE '*)
|
||||
SIZE)
|
||||
((FIXP SIZE)
|
||||
(if (< SIZE 10)
|
||||
then (CONCAT 0 SIZE)
|
||||
else SIZE))
|
||||
(T (\ILLEGAL.ARG SIZE]
|
||||
|
||||
(* ;; "Avoid adjacent wildcards because some devices (notably DSK) get exponentially slower. Nicely, PACK & CONCAT ignore packages.")
|
||||
|
||||
(PACKFILENAME.STRING 'NAME (CONCAT FAMILY SIZEPATT "-"
|
||||
[COND
|
||||
((EQUAL FACE '
|
||||
|
||||
(* * *)
|
||||
)
|
||||
'*)
|
||||
(T (CONCAT (NTHCHAR (fetch (FONTFACE WEIGHT)
|
||||
of FACE)
|
||||
1)
|
||||
(NTHCHAR (fetch (FONTFACE SLOPE)
|
||||
of FACE)
|
||||
1)
|
||||
(NTHCHAR (fetch (FONTFACE EXPANSION)
|
||||
of FACE)
|
||||
1]
|
||||
(COND
|
||||
[(FIXP CHARSET)
|
||||
(LET ((*PRINT-BASE* 8))
|
||||
(CONCAT "-C" (\PRINDATUM.TO.STRING CHARSET]
|
||||
(CHARSET (CONCAT "-C" CHARSET))
|
||||
(T "-C0")))
|
||||
'EXTENSION EXTENSION])
|
||||
(CL:IF (STRPOS "**" FILENAME)
|
||||
(CONCATCODES (for I C from 1 while (SETQ C (NTHCHARCODE FILENAME I))
|
||||
unless [AND (EQ (CHARCODE *)
|
||||
C)
|
||||
(EQ (CHARCODE *)
|
||||
(NTHCHARCODE FILENAME (ADD1 I] collect C))
|
||||
FILENAME)])
|
||||
|
||||
(FONTSPECFROMFILENAME
|
||||
[LAMBDA (FONTFILE DEVICE) (* ; "Edited 23-Nov-2025 21:42 by rmk")
|
||||
@@ -2120,56 +2000,6 @@
|
||||
FSFACE _ FACE
|
||||
FSROTATION _ 0
|
||||
FSDEVICE _ DEVICE])
|
||||
|
||||
(\FONTINFOFROMFILENAME.OLD
|
||||
[LAMBDA (FONTFILE DEVICE) (* ; "Edited 1-Jan-87 01:29 by FS")
|
||||
|
||||
(* ;; "returns a list of the family size face rotation device of the font stored in the file name FONTFILE.")
|
||||
|
||||
(PROG ((FILENAMELIST (UNPACKFILENAME FONTFILE))
|
||||
SIZEBEG SIZEND NAME FAMILY SIZE)
|
||||
(SETQ NAME (LISTGET FILENAMELIST 'NAME)) (* ;
|
||||
"find where the name and size are.")
|
||||
(SETQ SIZEBEG (for CH# from 1 when (NUMBERP (NTHCHAR NAME CH#))
|
||||
do (RETURN CH#)))
|
||||
[SETQ FAMILY (MKATOM (SUBSTRING NAME 1 (SUB1 SIZEBEG]
|
||||
(SETQ SIZEND (for CH# from SIZEBEG when (NOT (NUMBERP (NTHCHAR NAME CH#)))
|
||||
do (RETURN CH#)))
|
||||
[SETQ SIZE (MKATOM (SUBSTRING NAME SIZEBEG (SUB1 SIZEND]
|
||||
(RETURN (LIST FAMILY SIZE (SELECTQ (LISTGET FILENAMELIST 'EXTENSION)
|
||||
((DISPLAYFONT AC WD)
|
||||
(LIST (COND
|
||||
((STRPOS "-B" NAME SIZEND NIL T)
|
||||
'BOLD)
|
||||
(T 'MEDIUM))
|
||||
(COND
|
||||
((STRPOS "-I" NAME SIZEND NIL)
|
||||
'ITALIC)
|
||||
(T 'REGULAR))
|
||||
'REGULAR))
|
||||
(LIST (COND
|
||||
((STRPOS "B" NAME SIZEND NIL T)
|
||||
'BOLD)
|
||||
(T 'MEDIUM))
|
||||
(COND
|
||||
((STRPOS "I" NAME SIZEND NIL)
|
||||
'ITALIC)
|
||||
(T 'REGULAR))
|
||||
'REGULAR))
|
||||
0 DEVICE])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* (* ; "Do we still want old fonts?") (ADDVARS (*OLD-FONT-EXTENSIONS* STRIKE)))
|
||||
|
||||
|
||||
(RPAQ? *OLD-FONT-EXTENSIONS* NIL)
|
||||
|
||||
(RPAQ? *USEOLDFONTDIRECTORIES* NIL)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *OLD-FONT-EXTENSIONS* *USEOLDFONTDIRECTORIES*)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -2839,7 +2669,8 @@
|
||||
then FILEFONTS)))])
|
||||
|
||||
(FONTEXISTS?
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOCOERCIONS) (* ; "Edited 18-Dec-2025 13:10 by rmk")
|
||||
[LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOCOERCIONS) (* ; "Edited 22-Jan-2026 09:07 by rmk")
|
||||
(* ; "Edited 18-Dec-2025 13:10 by rmk")
|
||||
(* ; "Edited 25-Nov-2025 20:18 by rmk")
|
||||
(* ; "Edited 26-Sep-2025 10:10 by rmk")
|
||||
(* ; "Edited 28-Aug-2025 22:16 by rmk")
|
||||
@@ -2876,7 +2707,7 @@
|
||||
(FUNCTION NILL))
|
||||
FONTSPEC)))
|
||||
(if VAL
|
||||
then (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC VAL |(QUOTE SASSOC)|)
|
||||
then (STOREMULTI \FONTEXISTS?-CACHE FONTSPEC VAL 'SASSOC)
|
||||
elseif [AND (NOT NOCOERCIONS)
|
||||
(SETQ VAL (COERCEFONTSPEC FONTSPEC (FONTDEVICEPROP DEVICE
|
||||
'FONTCOERCIONS]
|
||||
@@ -3099,37 +2930,38 @@
|
||||
COLOR _ COLOR])
|
||||
|
||||
(FONTFACETOATOM
|
||||
[LAMBDA (FACE NOERROR) (* ; "Edited 7-Sep-2025 09:19 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 08:45 by rmk")
|
||||
(if (type? FONTFACE FACE)
|
||||
then [PACK (LIST* (SELECTQ (fetch (FONTFACE WEIGHT) of FACE)
|
||||
(MEDIUM 'M)
|
||||
(BOLD 'B)
|
||||
(LIGHT 'L)
|
||||
(fetch (FONTFACE WEIGHT) of FACE))
|
||||
(SELECTQ (fetch (FONTFACE SLOPE) of FACE)
|
||||
(ITALIC 'I)
|
||||
(REGULAR 'R)
|
||||
(fetch (FONTFACE SLOPE) of FACE))
|
||||
(SELECTQ (fetch (FONTFACE EXPANSION) of FACE)
|
||||
(REGULAR 'R)
|
||||
(COMPRESSED 'C)
|
||||
(EXPANDED 'E)
|
||||
(fetch (FONTFACE EXPANSION) of FACE))
|
||||
(CL:WHEN (fetch (FONTFACE COLOR) of FACE)
|
||||
(LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE)
|
||||
"-"
|
||||
(fetch (FONTFACE FORECOLOR) of FACE)))]
|
||||
elseif (AND FACE (LITATOM FACE)
|
||||
(MEMB (NTHCHARCODE FACE 1)
|
||||
(CHARCODE M B L))
|
||||
(MEMB (NTHCHARCODE FACE 2)
|
||||
(CHARCODE I R))
|
||||
(MEMB (NTHCHARCODE FACE 3)
|
||||
(CHARCODE R C E)))
|
||||
then FACE
|
||||
elseif (NOT NOERROR)
|
||||
then (\ILLEGAL.ARG FACE])
|
||||
[LAMBDA (FACE NOERROR) (* ; "Edited 22-Jan-2026 08:13 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 09:19 by rmk")
|
||||
(LET (ATOM)
|
||||
(SETQ ATOM (if (type? FONTFACE FACE)
|
||||
then [PACK (LIST* (SELECTQ (fetch (FONTFACE WEIGHT) of FACE)
|
||||
(MEDIUM 'M)
|
||||
(BOLD 'B)
|
||||
(LIGHT 'L)
|
||||
(fetch (FONTFACE WEIGHT) of FACE))
|
||||
(SELECTQ (fetch (FONTFACE SLOPE) of FACE)
|
||||
(ITALIC 'I)
|
||||
(REGULAR 'R)
|
||||
(fetch (FONTFACE SLOPE) of FACE))
|
||||
(SELECTQ (fetch (FONTFACE EXPANSION) of FACE)
|
||||
(REGULAR 'R)
|
||||
(COMPRESSED 'C)
|
||||
(EXPANDED 'E)
|
||||
(fetch (FONTFACE EXPANSION) of FACE))
|
||||
(CL:WHEN (fetch (FONTFACE COLOR) of FACE)
|
||||
(LIST "-" (fetch (FONTFACE BACKCOLOR) of FACE)
|
||||
"-"
|
||||
(fetch (FONTFACE FORECOLOR) of FACE)))]
|
||||
elseif (AND FACE (LITATOM FACE)
|
||||
(MEMB (NTHCHARCODE FACE 1)
|
||||
(CHARCODE M B L *))
|
||||
(MEMB (NTHCHARCODE FACE 2)
|
||||
(CHARCODE I R *))
|
||||
(MEMB (NTHCHARCODE FACE 3)
|
||||
(CHARCODE R C E *)))
|
||||
then FACE
|
||||
elseif (NOT NOERROR)
|
||||
then (\ILLEGAL.ARG FACE])
|
||||
)
|
||||
|
||||
(RPAQ? \FONTSINCORE NIL)
|
||||
@@ -3253,7 +3085,8 @@
|
||||
OFFSETS _ (\CREATECSINFOELEMENT)
|
||||
CHARSETNO _ MAX.SMALLP)
|
||||
|
||||
(RECORD FONTSPEC (FSFAMILY FSSIZE FSFACE FSROTATION FSDEVICE))
|
||||
(RECORD FONTSPEC (FSFAMILY FSSIZE FSFACE FSROTATION FSDEVICE)
|
||||
(TYPE? LISTP))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'FONTCLASS '(BYTE POINTER POINTER POINTER POINTER POINTER)
|
||||
@@ -3620,7 +3453,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\CREATEFONT
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 25-Dec-2025 10:58 by rmk")
|
||||
[LAMBDA (FONTSPEC) (* ; "Edited 26-Jan-2026 15:24 by rmk")
|
||||
(* ; "Edited 25-Dec-2025 10:58 by rmk")
|
||||
(* ; "Edited 25-Sep-2025 21:24 by rmk")
|
||||
(* ; "Edited 28-Aug-2025 14:30 by rmk")
|
||||
(* ; "Edited 18-Aug-2025 00:17 by rmk")
|
||||
@@ -3636,18 +3470,28 @@
|
||||
(LET ([FN (CAR (GETMULTI IMAGESTREAMTYPES (fetch (FONTSPEC FSDEVICE) of FONTSPEC)
|
||||
'FONTCREATE]
|
||||
FONT)
|
||||
(CL:WHEN FN
|
||||
(SETQ FONT (if (EQ (NARGS FN)
|
||||
1)
|
||||
then (APPLY* FN FONTSPEC)
|
||||
else (* ; "Old form: spreading FONTSPEC")
|
||||
(APPLY FN FONTSPEC)))
|
||||
(CL:UNLESS FONT
|
||||
(CL:WHEN (SETQ FONTSPEC (COERCEFONTSPEC FONTSPEC))
|
||||
(SETQ FONT (if (EQ (NARGS FN)
|
||||
1)
|
||||
then (APPLY* FN FONTSPEC)
|
||||
else (APPLY FN FONTSPEC))))))
|
||||
[if FN
|
||||
then (SETQ FONT (if (EQ (NARGS FN)
|
||||
1)
|
||||
then (APPLY* FN FONTSPEC)
|
||||
else (* ; "Old form: spreading FONTSPEC")
|
||||
(APPLY FN FONTSPEC)))
|
||||
(CL:UNLESS FONT
|
||||
(CL:WHEN (SETQ FONTSPEC (COERCEFONTSPEC FONTSPEC))
|
||||
(SETQ FONT (if (EQ (NARGS FN)
|
||||
1)
|
||||
then (APPLY* FN FONTSPEC)
|
||||
else (APPLY FN FONTSPEC)))))
|
||||
else (SETQ FONT (create FONTDESCRIPTOR
|
||||
FONTFAMILY _ (fetch (FONTSPEC FSFAMILY) of FONTSPEC)
|
||||
FONTSIZE _ (fetch (FONTSPEC FSSIZE) of FONTSPEC)
|
||||
FONTFACE _ (fetch (FONTSPEC FSFACE) of FONTSPEC)
|
||||
ROTATION _ (fetch (FONTSPEC FSROTATION) of FONTSPEC)
|
||||
FONTDEVICE _ (fetch (FONTSPEC FSDEVICE) of FONTSPEC)
|
||||
\SFAscent _ 0
|
||||
\SFDescent _ 0
|
||||
\SFHeight _ 0
|
||||
FONTDEVICESPEC _ (create FONTSPEC using FONTSPEC]
|
||||
FONT])
|
||||
|
||||
(\CREATECHARSET
|
||||
@@ -4640,44 +4484,43 @@
|
||||
(ADDTOVAR LAMA FONTCOPY)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (12139 21852 (CHARWIDTH 12149 . 12934) (CHARWIDTHY 12936 . 14453) (STRINGWIDTH 14455 .
|
||||
15548) (\CHARWIDTH.DISPLAY 15550 . 15963) (\STRINGWIDTH.DISPLAY 15965 . 16389) (\STRINGWIDTH.GENERIC
|
||||
16391 . 21850)) (21853 28373 (DEFAULTFONT 21863 . 23148) (FONTCLASS 23150 . 25312) (FONTCLASSUNPARSE
|
||||
25314 . 26213) (FONTCLASSCOMPONENT 26215 . 26803) (SETFONTCLASSCOMPONENT 26805 . 27247) (
|
||||
GETFONTCLASSCOMPONENT 27249 . 28371)) (30086 47590 (FONTCREATE 30096 . 33341) (FONTCREATE1 33343 .
|
||||
35958) (FONTCREATE.SLUGFD 35960 . 37442) (\FONT.CHECKARGS1 37444 . 41967) (\FONTCREATE1.NOFN 41969 .
|
||||
42183) (FONTFILEP 42185 . 43073) (\READCHARSET 43075 . 47588)) (47591 54667 (\FONT.CHECKARGS 47601 .
|
||||
54350) (\CHARSET.CHECK 54352 . 54665)) (54668 61279 (COERCEFONTSPEC 54678 . 60590) (
|
||||
COERCEFONTSPEC.TARGETFACE 60592 . 61277)) (63474 64813 (MAKEFONTSPEC 63484 . 64811)) (64814 72991 (
|
||||
COMPLETE.FONT 64824 . 67347) (COMPLETEFONTP 67349 . 67972) (COMPLETE.CHARSET 67974 . 70659) (
|
||||
PRUNESLUGCSINFOS 70661 . 71586) (MONOSPACEFONTP 71588 . 72989)) (73030 81285 (FONTASCENT 73040 . 73424
|
||||
) (FONTDESCENT 73426 . 73911) (FONTHEIGHT 73913 . 74315) (FONTPROP 74317 . 80562) (\AVGCHARWIDTH 80564
|
||||
. 81283)) (81942 82850 (FONTDEVICEPROP 81952 . 82848)) (82896 83750 (EDITCHAR 82906 . 83748)) (83796
|
||||
95986 (GETCHARBITMAP 83806 . 84930) (PUTCHARBITMAP 84932 . 87090) (\GETCHARBITMAP.CSINFO 87092 . 89108
|
||||
) (\PUTCHARBITMAP.CSINFO 89110 . 95984)) (95987 116467 (MOVECHARBITMAP 95997 . 97891) (MOVEFONTCHARS
|
||||
97893 . 101853) (\MOVEFONTCHAR 101855 . 106698) (\MOVEFONTCHARS.SOURCEDATA 106700 . 112805) (
|
||||
\MAKESLUGCHAR 112807 . 115342) (SLUGCHARP.DISPLAY 115344 . 116465)) (117400 138565 (FONTFILES 117410
|
||||
. 119243) (\FINDFONTFILE 119245 . 121554) (\FONTFILENAMES 121556 . 122551) (\FONTFILENAME 122553 .
|
||||
126536) (\FONTFILENAME.OLD 126538 . 129487) (\FONTFILENAME.NEW 129489 . 131746) (FONTSPECFROMFILENAME
|
||||
131748 . 136284) (\FONTINFOFROMFILENAME.OLD 136286 . 138563)) (138832 175407 (FONTCOPY 138842 . 143905
|
||||
) (FONTP 143907 . 144206) (FONTUNPARSE 144208 . 145927) (SETFONTDESCRIPTOR 145929 . 147393) (
|
||||
\STREAMCHARWIDTH 147395 . 151559) (\COERCECHARSET 151561 . 154928) (\BUILDSLUGCSINFO 154930 . 158553)
|
||||
(\FONTSYMBOL 158555 . 159205) (\DEVICESYMBOL 159207 . 160076) (\FONTFACE 160078 . 167268) (
|
||||
\FONTFACE.COLOR 167270 . 174190) (SETFONTCHARENCODING 174192 . 175405)) (175408 194969 (FONTSAVAILABLE
|
||||
175418 . 180772) (FONTEXISTS? 180774 . 184213) (\SEARCHFONTFILES 184215 . 187300) (FLUSHFONTCACHE
|
||||
187302 . 189525) (FINDFONTFILES 189527 . 192741) (SORTFONTSPECS 192743 . 194967)) (194970 198579 (
|
||||
MATCHFONTFACE 194980 . 195795) (MAKEFONTFACE 195797 . 196823) (FONTFACETOATOM 196825 . 198577)) (
|
||||
199210 199702 (\UNITWIDTHSVECTOR 199220 . 199700)) (214296 216363 (FONTDESCRIPTOR.DEFPRINT 214306 .
|
||||
215885) (FONTCLASS.DEFPRINT 215887 . 216361)) (220192 222982 (\CREATEKERNELEMENT 220202 . 220560) (
|
||||
\FSETLEFTKERN 220562 . 221053) (\FGETLEFTKERN 221055 . 222980)) (222983 233135 (\CREATEFONT 222993 .
|
||||
224948) (\CREATECHARSET 224950 . 228886) (\INSTALLCHARSETINFO 228888 . 232222) (
|
||||
\INSTALLCHARSETINFO.CHARENCODING 232224 . 233133)) (233457 234821 (\FONTRESETCHARWIDTHS 233467 .
|
||||
234819)) (235451 245492 (\CREATEDISPLAYFONT 235461 . 237310) (\CREATECHARSET.DISPLAY 237312 . 243021)
|
||||
(\FONTEXISTS?.DISPLAY 243023 . 245490)) (245493 260358 (STRIKEFONT.FILEP 245503 . 246391) (
|
||||
STRIKEFONT.GETCHARSET 246393 . 251985) (WRITESTRIKEFONTFILE 251987 . 256898) (STRIKECSINFO 256900 .
|
||||
260356)) (260389 276706 (MAKEBOLD.CHARSET 260399 . 264048) (MAKEBOLD.CHAR 264050 . 265802) (
|
||||
MAKEITALIC.CHARSET 265804 . 269477) (MAKEITALIC.CHAR 269479 . 271825) (\SFMAKEBOLD 271827 . 274051) (
|
||||
\SFMAKEITALIC 274053 . 276704)) (276707 280856 (\SFMAKEROTATEDFONT 276717 . 278118) (\SFROTATECSINFO
|
||||
278120 . 278757) (\SFROTATEFONTCHARACTERS 278759 . 279139) (\SFROTATECSINFOOFFSETS 279141 . 280854)) (
|
||||
280857 282238 (\SFMAKECOLOR 280867 . 282236)))))
|
||||
(FILEMAP (NIL (11455 21168 (CHARWIDTH 11465 . 12250) (CHARWIDTHY 12252 . 13769) (STRINGWIDTH 13771 .
|
||||
14864) (\CHARWIDTH.DISPLAY 14866 . 15279) (\STRINGWIDTH.DISPLAY 15281 . 15705) (\STRINGWIDTH.GENERIC
|
||||
15707 . 21166)) (21169 27689 (DEFAULTFONT 21179 . 22464) (FONTCLASS 22466 . 24628) (FONTCLASSUNPARSE
|
||||
24630 . 25529) (FONTCLASSCOMPONENT 25531 . 26119) (SETFONTCLASSCOMPONENT 26121 . 26563) (
|
||||
GETFONTCLASSCOMPONENT 26565 . 27687)) (29402 46906 (FONTCREATE 29412 . 32657) (FONTCREATE1 32659 .
|
||||
35274) (FONTCREATE.SLUGFD 35276 . 36758) (\FONT.CHECKARGS1 36760 . 41283) (\FONTCREATE1.NOFN 41285 .
|
||||
41499) (FONTFILEP 41501 . 42389) (\READCHARSET 42391 . 46904)) (46907 53983 (\FONT.CHECKARGS 46917 .
|
||||
53666) (\CHARSET.CHECK 53668 . 53981)) (53984 60595 (COERCEFONTSPEC 53994 . 59906) (
|
||||
COERCEFONTSPEC.TARGETFACE 59908 . 60593)) (62790 64129 (MAKEFONTSPEC 62800 . 64127)) (64130 72307 (
|
||||
COMPLETE.FONT 64140 . 66663) (COMPLETEFONTP 66665 . 67288) (COMPLETE.CHARSET 67290 . 69975) (
|
||||
PRUNESLUGCSINFOS 69977 . 70902) (MONOSPACEFONTP 70904 . 72305)) (72346 80792 (FONTASCENT 72356 . 72740
|
||||
) (FONTDESCENT 72742 . 73227) (FONTHEIGHT 73229 . 73631) (FONTPROP 73633 . 80069) (\AVGCHARWIDTH 80071
|
||||
. 80790)) (81449 82357 (FONTDEVICEPROP 81459 . 82355)) (82403 83257 (EDITCHAR 82413 . 83255)) (83303
|
||||
95493 (GETCHARBITMAP 83313 . 84437) (PUTCHARBITMAP 84439 . 86597) (\GETCHARBITMAP.CSINFO 86599 . 88615
|
||||
) (\PUTCHARBITMAP.CSINFO 88617 . 95491)) (95494 115974 (MOVECHARBITMAP 95504 . 97398) (MOVEFONTCHARS
|
||||
97400 . 101360) (\MOVEFONTCHAR 101362 . 106205) (\MOVEFONTCHARS.SOURCEDATA 106207 . 112312) (
|
||||
\MAKESLUGCHAR 112314 . 114849) (SLUGCHARP.DISPLAY 114851 . 115972)) (116632 128360 (FONTFILES 116642
|
||||
. 118475) (\FINDFONTFILE 118477 . 120345) (\FONTFILENAMES 120347 . 120907) (\FONTFILENAME 120909 .
|
||||
123820) (FONTSPECFROMFILENAME 123822 . 128358)) (128361 164936 (FONTCOPY 128371 . 133434) (FONTP
|
||||
133436 . 133735) (FONTUNPARSE 133737 . 135456) (SETFONTDESCRIPTOR 135458 . 136922) (\STREAMCHARWIDTH
|
||||
136924 . 141088) (\COERCECHARSET 141090 . 144457) (\BUILDSLUGCSINFO 144459 . 148082) (\FONTSYMBOL
|
||||
148084 . 148734) (\DEVICESYMBOL 148736 . 149605) (\FONTFACE 149607 . 156797) (\FONTFACE.COLOR 156799
|
||||
. 163719) (SETFONTCHARENCODING 163721 . 164934)) (164937 184598 (FONTSAVAILABLE 164947 . 170301) (
|
||||
FONTEXISTS? 170303 . 173842) (\SEARCHFONTFILES 173844 . 176929) (FLUSHFONTCACHE 176931 . 179154) (
|
||||
FINDFONTFILES 179156 . 182370) (SORTFONTSPECS 182372 . 184596)) (184599 188706 (MATCHFONTFACE 184609
|
||||
. 185424) (MAKEFONTFACE 185426 . 186452) (FONTFACETOATOM 186454 . 188704)) (189337 189829 (
|
||||
\UNITWIDTHSVECTOR 189347 . 189827)) (204458 206525 (FONTDESCRIPTOR.DEFPRINT 204468 . 206047) (
|
||||
FONTCLASS.DEFPRINT 206049 . 206523)) (210354 213144 (\CREATEKERNELEMENT 210364 . 210722) (
|
||||
\FSETLEFTKERN 210724 . 211215) (\FGETLEFTKERN 211217 . 213142)) (213145 224220 (\CREATEFONT 213155 .
|
||||
216033) (\CREATECHARSET 216035 . 219971) (\INSTALLCHARSETINFO 219973 . 223307) (
|
||||
\INSTALLCHARSETINFO.CHARENCODING 223309 . 224218)) (224542 225906 (\FONTRESETCHARWIDTHS 224552 .
|
||||
225904)) (226536 236577 (\CREATEDISPLAYFONT 226546 . 228395) (\CREATECHARSET.DISPLAY 228397 . 234106)
|
||||
(\FONTEXISTS?.DISPLAY 234108 . 236575)) (236578 251443 (STRIKEFONT.FILEP 236588 . 237476) (
|
||||
STRIKEFONT.GETCHARSET 237478 . 243070) (WRITESTRIKEFONTFILE 243072 . 247983) (STRIKECSINFO 247985 .
|
||||
251441)) (251474 267791 (MAKEBOLD.CHARSET 251484 . 255133) (MAKEBOLD.CHAR 255135 . 256887) (
|
||||
MAKEITALIC.CHARSET 256889 . 260562) (MAKEITALIC.CHAR 260564 . 262910) (\SFMAKEBOLD 262912 . 265136) (
|
||||
\SFMAKEITALIC 265138 . 267789)) (267792 271941 (\SFMAKEROTATEDFONT 267802 . 269203) (\SFROTATECSINFO
|
||||
269205 . 269842) (\SFROTATEFONTCHARACTERS 269844 . 270224) (\SFROTATECSINFOOFFSETS 270226 . 271939)) (
|
||||
271942 273323 (\SFMAKECOLOR 271952 . 273321)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
187
sources/HARDCOPY
187
sources/HARDCOPY
@@ -1,14 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "19-Jan-2026 17:17:23" {WMEDLEY}<sources>HARDCOPY.;155 147674
|
||||
(FILECREATED "29-Jan-2026 10:45:17" {WMEDLEY}<sources>HARDCOPY.;160 149481
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS HARDCOPYCOMS)
|
||||
(FNS TEXT.TO.IMAGEFILE TEXTTOIMAGEFILE VIEWERPRINT PRINTERDEVICE.OPENFN
|
||||
SEND.FILE.TO.PRINTER)
|
||||
:CHANGES-TO (FNS PRINTERNAME FIND.PRINTER.FOR.IMAGETYPE PRINTERDEVICE.OPENFN PRINTERTYPE)
|
||||
|
||||
:PREVIOUS-DATE "18-Jan-2026 15:20:21" {WMEDLEY}<sources>HARDCOPY.;149)
|
||||
:PREVIOUS-DATE "27-Jan-2026 23:11:17" {WMEDLEY}<sources>HARDCOPY.;157)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT HARDCOPYCOMS)
|
||||
@@ -52,11 +50,14 @@
|
||||
(FNS SCALEREGION)
|
||||
[COMS (* ;
|
||||
"Converting text files to imagestreams")
|
||||
(GLOBALVARS TEXTDEFAULTPAGEREGION)
|
||||
[INITVARS (TEXTDEFAULTPAGEREGION (SCALEREGION MICASPERINCH (CREATEREGION 1.1 0.75 7.25
|
||||
9.75]
|
||||
(GLOBALVARS TEXTDEFAULTPAGEREGION)
|
||||
(ALISTS (IMAGESTREAMTYPES TEXT)
|
||||
(PRINTFILETYPES TEXT))
|
||||
(FNS TEXT.TO.IMAGEFILE COPY.TEXT.TO.IMAGE TEXTTOIMAGEFILE)
|
||||
(P (DEFAULT.IMAGETYPE.CONVERSIONS '(TEXT TEXT.TO.IMAGEFILE]
|
||||
(P (FONTPROFILE.ADDDEVICE 'TEXT)
|
||||
(DEFAULT.IMAGETYPE.CONVERSIONS '(TEXT TEXT.TO.IMAGEFILE]
|
||||
(COMS (* ;
|
||||
"hack for printers that can't really BLTSHADE")
|
||||
(FNS \BLTSHADE.GENERICPRINTER))
|
||||
@@ -369,7 +370,8 @@
|
||||
(AND STATUSFN (APPLY* STATUSFN PRINTER])
|
||||
|
||||
(PRINTERTYPE
|
||||
[LAMBDA (HOST PREFERRED NODEFAULT) (* ; "Edited 18-Jan-2026 14:47 by rmk")
|
||||
[LAMBDA (HOST PREFERRED NODEFAULT) (* ; "Edited 28-Jan-2026 23:55 by rmk")
|
||||
(* ; "Edited 18-Jan-2026 14:47 by rmk")
|
||||
(* ; "Edited 16-Jan-2026 07:35 by rmk")
|
||||
(* ; "Edited 17-Dec-2025 00:52 by rmk")
|
||||
(* ; "Edited 14-Dec-2025 17:53 by rmk")
|
||||
@@ -378,11 +380,6 @@
|
||||
(* ; "Edited 19-Sep-2025 10:18 by rmk")
|
||||
(* ; "Edited 27-Apr-98 16:16 by rmk:")
|
||||
(* ; "Edited 15-Feb-91 14:14 by gadener")
|
||||
|
||||
(* ;;
|
||||
"We uppercase before we look at the printer HOSTNAMEP functions--they can handle the casing")
|
||||
|
||||
(SETQ HOST (MKATOM HOST))
|
||||
(COND
|
||||
((NULL HOST)
|
||||
DEFAULTPRINTERTYPE)
|
||||
@@ -424,7 +421,8 @@
|
||||
DEFAULTPRINTERTYPE])
|
||||
|
||||
(PRINTERNAME
|
||||
[LAMBDA (PRINTER) (* ; "Edited 5-Dec-2025 09:35 by rmk")
|
||||
[LAMBDA (PRINTER) (* ; "Edited 29-Jan-2026 10:44 by rmk")
|
||||
(* ; "Edited 5-Dec-2025 09:35 by rmk")
|
||||
(* ; "Edited 19-Sep-2025 09:59 by rmk")
|
||||
|
||||
(* ;;
|
||||
@@ -432,17 +430,20 @@
|
||||
|
||||
(* ;; "Takes a printer-spec (in form (type printer-name) or just printer-name) and returns printer-name. returns nil for null arg.")
|
||||
|
||||
(CL:WHEN (LISTP PRINTER)
|
||||
(SETQ PRINTER (CADR PRINTER)))
|
||||
(CL:WHEN (PRINTERDEVICEP PRINTER)
|
||||
[LET (FDEV)
|
||||
(if (AND (STREAMP PRINTER)
|
||||
(STREAMPROP PRINTER 'PRINTERNAME))
|
||||
else (SETQ FDEV (TRUEDEVICE PRINTER))
|
||||
(if (EQ 'LPT (fetch (FDEV DEVICENAME) of FDEV))
|
||||
then (CL:UNLESS [EQ '%. (SETQ PRINTER (FILENAMEFIELD PRINTER 'NAME]
|
||||
PRINTER)
|
||||
else (fetch (FDEV DEVICENAME) of FDEV])])
|
||||
(if (LISTP PRINTER)
|
||||
then (CADR PRINTER)
|
||||
elseif (LITATOM PRINTER)
|
||||
then PRINTER
|
||||
elseif (PRINTERDEVICEP PRINTER)
|
||||
then (LET (FDEV)
|
||||
(if (AND (STREAMP PRINTER)
|
||||
(STREAMPROP PRINTER 'PRINTERNAME))
|
||||
else (SETQ FDEV (TRUEDEVICE PRINTER))
|
||||
(if (EQ 'LPT (fetch (FDEV DEVICENAME) of FDEV))
|
||||
then (CL:UNLESS [EQ '%. (SETQ PRINTER (FILENAMEFIELD PRINTER
|
||||
'NAME]
|
||||
PRINTER)
|
||||
else (fetch (FDEV DEVICENAME) of FDEV])
|
||||
|
||||
(PRINTFILETYPE
|
||||
[LAMBDA (FILE DONTOPEN) (* ; "Edited 24-Dec-2025 20:39 by rmk")
|
||||
@@ -542,7 +543,8 @@
|
||||
IMAGESOURCE)))])])
|
||||
|
||||
(FIND.PRINTER.FOR.IMAGETYPE
|
||||
[LAMBDA (IMAGETYPE HOST) (* ; "Edited 12-Jan-2026 23:49 by rmk")
|
||||
[LAMBDA (IMAGETYPE HOST) (* ; "Edited 29-Jan-2026 10:29 by rmk")
|
||||
(* ; "Edited 12-Jan-2026 23:49 by rmk")
|
||||
(* ; "Edited 28-Dec-2025 18:02 by rmk")
|
||||
(* ; "Edited 23-Dec-2025 10:13 by rmk")
|
||||
(* ; "Edited 17-Dec-2025 00:59 by rmk")
|
||||
@@ -559,22 +561,19 @@
|
||||
|
||||
(CL:WHEN (SETQ TARGETTYPE (CAN.PRINT.SOMEHOW HOST IMAGETYPE))
|
||||
(LIST (PRINTERTYPE HOST)
|
||||
HOST TARGETTYPE))
|
||||
(PRINTERNAME HOST)
|
||||
TARGETTYPE))
|
||||
elseif (for PRINTER in (DEFAULTPRINTERS) when (SETQ TARGETTYPE (CAN.PRINT.SOMEHOW PRINTER
|
||||
IMAGETYPE T))
|
||||
do (* ; "Direct?")
|
||||
(RETURN (LIST (PRINTERTYPE PRINTER)
|
||||
(CL:IF (LISTP PRINTER)
|
||||
(CADR PRINTER)
|
||||
PRINTER)
|
||||
(PRINTERNAME PRINTER)
|
||||
TARGETTYPE)))
|
||||
else (for PRINTER in (DEFAULTPRINTERS) when (SETQ TARGETTYPE (CAN.PRINT.SOMEHOW PRINTER
|
||||
IMAGETYPE))
|
||||
do (* ; "Conversion")
|
||||
(RETURN (LIST (PRINTERTYPE PRINTER)
|
||||
(CL:IF (LISTP PRINTER)
|
||||
(CADR PRINTER)
|
||||
PRINTER)
|
||||
(PRINTERNAME PRINTER)
|
||||
TARGETTYPE])
|
||||
|
||||
(CAN.PRINT.SOMEHOW
|
||||
@@ -626,7 +625,8 @@
|
||||
LPTNAME])
|
||||
|
||||
(PRINTERDEVICE.OPENFN
|
||||
[LAMBDA (LPTNAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM) (* ; "Edited 19-Jan-2026 12:19 by rmk")
|
||||
[LAMBDA (LPTNAME ACCESS RECOG PARAMETERS FDEV OLDSTREAM) (* ; "Edited 29-Jan-2026 00:13 by rmk")
|
||||
(* ; "Edited 19-Jan-2026 12:19 by rmk")
|
||||
(* ; "Edited 16-Jan-2026 23:09 by rmk")
|
||||
(* ; "Edited 28-Dec-2025 17:44 by rmk")
|
||||
(* ; "Edited 11-Sep-2025 17:03 by rmk")
|
||||
@@ -656,14 +656,25 @@
|
||||
"The case of foo.local as a printer name with no type")
|
||||
(SETQ PRINTERNAME PN)
|
||||
(SETQ IMAGEFILETYPE NIL))
|
||||
(CL:UNLESS PRINTERNAME (SETQ PRINTERNAME :DEFAULTPRINTER))
|
||||
|
||||
(* ;; "Filename is now decoded")
|
||||
|
||||
[if IMAGEFILETYPE
|
||||
[if (AND IMAGEFILETYPE PRINTERNAME)
|
||||
then (CL:UNLESS (CAN.PRINT.SOMEHOW PRINTERNAME IMAGEFILETYPE)
|
||||
(* ; "{LPT}P.T")
|
||||
(ERROR PRINTERNAME (CONCAT "cannot print files of type " IMAGEFILETYPE)))
|
||||
else (SETQ IMAGEFILETYPE (CAR (PRINTERPROP (PRINTERTYPE PRINTERNAME)
|
||||
elseif PRINTERNAME
|
||||
then (* ; "{LPT}P")
|
||||
[SETQ IMAGEFILETYPE (CAR (PRINTERPROP (PRINTERTYPE PRINTERNAME)
|
||||
'CANPRINT]
|
||||
elseif IMAGEFILETYPE
|
||||
then (* ; "{LPT}.T")
|
||||
(CL:UNLESS (SETQ PRINTERNAME (FIND.PRINTER.FOR.IMAGETYPE IMAGEFILETYPE))
|
||||
(ERROR "No printers for " IMAGEFILETYPE " files" (CONCAT
|
||||
"cannot print files of type "
|
||||
IMAGEFILETYPE)))
|
||||
else (SETQ PRINTERNAME :DEFAULTPRINTER) (* ; "Just {LPT}")
|
||||
(SETQ IMAGEFILETYPE (CAR (PRINTERPROP (PRINTERTYPE PRINTERNAME)
|
||||
'CANPRINT]
|
||||
|
||||
(* ;; "Open as a regular Unix tmp stream... with a funky closefn")
|
||||
@@ -723,7 +734,8 @@
|
||||
(fetch (FDEV DEVICENAME) of FDEV))))])
|
||||
|
||||
(PRINTERNAME
|
||||
[LAMBDA (PRINTER) (* ; "Edited 5-Dec-2025 09:35 by rmk")
|
||||
[LAMBDA (PRINTER) (* ; "Edited 29-Jan-2026 10:44 by rmk")
|
||||
(* ; "Edited 5-Dec-2025 09:35 by rmk")
|
||||
(* ; "Edited 19-Sep-2025 09:59 by rmk")
|
||||
|
||||
(* ;;
|
||||
@@ -731,17 +743,20 @@
|
||||
|
||||
(* ;; "Takes a printer-spec (in form (type printer-name) or just printer-name) and returns printer-name. returns nil for null arg.")
|
||||
|
||||
(CL:WHEN (LISTP PRINTER)
|
||||
(SETQ PRINTER (CADR PRINTER)))
|
||||
(CL:WHEN (PRINTERDEVICEP PRINTER)
|
||||
[LET (FDEV)
|
||||
(if (AND (STREAMP PRINTER)
|
||||
(STREAMPROP PRINTER 'PRINTERNAME))
|
||||
else (SETQ FDEV (TRUEDEVICE PRINTER))
|
||||
(if (EQ 'LPT (fetch (FDEV DEVICENAME) of FDEV))
|
||||
then (CL:UNLESS [EQ '%. (SETQ PRINTER (FILENAMEFIELD PRINTER 'NAME]
|
||||
PRINTER)
|
||||
else (fetch (FDEV DEVICENAME) of FDEV])])
|
||||
(if (LISTP PRINTER)
|
||||
then (CADR PRINTER)
|
||||
elseif (LITATOM PRINTER)
|
||||
then PRINTER
|
||||
elseif (PRINTERDEVICEP PRINTER)
|
||||
then (LET (FDEV)
|
||||
(if (AND (STREAMP PRINTER)
|
||||
(STREAMPROP PRINTER 'PRINTERNAME))
|
||||
else (SETQ FDEV (TRUEDEVICE PRINTER))
|
||||
(if (EQ 'LPT (fetch (FDEV DEVICENAME) of FDEV))
|
||||
then (CL:UNLESS [EQ '%. (SETQ PRINTER (FILENAMEFIELD PRINTER
|
||||
'NAME]
|
||||
PRINTER)
|
||||
else (fetch (FDEV DEVICENAME) of FDEV])
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
@@ -839,12 +854,18 @@
|
||||
|
||||
(* ; "Converting text files to imagestreams")
|
||||
|
||||
|
||||
(RPAQ? TEXTDEFAULTPAGEREGION (SCALEREGION MICASPERINCH (CREATEREGION 1.1 0.75 7.25 9.75)))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS TEXTDEFAULTPAGEREGION)
|
||||
)
|
||||
|
||||
(RPAQ? TEXTDEFAULTPAGEREGION (SCALEREGION MICASPERINCH (CREATEREGION 1.1 0.75 7.25 9.75)))
|
||||
|
||||
(ADDTOVAR IMAGESTREAMTYPES (TEXT (FONTCREATE \CREATEDISPLAYFONT)
|
||||
(CREATECHARSET \CREATECHARSET.DISPLAY)))
|
||||
|
||||
(ADDTOVAR PRINTFILETYPES (TEXT (TEST LISPSOURCEFILEP)
|
||||
(EXTENSION (TXT TEXT))))
|
||||
(DEFINEQ
|
||||
|
||||
(TEXT.TO.IMAGEFILE
|
||||
@@ -970,6 +991,8 @@
|
||||
(TEDIT.TO.IMAGEFILE FILE IMAGEFILE IMAGETYPE OPTIONS])
|
||||
)
|
||||
|
||||
(FONTPROFILE.ADDDEVICE 'TEXT)
|
||||
|
||||
(DEFAULT.IMAGETYPE.CONVERSIONS '(TEXT TEXT.TO.IMAGEFILE))
|
||||
|
||||
|
||||
@@ -2330,35 +2353,35 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (6606 19331 (MakeMenuOfPrinters 6616 . 8105) (PRINTERS.WHENSELECTEDFN 8107 . 10038) (
|
||||
MakeMenuOfImageTypes 10040 . 10859) (GetNewPrinterFromUser 10861 . 11417) (PopUpWindowAndGetAtom 11419
|
||||
. 12870) (PopUpWindowAndGetList 12872 . 14442) (NewPrinter 14444 . 16058) (GetPrinterName 16060 .
|
||||
16348) (GetImageFile 16350 . 19329)) (19386 37306 (HARDCOPYW 19396 . 20869) (LISTFILES1 20871 . 21048)
|
||||
(PRINTERPROP 21050 . 21300) (PRINTERSTATUS 21302 . 21577) (PRINTERTYPE 21579 . 24855) (PRINTERNAME
|
||||
24857 . 25943) (PRINTFILETYPE 25945 . 26318) (PRINTERTYPEP 26320 . 26545) (SEND.FILE.TO.PRINTER 26547
|
||||
. 32796) (FIND.PRINTER.FOR.IMAGETYPE 32798 . 35503) (CAN.PRINT.SOMEHOW 35505 . 36877) (
|
||||
CAN.PRINT.DIRECTLY 36879 . 37304)) (37307 45651 (PRINTERDEVICE 37317 . 38926) (PRINTERDEVICE.OPENFN
|
||||
38928 . 41914) (PRINTERDEVICE.CLOSEFN 41916 . 43635) (PRINTERDEVICEP 43637 . 44561) (PRINTERNAME 44563
|
||||
. 45649)) (45713 48137 (DEFAULTPRINTERS 45723 . 48135)) (48536 49833 (VIEWERPRINT 48546 . 49831)) (
|
||||
49951 50509 (SCALEREGION 49961 . 50507)) (50733 58555 (TEXT.TO.IMAGEFILE 50743 . 51956) (
|
||||
COPY.TEXT.TO.IMAGE 51958 . 58306) (TEXTTOIMAGEFILE 58308 . 58553)) (58676 60419 (
|
||||
\BLTSHADE.GENERICPRINTER 58686 . 60417)) (60486 97652 (MAKEHARDCOPYSTREAM 60496 . 62212) (
|
||||
UNMAKEHARDCOPYSTREAM 62214 . 63144) (HARDCOPYSTREAMTYPE 63146 . 63553) (\CHARWIDTH.HDCPYDISPLAY 63555
|
||||
. 64375) (\DSPFONT.HDCPYDISPLAY 64377 . 67172) (\DSPRIGHTMARGIN.HDCPYDISPLAY 67174 . 68029) (
|
||||
\DSPXPOSITION.HDCPYDISPLAY 68031 . 68406) (\DSPYPOSITION.HDCPYDISPLAY 68408 . 68783) (
|
||||
\STRINGWIDTH.HDCPYDISPLAY 68785 . 69740) (\STRINGWIDTH.HCPYDISPLAYAUX 69742 . 75082) (\HDCPYBLTCHAR
|
||||
75084 . 79981) (\HDCPYDISPLAY.FIX.XPOS 79983 . 80740) (\HDCPYDISPLAY.FIX.YPOS 80742 . 81483) (
|
||||
\HDCPYDISPLAYINIT 81485 . 83175) (\HDCPYDSPPRINTCHAR 83177 . 89090) (\SLOWHDCPYBLTCHAR 89092 . 95708)
|
||||
(\CHANGECHARSET.HDCPYDISPLAY 95710 . 97650)) (97967 147518 (MAKEHARDCOPYMODESTREAM 97977 . 100698) (
|
||||
UNMAKEHARDCOPYMODESTREAM 100700 . 102290) (\HCPYDISPLAYIMAGEOPS 102292 . 105112) (\BLTSHADE.HCPYMODE
|
||||
105114 . 105780) (\BITBLT.HCPYMODE 105782 . 106530) (\BRUSHCONVERT.HCPYMODE 106532 . 107081) (
|
||||
\CHANGECHARSET.HCPYMODE 107083 . 110345) (\DASHINGCONVERT.HCPYMODE 110347 . 110688) (
|
||||
\CHARWIDTH.HCPYMODE 110690 . 111127) (\DRAWLINE.HCPYMODE 111129 . 111658) (\DRAWCURVE.HCPYMODE 111660
|
||||
. 112247) (\DRAWCIRCLE.HCPYMODE 112249 . 112734) (\DRAWELLIPSE.HCPYMODE 112736 . 113420) (
|
||||
\DSPFONT.HCPYMODE 113422 . 116106) (\DSPLEFTMARGIN.HCPYMODE 116108 . 116850) (\DSPLINEFEED.HCPYMODE
|
||||
116852 . 117485) (\DSPRIGHTMARGIN.HCPYMODE 117487 . 118555) (\DSPSPACEFACTOR.HCPYMODE 118557 . 119332)
|
||||
(\DSPXPOSITION.HCPYMODE 119334 . 120352) (\DSPYPOSITION.HCPYMODE 120354 . 121004) (\MOVETO.HCPYMODE
|
||||
121006 . 121220) (\FONTCREATE.HCPYMODE 121222 . 123179) (\CREATECHARSET.HCPYMODE 123181 . 124904) (
|
||||
\STRINGWIDTH.HCPYMODE 124906 . 125701) (\HCPYMODEBLTCHAR 125703 . 131453) (\HCPYMODEDSPPRINTCHAR
|
||||
131455 . 137389) (\SLOWHCPYMODEBLTCHAR 137391 . 144020) (\SFFixY.HCPYMODE 144022 . 147516)))))
|
||||
(FILEMAP (NIL (6665 19390 (MakeMenuOfPrinters 6675 . 8164) (PRINTERS.WHENSELECTEDFN 8166 . 10097) (
|
||||
MakeMenuOfImageTypes 10099 . 10918) (GetNewPrinterFromUser 10920 . 11476) (PopUpWindowAndGetAtom 11478
|
||||
. 12929) (PopUpWindowAndGetList 12931 . 14501) (NewPrinter 14503 . 16117) (GetPrinterName 16119 .
|
||||
16407) (GetImageFile 16409 . 19388)) (19445 37555 (HARDCOPYW 19455 . 20928) (LISTFILES1 20930 . 21107)
|
||||
(PRINTERPROP 21109 . 21359) (PRINTERSTATUS 21361 . 21636) (PRINTERTYPE 21638 . 24874) (PRINTERNAME
|
||||
24876 . 26243) (PRINTFILETYPE 26245 . 26618) (PRINTERTYPEP 26620 . 26845) (SEND.FILE.TO.PRINTER 26847
|
||||
. 33096) (FIND.PRINTER.FOR.IMAGETYPE 33098 . 35752) (CAN.PRINT.SOMEHOW 35754 . 37126) (
|
||||
CAN.PRINT.DIRECTLY 37128 . 37553)) (37556 47168 (PRINTERDEVICE 37566 . 39175) (PRINTERDEVICE.OPENFN
|
||||
39177 . 43150) (PRINTERDEVICE.CLOSEFN 43152 . 44871) (PRINTERDEVICEP 44873 . 45797) (PRINTERNAME 45799
|
||||
. 47166)) (47230 49654 (DEFAULTPRINTERS 47240 . 49652)) (50053 51350 (VIEWERPRINT 50063 . 51348)) (
|
||||
51468 52026 (SCALEREGION 51478 . 52024)) (52509 60331 (TEXT.TO.IMAGEFILE 52519 . 53732) (
|
||||
COPY.TEXT.TO.IMAGE 53734 . 60082) (TEXTTOIMAGEFILE 60084 . 60329)) (60483 62226 (
|
||||
\BLTSHADE.GENERICPRINTER 60493 . 62224)) (62293 99459 (MAKEHARDCOPYSTREAM 62303 . 64019) (
|
||||
UNMAKEHARDCOPYSTREAM 64021 . 64951) (HARDCOPYSTREAMTYPE 64953 . 65360) (\CHARWIDTH.HDCPYDISPLAY 65362
|
||||
. 66182) (\DSPFONT.HDCPYDISPLAY 66184 . 68979) (\DSPRIGHTMARGIN.HDCPYDISPLAY 68981 . 69836) (
|
||||
\DSPXPOSITION.HDCPYDISPLAY 69838 . 70213) (\DSPYPOSITION.HDCPYDISPLAY 70215 . 70590) (
|
||||
\STRINGWIDTH.HDCPYDISPLAY 70592 . 71547) (\STRINGWIDTH.HCPYDISPLAYAUX 71549 . 76889) (\HDCPYBLTCHAR
|
||||
76891 . 81788) (\HDCPYDISPLAY.FIX.XPOS 81790 . 82547) (\HDCPYDISPLAY.FIX.YPOS 82549 . 83290) (
|
||||
\HDCPYDISPLAYINIT 83292 . 84982) (\HDCPYDSPPRINTCHAR 84984 . 90897) (\SLOWHDCPYBLTCHAR 90899 . 97515)
|
||||
(\CHANGECHARSET.HDCPYDISPLAY 97517 . 99457)) (99774 149325 (MAKEHARDCOPYMODESTREAM 99784 . 102505) (
|
||||
UNMAKEHARDCOPYMODESTREAM 102507 . 104097) (\HCPYDISPLAYIMAGEOPS 104099 . 106919) (\BLTSHADE.HCPYMODE
|
||||
106921 . 107587) (\BITBLT.HCPYMODE 107589 . 108337) (\BRUSHCONVERT.HCPYMODE 108339 . 108888) (
|
||||
\CHANGECHARSET.HCPYMODE 108890 . 112152) (\DASHINGCONVERT.HCPYMODE 112154 . 112495) (
|
||||
\CHARWIDTH.HCPYMODE 112497 . 112934) (\DRAWLINE.HCPYMODE 112936 . 113465) (\DRAWCURVE.HCPYMODE 113467
|
||||
. 114054) (\DRAWCIRCLE.HCPYMODE 114056 . 114541) (\DRAWELLIPSE.HCPYMODE 114543 . 115227) (
|
||||
\DSPFONT.HCPYMODE 115229 . 117913) (\DSPLEFTMARGIN.HCPYMODE 117915 . 118657) (\DSPLINEFEED.HCPYMODE
|
||||
118659 . 119292) (\DSPRIGHTMARGIN.HCPYMODE 119294 . 120362) (\DSPSPACEFACTOR.HCPYMODE 120364 . 121139)
|
||||
(\DSPXPOSITION.HCPYMODE 121141 . 122159) (\DSPYPOSITION.HCPYMODE 122161 . 122811) (\MOVETO.HCPYMODE
|
||||
122813 . 123027) (\FONTCREATE.HCPYMODE 123029 . 124986) (\CREATECHARSET.HCPYMODE 124988 . 126711) (
|
||||
\STRINGWIDTH.HCPYMODE 126713 . 127508) (\HCPYMODEBLTCHAR 127510 . 133260) (\HCPYMODEDSPPRINTCHAR
|
||||
133262 . 139196) (\SLOWHCPYMODEBLTCHAR 139198 . 145827) (\SFFixY.HCPYMODE 145829 . 149323)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
203
sources/IMAGEIO
203
sources/IMAGEIO
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "19-Jan-2026 14:08:55" {WMEDLEY}<sources>IMAGEIO.;51 99943
|
||||
(FILECREATED "29-Jan-2026 08:48:22" {WMEDLEY}<sources>IMAGEIO.;60 100411
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS IMAGESTREAMTYPE)
|
||||
:CHANGES-TO (VARS IMAGEIOCOMS)
|
||||
|
||||
:PREVIOUS-DATE "18-Jan-2026 15:04:58" {WMEDLEY}<sources>IMAGEIO.;50)
|
||||
:PREVIOUS-DATE "29-Jan-2026 00:29:52" {WMEDLEY}<sources>IMAGEIO.;57)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT IMAGEIOCOMS)
|
||||
@@ -19,17 +19,18 @@
|
||||
(FNS CONVERT.TO.IMAGEFILE)
|
||||
(FNS BITMAPFILEP BITMAP.TO.BITMAPFILE BITMAPFILE.TO.BITMAP BITMAPFILE.TO.IMAGEFILE)
|
||||
(FNS BITMAP.TO.IMAGEFILE WINDOW.TO.IMAGEFILE SCREENREGION.TO.IMAGEFILE COPY.WINDOW.TO.BITMAP)
|
||||
(COMS (ADDVARS (PRINTFILETYPES (DEFAULT)))
|
||||
(COMS (* ; "PRINTFILETYPES")
|
||||
(INITVARS (PRINTFILETYPES NIL))
|
||||
(GLOBALVARS PRINTFILETYPES)
|
||||
(FNS DEFAULT.IMAGETYPE.CONVERSIONS)
|
||||
[P (DEFAULT.IMAGETYPE.CONVERSIONS '(BITMAP BITMAP.TO.IMAGEFILE WINDOW
|
||||
WINDOW.TO.IMAGEFILE SCREENREGION
|
||||
SCREENREGION.TO.IMAGEFILE BITMAPFILE
|
||||
BITMAPFILE.TO.IMAGEFILE]
|
||||
(ALISTS (PRINTFILETYPES BITMAP WINDOW SCREENREGION BITMAPFILE TEXT)))
|
||||
(COMS (* ; "Until HTML streams")
|
||||
(ALISTS (PRINTFILETYPES HTML))
|
||||
(FNS HTMLFILEP))
|
||||
(ALISTS (PRINTFILETYPES BITMAP WINDOW SCREENREGION BITMAPFILE))
|
||||
(COMS (* ; "Until HTML streams")
|
||||
(ALISTS (PRINTFILETYPES HTML))
|
||||
(FNS HTMLFILEP)))
|
||||
(INITVARS (IMAGESTREAMTYPES NIL))
|
||||
(FNS \GOOD.DASHLST)
|
||||
(FNS DRAWDASHEDLINE)
|
||||
@@ -220,6 +221,7 @@
|
||||
|
||||
(CONVERT.TO.IMAGEFILE
|
||||
[LAMBDA (IMAGESOURCE IMAGEFILE IMAGEFILETYPE OPTIONS NOERROR)
|
||||
(* ; "Edited 27-Jan-2026 17:45 by rmk")
|
||||
(* ; "Edited 17-Jan-2026 12:41 by rmk")
|
||||
(* ; "Edited 12-Jan-2026 23:49 by rmk")
|
||||
(* ; "Edited 11-Jan-2026 13:21 by rmk")
|
||||
@@ -254,40 +256,43 @@
|
||||
(SETQ IMAGEFILETYPE (IMAGESOURCETYPE IMAGEFILE)))
|
||||
(CL:WHEN (MEMB IMAGEFILETYPE '(PDF POSTSCRIPT)) (* ; "POSTSCRIPT SCREWS UP")
|
||||
(push OPTIONS 'HEADING NIL))
|
||||
(LET
|
||||
((SOURCETYPE (IMAGESOURCETYPE IMAGESOURCE))
|
||||
CONVERTED CFN)
|
||||
(LET ((SOURCETYPE (IMAGESOURCETYPE IMAGESOURCE))
|
||||
CONVERTED CFN)
|
||||
|
||||
(* ;; "The conversion function may abandon the IMAGEFILE we provide and create its own.")
|
||||
(* ;; "The conversion function may abandon the IMAGEFILE we provide and create its own.")
|
||||
|
||||
(if (EQ IMAGEFILETYPE SOURCETYPE)
|
||||
then
|
||||
(* ;; "Already have what we want")
|
||||
(if (EQ IMAGEFILETYPE SOURCETYPE)
|
||||
then
|
||||
(* ;; "Already have what we want")
|
||||
|
||||
IMAGESOURCE
|
||||
else (if [AND (SETQ CFN (OR (LISTGET (IMAGEFILEPROP IMAGEFILETYPE 'CONVERSION)
|
||||
SOURCETYPE)
|
||||
(LISTGET (IMAGEFILEPROP 'DEFAULT 'CONVERSION)
|
||||
SOURCETYPE)))
|
||||
(SETQ CONVERTED (CAR (NLSETQ (APPLY* CFN IMAGESOURCE
|
||||
[OR (STREAMP IMAGEFILE)
|
||||
(AND IMAGEFILE
|
||||
(PACKFILENAME 'BODY IMAGEFILE
|
||||
'EXTENSION
|
||||
(CAR (
|
||||
IMAGESOURCE
|
||||
elseif [AND (SETQ CFN (OR (LISTGET (IMAGEFILEPROP IMAGEFILETYPE 'CONVERSION)
|
||||
SOURCETYPE)
|
||||
(LISTGET (IMAGEFILEPROP 'DEFAULT 'CONVERSION)
|
||||
SOURCETYPE)))
|
||||
(SETQ CONVERTED (CAR (NLSETQ (APPLY* CFN IMAGESOURCE
|
||||
[OR (STREAMP IMAGEFILE)
|
||||
[AND IMAGEFILE
|
||||
(PACKFILENAME 'BODY IMAGEFILE
|
||||
'EXTENSION
|
||||
(CAR (
|
||||
EXTENSIONS.FOR.IMAGEFILETYPE
|
||||
IMAGEFILETYPE]
|
||||
IMAGEFILETYPE OPTIONS]
|
||||
then (CL:WHEN (STREAMP CONVERTED) (* ; "Can't tell from the name")
|
||||
(STREAMPROP CONVERTED 'IMAGETYPE IMAGEFILETYPE))
|
||||
(CLOSEF? CONVERTED)
|
||||
CONVERTED
|
||||
elseif NOERROR
|
||||
then NIL
|
||||
else (ERROR (CONCAT "Can't convert " SOURCETYPE " file to " IMAGEFILETYPE)
|
||||
(CL:IF (STREAMP IMAGESOURCE)
|
||||
(FULLNAME IMAGESOURCE)
|
||||
IMAGESOURCE)])
|
||||
IMAGEFILETYPE]
|
||||
(UNIX-TMP-FILE-NAME
|
||||
(L-CASE SOURCETYPE)
|
||||
(CAR (EXTENSIONS.FOR.IMAGEFILETYPE
|
||||
IMAGEFILETYPE]
|
||||
IMAGEFILETYPE OPTIONS]
|
||||
then (CL:WHEN (STREAMP CONVERTED) (* ; "Can't tell from the name")
|
||||
(STREAMPROP CONVERTED 'IMAGETYPE IMAGEFILETYPE))
|
||||
(CLOSEF? CONVERTED)
|
||||
CONVERTED
|
||||
elseif NOERROR
|
||||
then NIL
|
||||
else (ERROR (CONCAT "Can't convert " SOURCETYPE " file to " IMAGEFILETYPE)
|
||||
(CL:IF (STREAMP IMAGESOURCE)
|
||||
(FULLNAME IMAGESOURCE)
|
||||
IMAGESOURCE)])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -479,7 +484,12 @@
|
||||
(T (BITMAPCOPY (WINDOWPROP WINDOW 'IMAGECOVERED])
|
||||
)
|
||||
|
||||
(ADDTOVAR PRINTFILETYPES (DEFAULT))
|
||||
|
||||
|
||||
(* ; "PRINTFILETYPES")
|
||||
|
||||
|
||||
(RPAQ? PRINTFILETYPES NIL)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS PRINTFILETYPES)
|
||||
@@ -487,33 +497,27 @@
|
||||
(DEFINEQ
|
||||
|
||||
(DEFAULT.IMAGETYPE.CONVERSIONS
|
||||
[LAMBDA (CONVERSIONS) (* ; "Edited 18-Jan-2026 00:18 by rmk")
|
||||
|
||||
(* ;; "Adds CONVERSIONS to the DEFAULT PRINTFILETYPE")
|
||||
(* ; "Edited 24-Dec-2025 22:42 by rmk")
|
||||
(CL:UNLESS (EQ 0 (IMOD (LENGTH CONVERSIONS)
|
||||
2))
|
||||
(ERROR "CONVERSIONS is not a property list"))
|
||||
(PUTMULTI PRINTFILETYPES 'DEFAULT 'CONVERSION
|
||||
(CONS (for CTAIL (CURRENT _ (OR (CAR (GETMULTI PRINTFILETYPES 'DEFAULT 'CONVERSION))
|
||||
(LIST (CAR CONVERSIONS)
|
||||
NIL))) on CONVERSIONS by (CDDR CTAIL)
|
||||
do (LISTPUT CURRENT (CAR CTAIL)
|
||||
(CADR CTAIL)) finally (RETURN CURRENT])
|
||||
[LAMBDA (CONVERSIONS) (* ; "Edited 27-Jan-2026 23:24 by rmk")
|
||||
(* ; "Edited 18-Jan-2026 00:18 by rmk")
|
||||
(* ; "Edited 24-Dec-2025 22:42 by rmk")
|
||||
(CL:WHEN CONVERSIONS
|
||||
[PUTMULTI PRINTFILETYPES 'DEFAULT 'CONVERSION
|
||||
(CONS (for CTAIL (CURRENT _ (OR (CAR (GETMULTI PRINTFILETYPES 'DEFAULT 'CONVERSION))
|
||||
(LIST (CAR CONVERSIONS)
|
||||
NIL))) on CONVERSIONS by (CDDR CTAIL)
|
||||
do (LISTPUT CURRENT (CAR CTAIL)
|
||||
(CADR CTAIL)) finally (RETURN CURRENT])])
|
||||
)
|
||||
|
||||
(DEFAULT.IMAGETYPE.CONVERSIONS '(BITMAP BITMAP.TO.IMAGEFILE WINDOW WINDOW.TO.IMAGEFILE SCREENREGION
|
||||
SCREENREGION.TO.IMAGEFILE BITMAPFILE BITMAPFILE.TO.IMAGEFILE))
|
||||
|
||||
(ADDTOVAR PRINTFILETYPES
|
||||
(BITMAP (TEST BITMAPP))
|
||||
(WINDOW (TEST WINDOWP))
|
||||
(SCREENREGION (TEST REGIONP))
|
||||
(BITMAPFILE (TEST BITMAPFILEP)
|
||||
(EXTENSION (BM BITMAP))
|
||||
(CONVERSION (BITMAP BITMAP.TO.BITMAPFILE)))
|
||||
(TEXT (TEST LISPSOURCEFILEP)
|
||||
(EXTENSION (TXT TEXT))))
|
||||
(ADDTOVAR PRINTFILETYPES (BITMAP (TEST BITMAPP))
|
||||
(WINDOW (TEST WINDOWP))
|
||||
(SCREENREGION (TEST REGIONP))
|
||||
(BITMAPFILE (TEST BITMAPFILEP)
|
||||
(EXTENSION (BM BITMAP))
|
||||
(CONVERSION (BITMAP BITMAP.TO.BITMAPFILE))))
|
||||
|
||||
|
||||
|
||||
@@ -1834,23 +1838,22 @@
|
||||
)
|
||||
|
||||
(ADDTOVAR IMAGESTREAMTYPES
|
||||
(DISPLAY (OPENSTREAM OPENDISPLAYSTREAM)
|
||||
(FONTCREATE \CREATEDISPLAYFONT)
|
||||
(DISPLAY (FONTCREATE \CREATEDISPLAYFONT)
|
||||
(OPENSTREAM OPENDISPLAYSTREAM)
|
||||
(FONTSAVAILABLE \SEARCHFONTFILES)
|
||||
(CREATECHARSET \CREATECHARSET.DISPLAY)
|
||||
(FONTEXISTS? \FONTEXISTS?.DISPLAY))
|
||||
(4DISPLAY (OPENSTREAM OPENDISPLAYSTREAM)
|
||||
(4DISPLAY (FONTCREATE \CREATEDISPLAYFONT)
|
||||
(OPENSTREAM OPENDISPLAYSTREAM)
|
||||
(FONTSAVAILABLE \SEARCHFONTFILES)
|
||||
(FONTEXISTS? \FONTEXISTS?.DISPLAY))
|
||||
(8DISPLAY (FONTCREATE \CREATEDISPLAYFONT)
|
||||
(OPENSTREAM OPENDISPLAYSTREAM)
|
||||
(FONTCREATE \CREATEDISPLAYFONT)
|
||||
(FONTSAVAILABLE \SEARCHFONTFILES)
|
||||
(CREATECHARSET \CREATECHARSET.DISPLAY)
|
||||
(FONTEXISTS? \FONTEXISTS?.DISPLAY))
|
||||
(8DISPLAY (OPENSTREAM OPENDISPLAYSTREAM)
|
||||
(FONTCREATE \CREATEDISPLAYFONT)
|
||||
(FONTSAVAILABLE \SEARCHFONTFILES)
|
||||
(CREATECHARSET \CREATECHARSET.DISPLAY)
|
||||
(FONTEXISTS? \FONTEXISTS?.DISPLAY))
|
||||
(24DISPLAY (OPENSTREAM OPENDISPLAYSTREAM)
|
||||
(FONTCREATE \CREATEDISPLAYFONT)
|
||||
(24DISPLAY (FONTCREATE \CREATEDISPLAYFONT)
|
||||
(OPENSTREAM OPENDISPLAYSTREAM)
|
||||
(FONTSAVAILABLE \SEARCHFONTFILES)
|
||||
(CREATECHARSET \CREATECHARSET.DISPLAY)
|
||||
(FONTEXISTS? \FONTEXISTS?.DISPLAY)))
|
||||
@@ -1877,32 +1880,32 @@
|
||||
(ADDTOVAR LAMA IMAGESTREAMP)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4337 6241 (OPENIMAGESTREAM 4347 . 6239)) (6242 11483 (IMAGESTREAMP 6252 . 7084) (
|
||||
IMAGESTREAMTYPE 7086 . 7602) (IMAGESTREAMTYPEP 7604 . 8239) (IMAGEFILEPROP 8241 . 8779) (
|
||||
IMAGESOURCEFILEP 8781 . 9058) (IMAGESOURCETYPE 9060 . 11481)) (11484 12775 (
|
||||
EXTENSIONS.FOR.IMAGEFILETYPE 11494 . 12136) (IMAGEFILETYPE.FROM.EXTENSION 12138 . 12773)) (12776 17758
|
||||
(CONVERT.TO.IMAGEFILE 12786 . 17756)) (17759 21850 (BITMAPFILEP 17769 . 19270) (BITMAP.TO.BITMAPFILE
|
||||
19272 . 20949) (BITMAPFILE.TO.BITMAP 20951 . 21605) (BITMAPFILE.TO.IMAGEFILE 21607 . 21848)) (21851
|
||||
28176 (BITMAP.TO.IMAGEFILE 21861 . 23418) (WINDOW.TO.IMAGEFILE 23420 . 26249) (
|
||||
SCREENREGION.TO.IMAGEFILE 26251 . 27155) (COPY.WINDOW.TO.BITMAP 27157 . 28174)) (28284 29190 (
|
||||
DEFAULT.IMAGETYPE.CONVERSIONS 28294 . 29188)) (29904 30130 (HTMLFILEP 29914 . 30128)) (30165 32280 (
|
||||
\GOOD.DASHLST 30175 . 32278)) (32281 34578 (DRAWDASHEDLINE 32291 . 34576)) (34579 41919 (DSPBACKCOLOR
|
||||
34589 . 34961) (DSPBOTTOMMARGIN 34963 . 35348) (DSPCOLOR 35350 . 35714) (DSPCLIPPINGREGION 35716 .
|
||||
36421) (DSPRESET 36423 . 36703) (DSPFONT 36705 . 37069) (DSPLEFTMARGIN 37071 . 37452) (DSPLINEFEED
|
||||
37454 . 37754) (DSPOPERATION 37756 . 38133) (DSPRIGHTMARGIN 38135 . 38518) (DSPTOPMARGIN 38520 . 38899
|
||||
) (DSPSCALE 38901 . 39268) (DSPSPACEFACTOR 39270 . 39663) (DSPXPOSITION 39665 . 39970) (DSPYPOSITION
|
||||
39972 . 40277) (DSPROTATE 40279 . 40574) (DSPPUSHSTATE 40576 . 40822) (DSPPOPSTATE 40824 . 41067) (
|
||||
DSPDEFAULTSTATE 41069 . 41321) (DSPSCALE2 41323 . 41614) (DSPTRANSLATE 41616 . 41917)) (41920 50721 (
|
||||
DSPNEWPAGE 41930 . 42622) (DRAWBETWEEN 42624 . 43326) (DRAWCIRCLE 43328 . 43824) (DRAWARC 43826 .
|
||||
44343) (DRAWCURVE 44345 . 45022) (DRAWELLIPSE 45024 . 45810) (DRAWLINE 45812 . 46202) (DRAWPOLYGON
|
||||
46204 . 46659) (DRAWPOINT 46661 . 47080) (FILLPOLYGON 47082 . 47648) (DRAWTO 47650 . 48068) (
|
||||
FILLCIRCLE 48070 . 48293) (MOVETO 48295 . 48659) (RELDRAWTO 48661 . 49578) (BITMAPIMAGESIZE 49580 .
|
||||
49751) (SCALEDBITBLT 49753 . 50719)) (50722 57761 (\DRAWPOINT.GENERIC 50732 . 51079) (
|
||||
\DRAWPOLYGON.GENERIC 51081 . 53389) (\DRAWCIRCLE.GENERIC 53391 . 55049) (\DRAWELLIPSE.GENERIC 55051 .
|
||||
57759)) (57762 62706 (\IMAGEIOINIT 57772 . 61052) (\NOIMAGE.DSPFONT 61054 . 62540) (\UNIMPIMAGEOP
|
||||
62542 . 62704)) (62829 65953 (INSURE.BRUSH 62839 . 64213) (BRUSHP 64215 . 65005) (\POSSIBLECOLOR 65007
|
||||
. 65558) (NEGSHADE 65560 . 65951)) (66509 67193 (DASHINGP 66519 . 66849) (INSURE.DASHING 66851 .
|
||||
67191)) (77931 98477 (\DisplayEventFn 77941 . 78451) (\DISPLAYINIT 78453 . 84036) (\4DISPLAYINIT 84038
|
||||
. 88739) (\8DISPLAYINIT 88741 . 93444) (\24DISPLAYINIT 93446 . 98218) (\DISPLAYSTREAMTYPEBPP 98220 .
|
||||
98475)))))
|
||||
(FILEMAP (NIL (4424 6328 (OPENIMAGESTREAM 4434 . 6326)) (6329 11570 (IMAGESTREAMP 6339 . 7171) (
|
||||
IMAGESTREAMTYPE 7173 . 7689) (IMAGESTREAMTYPEP 7691 . 8326) (IMAGEFILEPROP 8328 . 8866) (
|
||||
IMAGESOURCEFILEP 8868 . 9145) (IMAGESOURCETYPE 9147 . 11568)) (11571 12862 (
|
||||
EXTENSIONS.FOR.IMAGEFILETYPE 11581 . 12223) (IMAGEFILETYPE.FROM.EXTENSION 12225 . 12860)) (12863 18321
|
||||
(CONVERT.TO.IMAGEFILE 12873 . 18319)) (18322 22413 (BITMAPFILEP 18332 . 19833) (BITMAP.TO.BITMAPFILE
|
||||
19835 . 21512) (BITMAPFILE.TO.BITMAP 21514 . 22168) (BITMAPFILE.TO.IMAGEFILE 22170 . 22411)) (22414
|
||||
28739 (BITMAP.TO.IMAGEFILE 22424 . 23981) (WINDOW.TO.IMAGEFILE 23983 . 26812) (
|
||||
SCREENREGION.TO.IMAGEFILE 26814 . 27718) (COPY.WINDOW.TO.BITMAP 27720 . 28737)) (28869 29735 (
|
||||
DEFAULT.IMAGETYPE.CONVERSIONS 28879 . 29733)) (30435 30661 (HTMLFILEP 30445 . 30659)) (30696 32811 (
|
||||
\GOOD.DASHLST 30706 . 32809)) (32812 35109 (DRAWDASHEDLINE 32822 . 35107)) (35110 42450 (DSPBACKCOLOR
|
||||
35120 . 35492) (DSPBOTTOMMARGIN 35494 . 35879) (DSPCOLOR 35881 . 36245) (DSPCLIPPINGREGION 36247 .
|
||||
36952) (DSPRESET 36954 . 37234) (DSPFONT 37236 . 37600) (DSPLEFTMARGIN 37602 . 37983) (DSPLINEFEED
|
||||
37985 . 38285) (DSPOPERATION 38287 . 38664) (DSPRIGHTMARGIN 38666 . 39049) (DSPTOPMARGIN 39051 . 39430
|
||||
) (DSPSCALE 39432 . 39799) (DSPSPACEFACTOR 39801 . 40194) (DSPXPOSITION 40196 . 40501) (DSPYPOSITION
|
||||
40503 . 40808) (DSPROTATE 40810 . 41105) (DSPPUSHSTATE 41107 . 41353) (DSPPOPSTATE 41355 . 41598) (
|
||||
DSPDEFAULTSTATE 41600 . 41852) (DSPSCALE2 41854 . 42145) (DSPTRANSLATE 42147 . 42448)) (42451 51252 (
|
||||
DSPNEWPAGE 42461 . 43153) (DRAWBETWEEN 43155 . 43857) (DRAWCIRCLE 43859 . 44355) (DRAWARC 44357 .
|
||||
44874) (DRAWCURVE 44876 . 45553) (DRAWELLIPSE 45555 . 46341) (DRAWLINE 46343 . 46733) (DRAWPOLYGON
|
||||
46735 . 47190) (DRAWPOINT 47192 . 47611) (FILLPOLYGON 47613 . 48179) (DRAWTO 48181 . 48599) (
|
||||
FILLCIRCLE 48601 . 48824) (MOVETO 48826 . 49190) (RELDRAWTO 49192 . 50109) (BITMAPIMAGESIZE 50111 .
|
||||
50282) (SCALEDBITBLT 50284 . 51250)) (51253 58292 (\DRAWPOINT.GENERIC 51263 . 51610) (
|
||||
\DRAWPOLYGON.GENERIC 51612 . 53920) (\DRAWCIRCLE.GENERIC 53922 . 55580) (\DRAWELLIPSE.GENERIC 55582 .
|
||||
58290)) (58293 63237 (\IMAGEIOINIT 58303 . 61583) (\NOIMAGE.DSPFONT 61585 . 63071) (\UNIMPIMAGEOP
|
||||
63073 . 63235)) (63360 66484 (INSURE.BRUSH 63370 . 64744) (BRUSHP 64746 . 65536) (\POSSIBLECOLOR 65538
|
||||
. 66089) (NEGSHADE 66091 . 66482)) (67040 67724 (DASHINGP 67050 . 67380) (INSURE.DASHING 67382 .
|
||||
67722)) (78462 99008 (\DisplayEventFn 78472 . 78982) (\DISPLAYINIT 78984 . 84567) (\4DISPLAYINIT 84569
|
||||
. 89270) (\8DISPLAYINIT 89272 . 93975) (\24DISPLAYINIT 93977 . 98749) (\DISPLAYSTREAMTYPEBPP 98751 .
|
||||
99006)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
528
sources/LLETHER
528
sources/LLETHER
@@ -1,15 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(FILECREATED " 3-May-2021 23:13:56" {DSK}<home>larry>ilisp>medley>sources>LLETHER.;4 139646
|
||||
|
||||
changes to%: (FNS \ETHEREVENTFN \ETHER-AVAILABLE)
|
||||
(VARS LLETHERCOMS)
|
||||
(FILECREATED "23-Jan-2026 12:42:02" {DSK}<Users>briggs>PROJECTS>Medley>sources>LLETHER.;4 138728
|
||||
|
||||
previous date%: " 2-May-2021 12:37:02" {DSK}<home>larry>ilisp>medley>sources>LLETHER.;3)
|
||||
:EDIT-BY nhb
|
||||
|
||||
:CHANGES-TO (FNS \SETETHERFLAGS)
|
||||
|
||||
:PREVIOUS-DATE "20-Dec-2025 14:12:06" {DSK}<Users>briggs>PROJECTS>Medley>sources>LLETHER.;3)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT LLETHERCOMS)
|
||||
|
||||
@@ -17,19 +15,19 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
[(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (SOURCE)
|
||||
LLNSDECLS))
|
||||
[COMS (* ;
|
||||
"Stuff that should be somewhere else!")
|
||||
"Stuff that should be somewhere else!")
|
||||
(INITVARS (ERRORMESSAGESTREAM T)
|
||||
(PROMPTWINDOW T))
|
||||
(GLOBALVARS ERRORMESSAGESTREAM PROMPTWINDOW)
|
||||
(COMS (* ;
|
||||
"Queue management for data which can be chain-linked through the first cell")
|
||||
"Queue management for data which can be chain-linked through the first cell")
|
||||
(DECLARE%: DONTCOPY (EXPORT (RECORDS SYSQUEUE QABLEITEM)
|
||||
(MACROS \QUEUEHEAD)))
|
||||
(INITRECORDS SYSQUEUE)
|
||||
(SYSRECORDS SYSQUEUE)
|
||||
(FNS CANONICAL.HOSTNAME \ENQUEUE \DEQUEUE \QUEUELENGTH \ONQUEUE \UNQUEUE)
|
||||
(* ;
|
||||
"Queue management constructed by TCONC")
|
||||
"Queue management constructed by TCONC")
|
||||
(EXPORT (MACROS \DETCONC \ENTCONC \PEEKTCONC]
|
||||
(COMS (* ; "General packet management")
|
||||
(DECLARE%: DONTCOPY
|
||||
@@ -124,7 +122,7 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (GLOBALVARS \CENTICLOCKFACTOR \CENTICLOCKBOX)
|
||||
(RECORDS CENTICLOCK)))
|
||||
(COMS (* ;
|
||||
"3MB stuff, which is not needed in DandeLion")
|
||||
"3MB stuff, which is not needed in DandeLion")
|
||||
(FNS \3MBGETPACKET \3MB.CREATENDB \3MBSENDPACKET \3MBWATCHER \3MBENCAPSULATE
|
||||
\3MB.BROADCASTP \3MBFLUSH)
|
||||
(INITVARS (\MAXWATCHERGETS 5))
|
||||
@@ -168,19 +166,18 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE SYSQUEUE ((NIL BYTE)
|
||||
(SYSQUEUEHEAD POINTER)
|
||||
(NIL BYTE)
|
||||
(SYSQUEUETAIL POINTER)))
|
||||
(SYSQUEUEHEAD POINTER)
|
||||
(NIL BYTE)
|
||||
(SYSQUEUETAIL POINTER)))
|
||||
|
||||
(BLOCKRECORD QABLEITEM ((NIL BITS 4)
|
||||
(QLINK POINTER) (* ;
|
||||
"Link to next thing in queue always in first pointer of datum, independent of what the datum is")
|
||||
)
|
||||
(BLOCKRECORD QABLEITEM ((NIL BITS 4)
|
||||
(LINK POINTER)
|
||||
(* ;
|
||||
"Let's also be able to call it a LINK")
|
||||
)))
|
||||
(QLINK POINTER) (* ;
|
||||
"Link to next thing in queue always in first pointer of datum, independent of what the datum is")
|
||||
)
|
||||
(BLOCKRECORD QABLEITEM ((NIL BITS 4)
|
||||
(LINK POINTER)(* ;
|
||||
"Let's also be able to call it a LINK")
|
||||
)))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'SYSQUEUE '(BYTE POINTER BYTE POINTER)
|
||||
@@ -192,7 +189,7 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \QUEUEHEAD MACRO ((Q)
|
||||
(fetch (SYSQUEUE SYSQUEUEHEAD) of Q)))
|
||||
(fetch (SYSQUEUE SYSQUEUEHEAD) of Q)))
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
@@ -208,9 +205,9 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR SYSTEMRECLST
|
||||
|
||||
(DATATYPE SYSQUEUE ((NIL BYTE)
|
||||
(SYSQUEUEHEAD POINTER)
|
||||
(NIL BYTE)
|
||||
(SYSQUEUETAIL POINTER)))
|
||||
(SYSQUEUEHEAD POINTER)
|
||||
(NIL BYTE)
|
||||
(SYSQUEUETAIL POINTER)))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -362,9 +359,9 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \DETCONC MACRO [OPENLAMBDA (TQ)
|
||||
(PROG1 (\PEEKTCONC TQ)
|
||||
(if [NULL (CAR (RPLACA TQ (CDAR TQ]
|
||||
then (RPLACD TQ)))])
|
||||
(PROG1 (\PEEKTCONC TQ)
|
||||
(if [NULL (CAR (RPLACA TQ (CDAR TQ]
|
||||
then (RPLACD TQ)))])
|
||||
|
||||
(PUTPROPS \ENTCONC MACRO (= . TCONC))
|
||||
|
||||
@@ -382,48 +379,48 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE ETHERPACKET ((NIL BYTE)
|
||||
(EPLINK POINTER) (* ; "For queue maintenence")
|
||||
(EPFLAGS BYTE) (* ;
|
||||
"optional flags for some applications")
|
||||
(EPUSERFIELD POINTER) (* ;
|
||||
"Arbitrary pointer for applications")
|
||||
(NIL BYTE)
|
||||
(EPPLIST POINTER) (* ;
|
||||
"Extra field for use as an A-list for properties")
|
||||
(EPTRANSMITTING FLAG) (* ;
|
||||
"True while packet is being transmitted and hence cannot be reused")
|
||||
(EPRECEIVING FLAG) (* ;
|
||||
"True when a packet has been seen at the head of the network's input queue at least once")
|
||||
(NIL BITS 6)
|
||||
(EPREQUEUE POINTER) (* ;
|
||||
"Where to requeue this packet after transmission")
|
||||
(NIL BYTE)
|
||||
(EPSOCKET POINTER)
|
||||
(NIL BYTE)
|
||||
(EPNETWORK POINTER)
|
||||
(EPTYPE WORD) (* ;
|
||||
"Type of packet to be encapsulated (PUP or XIP or 10TO3)")
|
||||
(NIL WORD)
|
||||
(EPTIMESTAMP FIXP) (* ;
|
||||
"Gets RCLK value when transmitted/received")
|
||||
(EPREQUEUEFN POINTER) (* ; "FN to perform requeueing")
|
||||
(NIL 4 WORD) (* ; "Space for expansion")
|
||||
(EPLINK POINTER) (* ; "For queue maintenence")
|
||||
(EPFLAGS BYTE) (* ;
|
||||
"optional flags for some applications")
|
||||
(EPUSERFIELD POINTER) (* ;
|
||||
"Arbitrary pointer for applications")
|
||||
(NIL BYTE)
|
||||
(EPPLIST POINTER) (* ;
|
||||
"Extra field for use as an A-list for properties")
|
||||
(EPTRANSMITTING FLAG) (* ;
|
||||
"True while packet is being transmitted and hence cannot be reused")
|
||||
(EPRECEIVING FLAG) (* ;
|
||||
"True when a packet has been seen at the head of the network's input queue at least once")
|
||||
(NIL BITS 6)
|
||||
(EPREQUEUE POINTER) (* ;
|
||||
"Where to requeue this packet after transmission")
|
||||
(NIL BYTE)
|
||||
(EPSOCKET POINTER)
|
||||
(NIL BYTE)
|
||||
(EPNETWORK POINTER)
|
||||
(EPTYPE WORD) (* ;
|
||||
"Type of packet to be encapsulated (PUP or XIP or 10TO3)")
|
||||
(NIL WORD)
|
||||
(EPTIMESTAMP FIXP) (* ;
|
||||
"Gets RCLK value when transmitted/received")
|
||||
(EPREQUEUEFN POINTER) (* ; "FN to perform requeueing")
|
||||
(NIL 4 WORD) (* ; "Space for expansion")
|
||||
(* ;
|
||||
"Note: This next field wants to be quad+2 aligned so that the 10mb packet is quad+3 aligned")
|
||||
(EPENCAPSULATION 8 WORD) (* ;
|
||||
"10mb encapsulation, or 3mb encapsulation with padding")
|
||||
(EPBODY 289 WORD) (* ;
|
||||
"Body of packet, header up to 16 words plus data up to 546 bytes")
|
||||
))
|
||||
"Note: This next field wants to be quad+2 aligned so that the 10mb packet is quad+3 aligned")
|
||||
(EPENCAPSULATION 8 WORD) (* ;
|
||||
"10mb encapsulation, or 3mb encapsulation with padding")
|
||||
(EPBODY 289 WORD) (* ;
|
||||
"Body of packet, header up to 16 words plus data up to 546 bytes")
|
||||
))
|
||||
|
||||
(ACCESSFNS ETHERAUX ((AUXPTR (CDR (ASSOC 'AUXPTR (fetch EPPLIST of DATUM)))
|
||||
(\EP.PUT.AUX DATUM 'AUXPTR NEWVALUE))
|
||||
(AUXWORD (OR (CDR (ASSOC 'AUXWORD (fetch EPPLIST of DATUM)))
|
||||
0)
|
||||
(\EP.PUT.AUX DATUM 'AUXWORD NEWVALUE))
|
||||
(AUXBYTE (OR (CDR (ASSOC 'AUXBYTE (fetch EPPLIST of DATUM)))
|
||||
0)
|
||||
(\EP.PUT.AUX DATUM 'AUXBYTE NEWVALUE))))
|
||||
(\EP.PUT.AUX DATUM 'AUXPTR NEWVALUE))
|
||||
(AUXWORD (OR (CDR (ASSOC 'AUXWORD (fetch EPPLIST of DATUM)))
|
||||
0)
|
||||
(\EP.PUT.AUX DATUM 'AUXWORD NEWVALUE))
|
||||
(AUXBYTE (OR (CDR (ASSOC 'AUXBYTE (fetch EPPLIST of DATUM)))
|
||||
0)
|
||||
(\EP.PUT.AUX DATUM 'AUXBYTE NEWVALUE))))
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'ETHERPACKET
|
||||
@@ -1140,26 +1137,26 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR SYSTEMRECLST
|
||||
|
||||
(DATATYPE ETHERPACKET ((NIL BYTE)
|
||||
(EPLINK POINTER)
|
||||
(EPFLAGS BYTE)
|
||||
(EPUSERFIELD POINTER)
|
||||
(NIL BYTE)
|
||||
(EPPLIST POINTER)
|
||||
(EPTRANSMITTING FLAG)
|
||||
(EPRECEIVING FLAG)
|
||||
(NIL BITS 6)
|
||||
(EPREQUEUE POINTER)
|
||||
(NIL BYTE)
|
||||
(EPSOCKET POINTER)
|
||||
(NIL BYTE)
|
||||
(EPNETWORK POINTER)
|
||||
(EPTYPE WORD)
|
||||
(NIL WORD)
|
||||
(EPTIMESTAMP FIXP)
|
||||
(EPREQUEUEFN POINTER)
|
||||
(NIL 4 WORD)
|
||||
(EPENCAPSULATION 8 WORD)
|
||||
(EPBODY 289 WORD)))
|
||||
(EPLINK POINTER)
|
||||
(EPFLAGS BYTE)
|
||||
(EPUSERFIELD POINTER)
|
||||
(NIL BYTE)
|
||||
(EPPLIST POINTER)
|
||||
(EPTRANSMITTING FLAG)
|
||||
(EPRECEIVING FLAG)
|
||||
(NIL BITS 6)
|
||||
(EPREQUEUE POINTER)
|
||||
(NIL BYTE)
|
||||
(EPSOCKET POINTER)
|
||||
(NIL BYTE)
|
||||
(EPNETWORK POINTER)
|
||||
(EPTYPE WORD)
|
||||
(NIL WORD)
|
||||
(EPTIMESTAMP FIXP)
|
||||
(EPREQUEUEFN POINTER)
|
||||
(NIL 4 WORD)
|
||||
(EPENCAPSULATION 8 WORD)
|
||||
(EPBODY 289 WORD)))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -1499,21 +1496,19 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
HOSTNAMEP _ 'NILL])
|
||||
|
||||
(\ETHEREVENTFN
|
||||
[LAMBDA (DEV EVENT) (* ; "Edited 3-May-2021 23:12 by larry")
|
||||
[LAMBDA (DEV EVENT) (* ; "Edited 17-Dec-2025 11:01 by nhb")
|
||||
(* ; "Edited 3-May-2021 23:12 by larry")
|
||||
(PROG (NDB TURNOFFNS TIMESET)
|
||||
(SELECTQ EVENT
|
||||
((NIL AFTERLOGOUT AFTERSYSOUT AFTERMAKESYS AFTERSAVEVM RESTART)
|
||||
(SETQ \PUP.READY (SETQ \NS.READY (SETQ \IP.READY)))
|
||||
(OR (\ETHER-AVAILABLE)
|
||||
(RETURN))
|
||||
(\SETETHERFLAGS)
|
||||
(\SETLOCALNSNUMBERS)
|
||||
(\FLUSHNDBS EVENT)
|
||||
(SETQ \10MBLOCALNDB (COND
|
||||
(\10MBFLG (SETQ NDB (\10MB.CREATENDB \10MBFLG))
|
||||
(COND
|
||||
(\LOCALNDBS (replace NDBNEXT of
|
||||
\LOCALNDBS
|
||||
(\LOCALNDBS (replace NDBNEXT of \LOCALNDBS
|
||||
with NDB))
|
||||
(T (SETQ \LOCALNDBS NDB)))
|
||||
NDB)))
|
||||
@@ -1536,10 +1531,10 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
((BEFOREMAKESYS BEFORELOGOUT BEFORESYSOUT BEFORESAVEVM)
|
||||
(COND
|
||||
((EQ EVENT 'BEFORESAVEVM) (* ;
|
||||
"Save passwords in place outside vmem to avoid having to reenter them later")
|
||||
"Save passwords in place outside vmem to avoid having to reenter them later")
|
||||
(\STASH.PASSWORDS))
|
||||
(T (* ;
|
||||
"No need to flush this before SAVEVM")
|
||||
"No need to flush this before SAVEVM")
|
||||
(CLRHASH \ETHERPORTS)))
|
||||
(CLRHASH LOGINPASSWORDS))
|
||||
NIL])
|
||||
@@ -1556,11 +1551,13 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(printout PROMPTWINDOW T "[Time not set]"])
|
||||
|
||||
(\SETETHERFLAGS
|
||||
[LAMBDA NIL (* ; "Edited 2-May-2021 12:35 by larry")
|
||||
[LAMBDA NIL (* ; "Edited 23-Jan-2026 12:39 by nhb")
|
||||
(* ; "Edited 2-May-2021 12:35 by larry")
|
||||
|
||||
(* ;; "for Medley there is no 3MB ethernet ; used to be conditional on \MACHINETYPE")
|
||||
|
||||
(SETQ \10MBFLG 0)
|
||||
(SETQ \10MBFLG (AND (\ETHER-AVAILABLE)
|
||||
0))
|
||||
(SETQ \3MBFLG NIL)
|
||||
(SETQ *MAXIMUM-PACKET-SIZE* (- (TIMES 2 BYTESPERPAGE)
|
||||
(UNFOLD (INDEXF (FETCH EPBODY))
|
||||
@@ -1706,40 +1703,40 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTCOPY
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE NDB ((NETTYPE BYTE) (* ; "10 or 3 for now")
|
||||
(NDBNEXT POINTER) (* ; "Link to next NDB")
|
||||
(NDBPUPNET# BYTE) (* ;
|
||||
"Pup number of this net. May be different from NS net number, though not in Xerox world")
|
||||
(NDBNSNET# POINTER) (* ;
|
||||
"Can be 32-bits, so might as well leave its box around")
|
||||
(NDBTASK# BYTE) (* ; "Task # of this network")
|
||||
(NDBBROADCASTP POINTER) (* ;
|
||||
"Function that returns true if packet is of broadcast type")
|
||||
(NDBPUPHOST# BYTE) (* ;
|
||||
"My pup address on this net. NS address is global to all nets, so not needed here")
|
||||
(NDBTRANSMITTER POINTER) (* ;
|
||||
"(NDB PACKET) -- fn to send a raw packet on this net. returns NIL on failure")
|
||||
(NIL BYTE)
|
||||
(NDBENCAPSULATOR POINTER) (* ;
|
||||
"(NDB PACKET HOST LENGTH TYPE) -- fn to encapsulate and send a higher-level packet on this net ")
|
||||
(NDBCSB POINTER) (* ; "Pointer to CSB for this network")
|
||||
(NDBIQLENGTH BYTE)
|
||||
(NDBIQ POINTER) (* ;
|
||||
"Queue of empty packets for receiver")
|
||||
(NDBTQ POINTER) (* ; "Queue of packets to transmit")
|
||||
(NDBTRANSLATIONS POINTER) (* ;
|
||||
"Cache of translations, 3:10 or 10:3 according to network")
|
||||
(NDBETHERFLUSHER POINTER) (* ; "Turns off this ether. Args NDB")
|
||||
(NDBWATCHER POINTER)
|
||||
(NDBCANHEARSELF POINTER) (* ;
|
||||
"True if receiver can hear packets sent by transmitter")
|
||||
(NDBIPNET# POINTER)
|
||||
(NDBIPHOST# POINTER)
|
||||
(NDBPUPTYPE WORD) (* ;
|
||||
"The packet encapsulation of PUP on this net")
|
||||
(NIL WORD)
|
||||
(NIL POINTER) (* ; "Spares")
|
||||
))
|
||||
(DATATYPE NDB ((NETTYPE BYTE) (* ; "10 or 3 for now")
|
||||
(NDBNEXT POINTER) (* ; "Link to next NDB")
|
||||
(NDBPUPNET# BYTE) (* ;
|
||||
"Pup number of this net. May be different from NS net number, though not in Xerox world")
|
||||
(NDBNSNET# POINTER) (* ;
|
||||
"Can be 32-bits, so might as well leave its box around")
|
||||
(NDBTASK# BYTE) (* ; "Task # of this network")
|
||||
(NDBBROADCASTP POINTER) (* ;
|
||||
"Function that returns true if packet is of broadcast type")
|
||||
(NDBPUPHOST# BYTE) (* ;
|
||||
"My pup address on this net. NS address is global to all nets, so not needed here")
|
||||
(NDBTRANSMITTER POINTER) (* ;
|
||||
"(NDB PACKET) -- fn to send a raw packet on this net. returns NIL on failure")
|
||||
(NIL BYTE)
|
||||
(NDBENCAPSULATOR POINTER) (* ;
|
||||
"(NDB PACKET HOST LENGTH TYPE) -- fn to encapsulate and send a higher-level packet on this net ")
|
||||
(NDBCSB POINTER) (* ; "Pointer to CSB for this network")
|
||||
(NDBIQLENGTH BYTE)
|
||||
(NDBIQ POINTER) (* ;
|
||||
"Queue of empty packets for receiver")
|
||||
(NDBTQ POINTER) (* ; "Queue of packets to transmit")
|
||||
(NDBTRANSLATIONS POINTER) (* ;
|
||||
"Cache of translations, 3:10 or 10:3 according to network")
|
||||
(NDBETHERFLUSHER POINTER) (* ; "Turns off this ether. Args NDB")
|
||||
(NDBWATCHER POINTER)
|
||||
(NDBCANHEARSELF POINTER) (* ;
|
||||
"True if receiver can hear packets sent by transmitter")
|
||||
(NDBIPNET# POINTER)
|
||||
(NDBIPHOST# POINTER)
|
||||
(NDBPUPTYPE WORD) (* ;
|
||||
"The packet encapsulation of PUP on this net")
|
||||
(NIL WORD)
|
||||
(NIL POINTER) (* ; "Spares")
|
||||
))
|
||||
|
||||
(RECORD ROUTING (RTNET# RTHOPCOUNT RTGATEWAY# RTNDB RTTIMER RTRECENT))
|
||||
)
|
||||
@@ -1786,26 +1783,24 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS ENCAPSULATE.ETHERPACKET MACRO ((NDB PACKET HOST LENGTH TYPE)
|
||||
(SPREADAPPLY* (fetch NDBENCAPSULATOR
|
||||
of NDB)
|
||||
NDB PACKET HOST LENGTH TYPE)))
|
||||
(SPREADAPPLY* (fetch NDBENCAPSULATOR of NDB)
|
||||
NDB PACKET HOST LENGTH TYPE)))
|
||||
|
||||
(PUTPROPS TRANSMIT.ETHERPACKET MACRO ((NDB PACKET)
|
||||
(SPREADAPPLY* (fetch NDBTRANSMITTER of NDB)
|
||||
NDB PACKET)))
|
||||
(SPREADAPPLY* (fetch NDBTRANSMITTER of NDB)
|
||||
NDB PACKET)))
|
||||
|
||||
(PUTPROPS BROADCASTP MACRO ((PACKET)
|
||||
([LAMBDA (NDB)
|
||||
(AND NDB (APPLY* (fetch NDBBROADCASTP of NDB)
|
||||
PACKET NDB]
|
||||
(fetch EPNETWORK of PACKET))))
|
||||
([LAMBDA (NDB)
|
||||
(AND NDB (APPLY* (fetch NDBBROADCASTP of NDB)
|
||||
PACKET NDB]
|
||||
(fetch EPNETWORK of PACKET))))
|
||||
|
||||
(PUTPROPS \CHECK.ROUTING.TABLE MACRO [(TABLE)
|
||||
(if (NEQ (NTYPX TABLE)
|
||||
\ROUTING.TABLE.TYPENUM)
|
||||
then (CL:ERROR 'CONDITIONS:SIMPLE-TYPE-ERROR
|
||||
:CULPRIT TABLE :EXPECTED-TYPE
|
||||
'RoutingTable])
|
||||
(if (NEQ (NTYPX TABLE)
|
||||
\ROUTING.TABLE.TYPENUM)
|
||||
then (CL:ERROR 'CONDITIONS:SIMPLE-TYPE-ERROR :CULPRIT TABLE
|
||||
:EXPECTED-TYPE 'RoutingTable])
|
||||
)
|
||||
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
@@ -1851,28 +1846,28 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR SYSTEMRECLST
|
||||
|
||||
(DATATYPE NDB ((NETTYPE BYTE)
|
||||
(NDBNEXT POINTER)
|
||||
(NDBPUPNET# BYTE)
|
||||
(NDBNSNET# POINTER)
|
||||
(NDBTASK# BYTE)
|
||||
(NDBBROADCASTP POINTER)
|
||||
(NDBPUPHOST# BYTE)
|
||||
(NDBTRANSMITTER POINTER)
|
||||
(NIL BYTE)
|
||||
(NDBENCAPSULATOR POINTER)
|
||||
(NDBCSB POINTER)
|
||||
(NDBIQLENGTH BYTE)
|
||||
(NDBIQ POINTER)
|
||||
(NDBTQ POINTER)
|
||||
(NDBTRANSLATIONS POINTER)
|
||||
(NDBETHERFLUSHER POINTER)
|
||||
(NDBWATCHER POINTER)
|
||||
(NDBCANHEARSELF POINTER)
|
||||
(NDBIPNET# POINTER)
|
||||
(NDBIPHOST# POINTER)
|
||||
(NDBPUPTYPE WORD)
|
||||
(NIL WORD)
|
||||
(NIL POINTER)))
|
||||
(NDBNEXT POINTER)
|
||||
(NDBPUPNET# BYTE)
|
||||
(NDBNSNET# POINTER)
|
||||
(NDBTASK# BYTE)
|
||||
(NDBBROADCASTP POINTER)
|
||||
(NDBPUPHOST# BYTE)
|
||||
(NDBTRANSMITTER POINTER)
|
||||
(NIL BYTE)
|
||||
(NDBENCAPSULATOR POINTER)
|
||||
(NDBCSB POINTER)
|
||||
(NDBIQLENGTH BYTE)
|
||||
(NDBIQ POINTER)
|
||||
(NDBTQ POINTER)
|
||||
(NDBTRANSLATIONS POINTER)
|
||||
(NDBETHERFLUSHER POINTER)
|
||||
(NDBWATCHER POINTER)
|
||||
(NDBCANHEARSELF POINTER)
|
||||
(NDBIPNET# POINTER)
|
||||
(NDBIPHOST# POINTER)
|
||||
(NDBPUPTYPE WORD)
|
||||
(NIL WORD)
|
||||
(NIL POINTER)))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -2231,48 +2226,49 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS ETHERTRANS [(TRANSBODY (LOCF (fetch (ETHERPACKET EPBODY) of DATUM]
|
||||
[BLOCKRECORD TRANSBODY ((TRANSOPERATION WORD)
|
||||
[BLOCKRECORD TRANSBODY ((TRANSOPERATION WORD)
|
||||
(* ; "Request or response")
|
||||
(BASETRANSNSHOST 3 WORD)
|
||||
(BASETRANSNSHOST 3 WORD)
|
||||
(* ; "Known or desired NS address")
|
||||
(TRANSPUPHOST BYTE)
|
||||
(TRANSPUPHOST BYTE)
|
||||
(* ; "Known or desired PUP address")
|
||||
(NIL BYTE) (* ; "Padding")
|
||||
(BASETRANSSENDERNSHOST 3 WORD)
|
||||
(NIL BYTE) (* ; "Padding")
|
||||
(BASETRANSSENDERNSHOST 3 WORD)
|
||||
(* ; "Sender's info")
|
||||
(TRANSSENDERPUPHOST BYTE)
|
||||
(NIL BYTE))
|
||||
[ACCESSFNS BASETRANSNSHOST ((TRANSNSHOST (\LOADNSHOSTNUMBER
|
||||
(LOCF DATUM))
|
||||
(\STORENSHOSTNUMBER (LOCF DATUM)
|
||||
NEWVALUE]
|
||||
(ACCESSFNS BASETRANSSENDERNSHOST ((TRANSSENDERNSHOST
|
||||
(\LOADNSHOSTNUMBER (LOCF DATUM))
|
||||
(\STORENSHOSTNUMBER (LOCF DATUM)
|
||||
NEWVALUE]
|
||||
[ACCESSFNS ETHERTRANS
|
||||
([TRANSNSADDRESS
|
||||
(PROGN (* ;
|
||||
"Kludge to get a pointer that looks like a full ns address")
|
||||
(\ADDBASE DATUM (CONSTANT (+ (INDEXF (FETCH
|
||||
(ETHERPACKET EPBODY)
|
||||
of T))
|
||||
(INDEXF (FETCH
|
||||
(ETHERTRANS
|
||||
(TRANSSENDERPUPHOST BYTE)
|
||||
(NIL BYTE))
|
||||
[ACCESSFNS BASETRANSNSHOST ((TRANSNSHOST (\LOADNSHOSTNUMBER (LOCF DATUM)
|
||||
)
|
||||
(\STORENSHOSTNUMBER (LOCF DATUM)
|
||||
NEWVALUE]
|
||||
(ACCESSFNS BASETRANSSENDERNSHOST ((TRANSSENDERNSHOST (\LOADNSHOSTNUMBER
|
||||
(LOCF DATUM))
|
||||
(\STORENSHOSTNUMBER
|
||||
(LOCF DATUM)
|
||||
NEWVALUE]
|
||||
[ACCESSFNS ETHERTRANS
|
||||
([TRANSNSADDRESS (PROGN (* ;
|
||||
"Kludge to get a pointer that looks like a full ns address")
|
||||
(\ADDBASE
|
||||
DATUM
|
||||
(CONSTANT (+ (INDEXF (FETCH (ETHERPACKET EPBODY
|
||||
)
|
||||
of T))
|
||||
(INDEXF (FETCH (ETHERTRANS
|
||||
BASETRANSNSHOST
|
||||
) of
|
||||
T))
|
||||
-2]
|
||||
(TRANSSENDERNSADDRESS
|
||||
(\ADDBASE DATUM (CONSTANT (+ (INDEXF (FETCH (ETHERPACKET
|
||||
EPBODY)
|
||||
of T))
|
||||
(INDEXF (FETCH (ETHERTRANS
|
||||
)
|
||||
of T))
|
||||
-2]
|
||||
(TRANSSENDERNSADDRESS (\ADDBASE
|
||||
DATUM
|
||||
(CONSTANT (+ (INDEXF (FETCH (ETHERPACKET EPBODY)
|
||||
of T))
|
||||
(INDEXF (FETCH (ETHERTRANS
|
||||
BASETRANSSENDERNSHOST
|
||||
)
|
||||
of T))
|
||||
-2]
|
||||
(TYPE? (type? ETHERPACKET DATUM)))
|
||||
)
|
||||
of T))
|
||||
-2]
|
||||
(TYPE? (type? ETHERPACKET DATUM)))
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
@@ -2571,7 +2567,7 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(RPAQ? \RAWTRACING )
|
||||
|
||||
(ADDTOVAR \PACKET.PRINTERS (512 . PRINTPUP)
|
||||
(1537 . PRINT10TO3))
|
||||
(1537 . PRINT10TO3))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS \RAWTRACING \PACKET.PRINTERS PUPTRACEFILE XIPTRACEFILE \RCLKMILLISECOND)
|
||||
@@ -2615,7 +2611,7 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(BLOCKRECORD CENTICLOCK ((CENTICLOCKSIGNBIT BITS 1)
|
||||
(CENTICLOCKMAGNITUDE BITS 31)))
|
||||
(CENTICLOCKMAGNITUDE BITS 31)))
|
||||
)
|
||||
)
|
||||
|
||||
@@ -2757,43 +2753,41 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS 3MBENCAPSULATION [(3MBENCAPSTART (LOCF (fetch (ETHERPACKET EPENCAPSULATION)
|
||||
of DATUM]
|
||||
(BLOCKRECORD 3MBENCAPSTART ((NIL 5 WORD)
|
||||
(ACCESSFNS 3MBENCAPSULATION [(3MBENCAPSTART (LOCF (fetch (ETHERPACKET EPENCAPSULATION) of DATUM]
|
||||
(BLOCKRECORD 3MBENCAPSTART ((NIL 5 WORD)
|
||||
(* ; "waste space")
|
||||
(3MBLENGTH WORD)
|
||||
(3MBLENGTH WORD)
|
||||
(* ;
|
||||
"Length of packet in words, starting at the next word")
|
||||
(3MBDESTHOST BYTE)
|
||||
"Length of packet in words, starting at the next word")
|
||||
(3MBDESTHOST BYTE)
|
||||
(* ; "Immediate destination host")
|
||||
(3MBSOURCEHOST BYTE)
|
||||
(3MBSOURCEHOST BYTE)
|
||||
(* ; "Us")
|
||||
(3MBTYPE WORD)
|
||||
(3MBTYPE WORD)
|
||||
(* ;
|
||||
"Type of packet -- PUP or XIP or 10TO3")
|
||||
)
|
||||
[ACCESSFNS 3MBLENGTH ((3MBBASE (LOCF DATUM]
|
||||
"Type of packet -- PUP or XIP or 10TO3")
|
||||
)
|
||||
[ACCESSFNS 3MBLENGTH ((3MBBASE (LOCF DATUM]
|
||||
(* ; "What to hand to BCPL")
|
||||
)
|
||||
(TYPE? (type? ETHERPACKET DATUM)))
|
||||
)
|
||||
(TYPE? (type? ETHERPACKET DATUM)))
|
||||
|
||||
(BLOCKRECORD PBI ((PBILINK WORD)
|
||||
(PBIQUEUE WORD)
|
||||
(PBISOCKET WORD)
|
||||
(PBINDB WORD)
|
||||
(PBIINPUTP FLAG)
|
||||
(PBIALLNETSP FLAG)
|
||||
(PBINOZEROP FLAG)
|
||||
(NIL BITS 13)
|
||||
(PBITIMER WORD)
|
||||
(PBILENGTH WORD)
|
||||
(PBIENCAPSULATION 2 WORD)
|
||||
(PBIFIRSTPUPWORD 10 WORD)
|
||||
(PBIFIRSTPUPDATAWORD WORD))
|
||||
[ACCESSFNS PBI ((PBIPUPSTART (LOCF (fetch PBIFIRSTPUPWORD of DATUM)))
|
||||
(PBIPUPDATASTART (LOCF (fetch PBIFIRSTPUPDATAWORD
|
||||
of DATUM)))
|
||||
(PBIRAWSTART (LOCF (fetch PBILENGTH of DATUM])
|
||||
(PBIQUEUE WORD)
|
||||
(PBISOCKET WORD)
|
||||
(PBINDB WORD)
|
||||
(PBIINPUTP FLAG)
|
||||
(PBIALLNETSP FLAG)
|
||||
(PBINOZEROP FLAG)
|
||||
(NIL BITS 13)
|
||||
(PBITIMER WORD)
|
||||
(PBILENGTH WORD)
|
||||
(PBIENCAPSULATION 2 WORD)
|
||||
(PBIFIRSTPUPWORD 10 WORD)
|
||||
(PBIFIRSTPUPDATAWORD WORD))
|
||||
[ACCESSFNS PBI ((PBIPUPSTART (LOCF (fetch PBIFIRSTPUPWORD of DATUM)))
|
||||
(PBIPUPDATASTART (LOCF (fetch PBIFIRSTPUPDATAWORD of DATUM)))
|
||||
(PBIRAWSTART (LOCF (fetch PBILENGTH of DATUM])
|
||||
)
|
||||
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
@@ -2879,8 +2873,8 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
T])
|
||||
)
|
||||
|
||||
(RPAQQ ROUTINGINFOMACRO (1 "Operation = " WORDS 2 "Info: " REPEAT "(" SEPR ", " INTEGER -4 WORDS
|
||||
SEPR ") " -2 FINALLY ")"))
|
||||
(RPAQQ ROUTINGINFOMACRO (1 "Operation = " WORDS 2 "Info: " REPEAT "(" SEPR ", " INTEGER -4 WORDS SEPR
|
||||
") " -2 FINALLY ")"))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
@@ -2913,10 +2907,10 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTCOPY
|
||||
|
||||
(RPAQQ D0DEVICES ((\DEVICE.3MBETHERIN 7)
|
||||
(\DEVICE.3MBETHEROUT 6)
|
||||
(\DEVICE.10MBETHER 21)
|
||||
(\DEVICE.SA4000 3)
|
||||
(\DEVICE.DISPLAY 2)))
|
||||
(\DEVICE.3MBETHEROUT 6)
|
||||
(\DEVICE.10MBETHER 21)
|
||||
(\DEVICE.SA4000 3)
|
||||
(\DEVICE.DISPLAY 2)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ \DEVICE.3MBETHERIN 7)
|
||||
@@ -2947,33 +2941,31 @@ Copyright (c) 1982-1988, 1990-1993, 2021 by Venue & Xerox Corporation.
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
)
|
||||
(PUTPROPS LLETHER COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1988 1990 1991
|
||||
1992 1993 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (10792 19248 (CANONICAL.HOSTNAME 10802 . 12391) (\ENQUEUE 12393 . 15038) (\DEQUEUE 15040
|
||||
. 16367) (\QUEUELENGTH 16369 . 16669) (\ONQUEUE 16671 . 16937) (\UNQUEUE 16939 . 19246)) (52949 56815
|
||||
(\ALLOCATE.ETHERPACKET 52959 . 54000) (\RELEASE.ETHERPACKET 54002 . 55075) (RELEASE.PUP 55077 . 55222
|
||||
) (\FLUSH.PACKET.QUEUE 55224 . 55575) (\REQUEUE.ETHERPACKET 55577 . 56091) (\EP.PUT.AUX 56093 . 56813)
|
||||
) (57389 68770 (\SETLOCALNSNUMBERS 57399 . 58784) (\LOADNSADDRESS 58786 . 59078) (\STORENSADDRESS
|
||||
59080 . 59261) (\PRINTNSADDRESS 59263 . 60346) (\NSADDRESS.DEFPRINT 60348 . 65293) (
|
||||
\NSADDRESS.PRINT.DECIMAL 65295 . 67426) (\LOADNSHOSTNUMBER 67428 . 68057) (\STORENSHOSTNUMBER 68059 .
|
||||
68463) (PRINTNSHOSTNUMBER 68465 . 68768)) (68883 74631 (\ETHERINIT 68893 . 69463) (\ETHEREVENTFN 69465
|
||||
. 71997) (\ETHER-AVAILABLE 71999 . 72157) (\TIME.NOT.SET 72159 . 72485) (\SETETHERFLAGS 72487 . 72938
|
||||
) (\FLUSHNDBS 72940 . 74118) (\FLUSH.NDB.QUEUE 74120 . 74629)) (74632 77924 (\CHECKSUM 74642 . 76574)
|
||||
(\HANDLE.RAW.OTHER 76576 . 76931) (\HANDLE.RAW.PACKET 76933 . 77445) (\ADD.PACKET.FILTER 77447 . 77679
|
||||
) (\DEL.PACKET.FILTER 77681 . 77922)) (85757 86282 (ENCAPSULATE.ETHERPACKET 85767 . 86039) (
|
||||
TRANSMIT.ETHERPACKET 86041 . 86280)) (86570 99166 (\AGE.ROUTING.TABLE 86580 . 88729) (
|
||||
\ADD.ROUTING.TABLE.ENTRY 88731 . 89427) (\CLEAR.ROUTING.TABLE 89429 . 90156) (\MAP.ROUTING.TABLE 90158
|
||||
. 90686) (PRINTROUTINGTABLE 90688 . 94313) (\ROUTINGTABLE.INFOHOOK 94315 . 99164)) (99651 106436 (
|
||||
\TRANSLATE.10TO3 99661 . 101445) (\NOTE.10TO3 101447 . 103063) (\HANDLE.RAW.10TO3 103065 . 106434)) (
|
||||
110418 125240 (PRINTPACKET 110428 . 110989) (\MAYBEPRINTPACKET 110991 . 112648) (PRINT10TO3 112650 .
|
||||
114018) (PRINTPACKETDATA 114020 . 119310) (PRINTPACKETQUEUE 119312 . 119741) (TIME.SINCE.PACKET 119743
|
||||
. 120228) (MAKE-NETWORK-TRACE-WINDOW 120230 . 123772) (\CHANGE.ETHER.TRACING 123774 . 125238)) (
|
||||
125611 126426 (\CENTICLOCK 125621 . 126424)) (126881 132981 (\3MBGETPACKET 126891 . 128311) (
|
||||
\3MB.CREATENDB 128313 . 129028) (\3MBSENDPACKET 129030 . 131213) (\3MBWATCHER 131215 . 131953) (
|
||||
\3MBENCAPSULATE 131955 . 132503) (\3MB.BROADCASTP 132505 . 132676) (\3MBFLUSH 132678 . 132979)) (
|
||||
135935 137878 (ASSURE.ETHER.ON 135945 . 136275) (INITPUPLEVEL1 136277 . 136757) (TURN.ON.ETHER 136759
|
||||
. 136904) (RESTART.ETHER 136906 . 137280) (TURN.OFF.ETHER 137282 . 137600) (PRINTWORDS 137602 .
|
||||
137876)) (138153 138688 (\DEVICE.INPUT 138163 . 138328) (\DEVICE.OUTPUT 138330 . 138524) (\D0.STARTIO
|
||||
138526 . 138686)))))
|
||||
(FILEMAP (NIL (10585 19041 (CANONICAL.HOSTNAME 10595 . 12184) (\ENQUEUE 12186 . 14831) (\DEQUEUE 14833
|
||||
. 16160) (\QUEUELENGTH 16162 . 16462) (\ONQUEUE 16464 . 16730) (\UNQUEUE 16732 . 19039)) (52600 56466
|
||||
(\ALLOCATE.ETHERPACKET 52610 . 53651) (\RELEASE.ETHERPACKET 53653 . 54726) (RELEASE.PUP 54728 . 54873
|
||||
) (\FLUSH.PACKET.QUEUE 54875 . 55226) (\REQUEUE.ETHERPACKET 55228 . 55742) (\EP.PUT.AUX 55744 . 56464)
|
||||
) (57040 68421 (\SETLOCALNSNUMBERS 57050 . 58435) (\LOADNSADDRESS 58437 . 58729) (\STORENSADDRESS
|
||||
58731 . 58912) (\PRINTNSADDRESS 58914 . 59997) (\NSADDRESS.DEFPRINT 59999 . 64944) (
|
||||
\NSADDRESS.PRINT.DECIMAL 64946 . 67077) (\LOADNSHOSTNUMBER 67079 . 67708) (\STORENSHOSTNUMBER 67710 .
|
||||
68114) (PRINTNSHOSTNUMBER 68116 . 68419)) (68534 74394 (\ETHERINIT 68544 . 69114) (\ETHEREVENTFN 69116
|
||||
. 71594) (\ETHER-AVAILABLE 71596 . 71754) (\TIME.NOT.SET 71756 . 72082) (\SETETHERFLAGS 72084 . 72701
|
||||
) (\FLUSHNDBS 72703 . 73881) (\FLUSH.NDB.QUEUE 73883 . 74392)) (74395 77687 (\CHECKSUM 74405 . 76337)
|
||||
(\HANDLE.RAW.OTHER 76339 . 76694) (\HANDLE.RAW.PACKET 76696 . 77208) (\ADD.PACKET.FILTER 77210 . 77442
|
||||
) (\DEL.PACKET.FILTER 77444 . 77685)) (85191 85716 (ENCAPSULATE.ETHERPACKET 85201 . 85473) (
|
||||
TRANSMIT.ETHERPACKET 85475 . 85714)) (86004 98600 (\AGE.ROUTING.TABLE 86014 . 88163) (
|
||||
\ADD.ROUTING.TABLE.ENTRY 88165 . 88861) (\CLEAR.ROUTING.TABLE 88863 . 89590) (\MAP.ROUTING.TABLE 89592
|
||||
. 90120) (PRINTROUTINGTABLE 90122 . 93747) (\ROUTINGTABLE.INFOHOOK 93749 . 98598)) (99085 105870 (
|
||||
\TRANSLATE.10TO3 99095 . 100879) (\NOTE.10TO3 100881 . 102497) (\HANDLE.RAW.10TO3 102499 . 105868)) (
|
||||
109860 124682 (PRINTPACKET 109870 . 110431) (\MAYBEPRINTPACKET 110433 . 112090) (PRINT10TO3 112092 .
|
||||
113460) (PRINTPACKETDATA 113462 . 118752) (PRINTPACKETQUEUE 118754 . 119183) (TIME.SINCE.PACKET 119185
|
||||
. 119670) (MAKE-NETWORK-TRACE-WINDOW 119672 . 123214) (\CHANGE.ETHER.TRACING 123216 . 124680)) (
|
||||
125049 125864 (\CENTICLOCK 125059 . 125862)) (126315 132415 (\3MBGETPACKET 126325 . 127745) (
|
||||
\3MB.CREATENDB 127747 . 128462) (\3MBSENDPACKET 128464 . 130647) (\3MBWATCHER 130649 . 131387) (
|
||||
\3MBENCAPSULATE 131389 . 131937) (\3MB.BROADCASTP 131939 . 132110) (\3MBFLUSH 132112 . 132413)) (
|
||||
135157 137100 (ASSURE.ETHER.ON 135167 . 135497) (INITPUPLEVEL1 135499 . 135979) (TURN.ON.ETHER 135981
|
||||
. 136126) (RESTART.ETHER 136128 . 136502) (TURN.OFF.ETHER 136504 . 136822) (PRINTWORDS 136824 .
|
||||
137098)) (137371 137906 (\DEVICE.INPUT 137381 . 137546) (\DEVICE.OUTPUT 137548 . 137742) (\D0.STARTIO
|
||||
137744 . 137904)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "25-Oct-2021 15:12:33" |{DSK}<home>larry>medley>sources>MAIKOETHER.;2| 28792
|
||||
(FILECREATED "30-Dec-2025 19:09:34" |{DSK}<Users>briggs>projects>medley>sources>MAIKOETHER.;7| 26899
|
||||
|
||||
|changes| |to:| (FNS \\DISPLAYLINE)
|
||||
(VARS MAIKOETHERCOMS)
|
||||
:EDIT-BY |nhb|
|
||||
|
||||
|previous| |date:| "25-Mar-2021 09:50:57" |{DSK}<home>larry>medley>sources>MAIKOETHER.;1|)
|
||||
:CHANGES-TO (VARS MAIKOETHERCOMS)
|
||||
|
||||
:PREVIOUS-DATE "30-Dec-2025 18:50:46" |{DSK}<Users>briggs>projects>medley>sources>MAIKOETHER.;6|
|
||||
)
|
||||
|
||||
; Copyright (c) 1988-1991, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT MAIKOETHERCOMS)
|
||||
|
||||
@@ -23,10 +23,6 @@
|
||||
(DECLARE\: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||
10MBDRIVER)
|
||||
(GLOBALVARS \\MAIKO.INPUT.PACKET |\\ETHERtopMonitor|)
|
||||
|
||||
(* |;;| "The NDB for Maiko's 10MB connection; used by \\MAIKO.ETHER-INTERRUPT:")
|
||||
|
||||
(GLOBALVARS \\MAIKO.10MB.NDB)
|
||||
(GLOBALVARS \\MAIKO.IO-INTERRUPT-FLAGS \\MAIKO.IO-INTERRUPT-VECTOR))
|
||||
(ADDVARS (\\MAIKO.MOVDS (\\MAIKO.10MBSTARTDRIVER \\10MB.STARTDRIVER)
|
||||
(\\MAIKO.10MBWATCHER \\10MBWATCHER)
|
||||
@@ -35,9 +31,13 @@
|
||||
(\\MAIKO.10MBTURNONETHER \\10MB.TURNONETHER)
|
||||
(\\MAIKO.ETHERRESUME \\10MB.RESTART.ETHER)
|
||||
(\\MAIKO.CHECKSUM \\CHECKSUM)))
|
||||
(COMS (* \; "MAIKO handler for new interrupt-driven incoming ethernet communication, rather than polling for it.")
|
||||
(COMS
|
||||
(* |;;| "MAIKO handler for new interrupt-driven incoming ethernet communication, rather than polling for it.")
|
||||
|
||||
(FNS \\MAIKO.ETHER-INTERRUPT))
|
||||
(COMS (* \; "MAIKO Log & Console message handling. Interrupt-driven message printing, instead of polled printing.")
|
||||
(COMS
|
||||
(* |;;| "MAIKO Log & Console message handling. Interrupt-driven message printing, instead of polled printing.")
|
||||
|
||||
(FNS \\MAIKO.CONSOLE-LOG-PRINT))
|
||||
(COMS
|
||||
(* |;;| "Asynchronous I/O handling")
|
||||
@@ -48,13 +48,12 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\\10MB.RESTART.ETHER
|
||||
(LAMBDA NIL (* \; "Edited 11-May-88 16:09 by MASINTER")
|
||||
(LAMBDA NIL (* \; "Edited 11-May-88 16:09 by MASINTER")
|
||||
(SUBRCALL ETHER-RESUME)))
|
||||
|
||||
(\\10MB.STARTDRIVER
|
||||
(LAMBDA (NDB RESTARTFLG MYNSNUMBER) (* \; "Edited 5-Apr-89 15:03 by snow")
|
||||
(DECLARE (GLOBALVARS \\MAIKO.INPUT.PACKET \\10MB.EXPECTED.RECEIVE.INTERVAL
|
||||
\\10MB.INPUT.TIMEOUT))
|
||||
(LAMBDA (NDB RESTARTFLG MYNSNUMBER) (* \; "Edited 5-Apr-89 15:03 by snow")
|
||||
(DECLARE (GLOBALVARS \\MAIKO.INPUT.PACKET \\10MB.EXPECTED.RECEIVE.INTERVAL \\10MB.INPUT.TIMEOUT))
|
||||
(SUBRCALL ETHER-SUSPEND)
|
||||
(OR (\\INIT.ETHER.BUFFER.POOL)
|
||||
(ERROR "Unable to create buffer pool"))
|
||||
@@ -65,21 +64,17 @@
|
||||
0 0)
|
||||
(PROG ((CSB (|fetch| NDBCSB |of| NDB)))
|
||||
(OR \\MAIKO.INPUT.PACKET (SETQ \\MAIKO.INPUT.PACKET (\\ALLOCATE.ETHERPACKET)))
|
||||
(|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB) |with|
|
||||
\\ES.PENDING)
|
||||
(SUBRCALL ETHER-GET \\10MBPACKETLENGTH (|fetch| 10MBPACKETBASE |of|
|
||||
\\MAIKO.INPUT.PACKET
|
||||
))
|
||||
(|replace| NDBWATCHER |of| NDB |with| (ADD.PROCESS (LIST '\\10MBWATCHER
|
||||
(KWOTE NDB))
|
||||
'RESTARTABLE
|
||||
'SYSTEM
|
||||
'AFTEREXIT
|
||||
'DELETE))
|
||||
(|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB) |with| \\ES.PENDING)
|
||||
(SUBRCALL ETHER-GET \\10MBPACKETLENGTH (|fetch| 10MBPACKETBASE |of| \\MAIKO.INPUT.PACKET))
|
||||
(|replace| NDBWATCHER |of| NDB |with| (ADD.PROCESS (LIST '\\10MBWATCHER (KWOTE NDB))
|
||||
'RESTARTABLE
|
||||
'SYSTEM
|
||||
'AFTEREXIT
|
||||
'DELETE))
|
||||
(RETURN NDB))))
|
||||
|
||||
(\\10MB.TURNOFFETHER
|
||||
(LAMBDA NIL (* \; "Edited 11-May-88 16:11 by MASINTER")
|
||||
(LAMBDA NIL (* \; "Edited 11-May-88 16:11 by MASINTER")
|
||||
(SUBRCALL ETHER-SUSPEND)))
|
||||
|
||||
(\\10MB.TURNONETHER
|
||||
@@ -92,20 +87,16 @@
|
||||
|
||||
(PROG ((CSB (|fetch| NDBCSB |of| NDB)))
|
||||
(\\MAIKO.ETHERSUSPEND)
|
||||
(OR CSB (|replace| NDBCSB |of| NDB |with| (SETQ CSB
|
||||
(LOCF (|fetch| DLETHERNET
|
||||
|of| \\IOPAGE)))))
|
||||
(OR CSB (|replace| NDBCSB |of| NDB |with| (SETQ CSB (LOCF (|fetch| DLETHERNET |of| \\IOPAGE
|
||||
)))))
|
||||
(|replace| DLFIRSTOCB |of| CSB |with| 0)
|
||||
(|replace| DLFIRSTICB |of| CSB |with| 0)
|
||||
(AND NSHOSTNUMBER (COND
|
||||
((EQ NSHOSTNUMBER T)
|
||||
(\\BLT (LOCF (|fetch| DLLOCALHOST0 |of| CSB))
|
||||
(LOCF (|fetch| (IFPAGE |NSHost0|) |of|
|
||||
|\\InterfacePage|)
|
||||
)
|
||||
(LOCF (|fetch| (IFPAGE |NSHost0|) |of| |\\InterfacePage|))
|
||||
\\#WDS.NSHOSTNUMBER))
|
||||
(T (\\STORENSHOSTNUMBER (LOCF (|fetch| DLLOCALHOST0 |of|
|
||||
CSB))
|
||||
(T (\\STORENSHOSTNUMBER (LOCF (|fetch| DLLOCALHOST0 |of| CSB))
|
||||
NSHOSTNUMBER))))
|
||||
(AND OUTINTERRUPT (|replace| DLOUTPUTMASK |of| CSB |with| OUTINTERRUPT))
|
||||
(AND ININTERRUPT (|replace| DLINPUTMASK |of| CSB |with| ININTERRUPT))
|
||||
@@ -117,7 +108,7 @@
|
||||
(RETURN NDB))))
|
||||
|
||||
(\\10MBSENDPACKET
|
||||
(LAMBDA (NDB PACKET) (* \; "Edited 11-May-88 16:10 by MASINTER")
|
||||
(LAMBDA (NDB PACKET) (* \; "Edited 11-May-88 16:10 by MASINTER")
|
||||
(PROG NIL
|
||||
(COND
|
||||
(\\RAWTRACING (\\MAYBEPRINTPACKET PACKET 'RAWPUT)))
|
||||
@@ -125,23 +116,23 @@
|
||||
((OR (|fetch| 10MBMULTICASTP |of| PACKET)
|
||||
(EQNSADDRESS.HOST \\MY.NSADDRESS (|fetch| 10MBDESTHOSTBASE |of| PACKET)))
|
||||
(* \;
|
||||
"We would hear this packet if our hardware let us, so fake receipt")
|
||||
"We would hear this packet if our hardware let us, so fake receipt")
|
||||
(PROG ((COPYPACKET (\\ALLOCATE.ETHERPACKET)))
|
||||
(\\BLT (LOCF (|fetch| 10MBLENGTH |of| COPYPACKET))
|
||||
(LOCF (|fetch| 10MBLENGTH |of| PACKET))
|
||||
(ADD1 (|fetch| 10MBLENGTH |of| PACKET)))
|
||||
(* \;
|
||||
"Copy all data that would have been transmitted")
|
||||
"Copy all data that would have been transmitted")
|
||||
(|replace| EPNETWORK |of| COPYPACKET |with| NDB)
|
||||
(|replace| EPTYPE |of| COPYPACKET
|
||||
|with| (|for| PAIR |in| \\10MBTYPE.TRANSLATIONS
|
||||
|bind| (TYPE _ (|fetch| 10MBTYPE |of| PACKET))
|
||||
|when| (EQ TYPE (CAR PAIR)) |do|
|
||||
|bind| (TYPE _ (|fetch| 10MBTYPE |of| PACKET))
|
||||
|when| (EQ TYPE (CAR PAIR)) |do|
|
||||
|
||||
(* |;;| "TYPE is the raw type of the etherpacket. These do not always correspond one-to-one with the EPTYPE constants we use (in particular, for pups), so translate if necessary.")
|
||||
|
||||
(RETURN (CDR PAIR))
|
||||
|finally| (RETURN TYPE)))
|
||||
(RETURN (CDR PAIR))
|
||||
|finally| (RETURN TYPE)))
|
||||
(COND
|
||||
(\\RAWTRACING (\\MAYBEPRINTPACKET COPYPACKET 'RAWGET)))
|
||||
(\\HANDLE.RAW.PACKET COPYPACKET))))
|
||||
@@ -154,20 +145,21 @@
|
||||
(RETURN T))))
|
||||
|
||||
(\\10MBWATCHER
|
||||
(LAMBDA (NDB) (* \; "Edited 16-May-88 22:24 by MASINTER")
|
||||
(LAMBDA (NDB) (* \; "Edited 16-May-88 22:24 by MASINTER")
|
||||
|
||||
(* |;;| "merge message and packet reading")
|
||||
|
||||
(PROG ((CNTR 0)
|
||||
MESSAGE-BUFFER MESSAGE-LENGTH PACKET)
|
||||
LP (IF (SUBRCALL MESSAGE-READP)
|
||||
THEN (PROMPTPRINT (IF (SETQ MESSAGE-LENGTH (SUBRCALL MESSAGE-READ
|
||||
(OR MESSAGE-BUFFER
|
||||
(SETQ MESSAGE-BUFFER
|
||||
(ALLOCSTRING 1024)))
|
||||
1024))
|
||||
THEN (SUBSTRING MESSAGE-BUFFER 1 MESSAGE-LENGTH)
|
||||
ELSE "?? system message: polling failed")))
|
||||
THEN (PROMPTPRINT (IF (SETQ MESSAGE-LENGTH (SUBRCALL MESSAGE-READ (OR MESSAGE-BUFFER
|
||||
(SETQ
|
||||
MESSAGE-BUFFER
|
||||
(ALLOCSTRING
|
||||
1024)))
|
||||
1024))
|
||||
THEN (SUBSTRING MESSAGE-BUFFER 1 MESSAGE-LENGTH)
|
||||
ELSE "?? system message: polling failed")))
|
||||
(UNINTERRUPTABLY
|
||||
(SUBRCALL ETHER-CHECK)
|
||||
(SETQ PACKET (\\MAIKO.INPUT.INTERRUPT NDB)))
|
||||
@@ -182,31 +174,31 @@
|
||||
(GO LP))))
|
||||
|
||||
(\\MAIKO.10MBSENDPACKET
|
||||
(LAMBDA (NDB PACKET) (* \; "Edited 31-Oct-89 14:10 by bvm")
|
||||
(LAMBDA (NDB PACKET) (* \; "Edited 31-Oct-89 14:10 by bvm")
|
||||
(PROG NIL
|
||||
(COND
|
||||
(\\RAWTRACING (\\MAYBEPRINTPACKET PACKET 'RAWPUT)))
|
||||
(COND
|
||||
((OR (|fetch| 10MBMULTICASTP |of| PACKET)
|
||||
(EQNSADDRESS.HOST \\MY.NSADDRESS (|fetch| 10MBDESTNSADDRESSBASE |of| PACKET
|
||||
)))(* \;
|
||||
"We would hear this packet if our hardware let us, so fake receipt")
|
||||
(EQNSADDRESS.HOST \\MY.NSADDRESS (|fetch| 10MBDESTNSADDRESSBASE |of| PACKET)))
|
||||
(* \;
|
||||
"We would hear this packet if our hardware let us, so fake receipt")
|
||||
(PROG ((COPYPACKET (\\ALLOCATE.ETHERPACKET)))
|
||||
(\\BLT (LOCF (|fetch| 10MBLENGTH |of| COPYPACKET))
|
||||
(LOCF (|fetch| 10MBLENGTH |of| PACKET))
|
||||
(ADD1 (|fetch| 10MBLENGTH |of| PACKET)))
|
||||
(* \;
|
||||
"Copy all data that would have been transmitted")
|
||||
"Copy all data that would have been transmitted")
|
||||
(|replace| EPNETWORK |of| COPYPACKET |with| NDB)
|
||||
(|replace| EPTYPE |of| COPYPACKET
|
||||
|with| (|for| PAIR |in| \\10MBTYPE.TRANSLATIONS
|
||||
|bind| (TYPE _ (|fetch| 10MBTYPE |of| PACKET))
|
||||
|when| (EQ TYPE (CAR PAIR)) |do|
|
||||
|bind| (TYPE _ (|fetch| 10MBTYPE |of| PACKET))
|
||||
|when| (EQ TYPE (CAR PAIR)) |do|
|
||||
|
||||
(* |;;| "TYPE is the raw type of the etherpacket. These do not always correspond one-to-one with the EPTYPE constants we use (in particular, for pups), so translate if necessary.")
|
||||
|
||||
(RETURN (CDR PAIR))
|
||||
|finally| (RETURN TYPE)))
|
||||
(RETURN (CDR PAIR))
|
||||
|finally| (RETURN TYPE)))
|
||||
(COND
|
||||
(\\RAWTRACING (\\MAYBEPRINTPACKET COPYPACKET 'RAWGET)))
|
||||
(\\HANDLE.RAW.PACKET COPYPACKET))))
|
||||
@@ -219,20 +211,21 @@
|
||||
(RETURN T))))
|
||||
|
||||
(\\MAIKO.10MBWATCHER
|
||||
(LAMBDA (NDB) (* \; "Edited 16-May-88 22:24 by MASINTER")
|
||||
(LAMBDA (NDB) (* \; "Edited 16-May-88 22:24 by MASINTER")
|
||||
|
||||
(* |;;| "merge message and packet reading")
|
||||
|
||||
(PROG ((CNTR 0)
|
||||
MESSAGE-BUFFER MESSAGE-LENGTH PACKET)
|
||||
LP (IF (SUBRCALL MESSAGE-READP)
|
||||
THEN (PROMPTPRINT (IF (SETQ MESSAGE-LENGTH (SUBRCALL MESSAGE-READ
|
||||
(OR MESSAGE-BUFFER
|
||||
(SETQ MESSAGE-BUFFER
|
||||
(ALLOCSTRING 1024)))
|
||||
1024))
|
||||
THEN (SUBSTRING MESSAGE-BUFFER 1 MESSAGE-LENGTH)
|
||||
ELSE "?? system message: polling failed")))
|
||||
THEN (PROMPTPRINT (IF (SETQ MESSAGE-LENGTH (SUBRCALL MESSAGE-READ (OR MESSAGE-BUFFER
|
||||
(SETQ
|
||||
MESSAGE-BUFFER
|
||||
(ALLOCSTRING
|
||||
1024)))
|
||||
1024))
|
||||
THEN (SUBSTRING MESSAGE-BUFFER 1 MESSAGE-LENGTH)
|
||||
ELSE "?? system message: polling failed")))
|
||||
(UNINTERRUPTABLY
|
||||
(SUBRCALL ETHER-CHECK)
|
||||
(SETQ PACKET (\\MAIKO.INPUT.INTERRUPT NDB)))
|
||||
@@ -247,15 +240,15 @@
|
||||
(GO LP))))
|
||||
|
||||
(\\MAIKO.ETHERRESUME
|
||||
(LAMBDA NIL (* \; "Edited 11-May-88 16:09 by MASINTER")
|
||||
(LAMBDA NIL (* \; "Edited 11-May-88 16:09 by MASINTER")
|
||||
(SUBRCALL ETHER-RESUME)))
|
||||
|
||||
(\\MAIKO.ETHERSUSPEND
|
||||
(LAMBDA NIL (* \; "Edited 11-May-88 16:11 by MASINTER")
|
||||
(LAMBDA NIL (* \; "Edited 11-May-88 16:11 by MASINTER")
|
||||
(SUBRCALL ETHER-SUSPEND)))
|
||||
|
||||
(\\MAIKO.INPUT.INTERRUPT
|
||||
(LAMBDA (NDB) (* \; "Edited 11-May-88 16:05 by MASINTER")
|
||||
(LAMBDA (NDB) (* \; "Edited 11-May-88 16:05 by MASINTER")
|
||||
|
||||
(* |;;| "This routine gets called when 10MB input signals an interrupt. See if the \\MAIKO.INPUT.PACKET has indeed been processed, and if so, take care of it")
|
||||
|
||||
@@ -266,43 +259,38 @@
|
||||
(|replace| 10MBLENGTH |of| PACKET |with| LENGTH)
|
||||
(\\RCLK (LOCF (|fetch| EPTIMESTAMP |of| PACKET)))
|
||||
(|replace| EPNETWORK |of| PACKET |with| NDB)
|
||||
(|replace| EPTYPE |of| PACKET |with| (|for| PAIR |in|
|
||||
\\10MBTYPE.TRANSLATIONS
|
||||
|bind| (TYPE _
|
||||
(|fetch|
|
||||
10MBTYPE
|
||||
|of| PACKET
|
||||
))
|
||||
|when| (EQ TYPE (CAR PAIR))
|
||||
|do| (RETURN (CDR PAIR))
|
||||
|finally| (RETURN TYPE)))
|
||||
(|replace| EPTYPE |of| PACKET |with| (|for| PAIR |in| \\10MBTYPE.TRANSLATIONS
|
||||
|bind| (TYPE _ (|fetch| 10MBTYPE |of| PACKET))
|
||||
|when| (EQ TYPE (CAR PAIR))
|
||||
|do| (RETURN (CDR PAIR))
|
||||
|finally| (RETURN TYPE)))
|
||||
(COND
|
||||
(\\RAWTRACING (\\MAYBEPRINTPACKET PACKET 'RAWGET)))
|
||||
(RETURN (PROG1 PACKET
|
||||
(SETQ \\MAIKO.INPUT.PACKET (\\ALLOCATE.ETHERPACKET))
|
||||
(|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB)
|
||||
|with| \\ES.PENDING)
|
||||
(SUBRCALL ETHER-GET \\10MBPACKETLENGTH (|fetch| 10MBPACKETBASE
|
||||
|of| \\MAIKO.INPUT.PACKET))))
|
||||
)
|
||||
(|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB) |with| \\ES.PENDING)
|
||||
(SUBRCALL ETHER-GET \\10MBPACKETLENGTH (|fetch| 10MBPACKETBASE |of|
|
||||
\\MAIKO.INPUT.PACKET
|
||||
)))))
|
||||
(T (RETURN NIL))))))
|
||||
|
||||
(\\NS.SETTIME
|
||||
(LAMBDA (RETFLG) (* \; "Edited 13-May-88 15:22 by MASINTER")
|
||||
(LAMBDA (RETFLG) (* \; "Edited 13-May-88 15:22 by MASINTER")
|
||||
(CL:UNLESS (AND RETFLG (NOT (STRINGP RETFLG)))
|
||||
(SETQ |\\TimeZoneComp| (SUBRCALL GETUNIXTIME 8 NIL)))
|
||||
(\\PROCESS.RESET.TIMERS)
|
||||
(DAYTIME)))
|
||||
|
||||
(\\PUP.SETTIME
|
||||
(LAMBDA (RETFLG) (* \; "Edited 13-May-88 15:22 by MASINTER")
|
||||
(LAMBDA (RETFLG) (* \; "Edited 13-May-88 15:22 by MASINTER")
|
||||
(CL:UNLESS (AND RETFLG (NOT (STRINGP RETFLG)))
|
||||
(SETQ |\\TimeZoneComp| (SUBRCALL GETUNIXTIME 8 NIL)))
|
||||
(\\PROCESS.RESET.TIMERS)
|
||||
(DAYTIME)))
|
||||
|
||||
(\\MAIKO.10MBSTARTDRIVER
|
||||
(LAMBDA (NDB RESTARTFLG MYNSNUMBER) (* \; "Edited 4-May-91 15:50 by jds")
|
||||
(LAMBDA (NDB RESTARTFLG MYNSNUMBER) (* \; "Edited 30-Dec-2025 18:50 by nhb")
|
||||
(* \; "Edited 4-May-91 15:50 by jds")
|
||||
|
||||
(* |;;| "Start the \"driver\" for the 10MB ethernet on Sun Medley. In particular, turn on the C ehternet code, queue up the first input packet, and start the \\10MBWATCHER process.")
|
||||
|
||||
@@ -312,13 +300,11 @@
|
||||
(|replace| NDBTQ |of| NDB |with| (|create| SYSQUEUE))
|
||||
(SETQ \\10MB.RAWPACKETQ (|create| SYSQUEUE))
|
||||
(SETQ \\10MB.INPUT.TIMEOUT (TIMES \\RCLKSECOND \\10MB.EXPECTED.RECEIVE.INTERVAL))
|
||||
(SETQ \\MAIKO.10MB.NDB NDB)
|
||||
(\\10MB.TURNONETHER NDB NIL NIL (OR MYNSNUMBER T)
|
||||
0 0)
|
||||
(PROG ((CSB (|fetch| NDBCSB |of| NDB)))
|
||||
(OR \\MAIKO.INPUT.PACKET (SETQ \\MAIKO.INPUT.PACKET (\\ALLOCATE.ETHERPACKET)))
|
||||
(|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB) |with|
|
||||
\\ES.PENDING)
|
||||
(|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB) |with| \\ES.PENDING)
|
||||
(AND (SUBRCALL ETHER-GET \\10MBPACKETLENGTH (|fetch| 10MBPACKETBASE |of|
|
||||
\\MAIKO.INPUT.PACKET
|
||||
))
|
||||
@@ -340,20 +326,16 @@
|
||||
|
||||
(PROG ((CSB (|fetch| NDBCSB |of| NDB)))
|
||||
(\\MAIKO.ETHERSUSPEND)
|
||||
(OR CSB (|replace| NDBCSB |of| NDB |with| (SETQ CSB
|
||||
(LOCF (|fetch| DLETHERNET
|
||||
|of| \\IOPAGE)))))
|
||||
(OR CSB (|replace| NDBCSB |of| NDB |with| (SETQ CSB (LOCF (|fetch| DLETHERNET |of| \\IOPAGE
|
||||
)))))
|
||||
(|replace| DLFIRSTOCB |of| CSB |with| 0)
|
||||
(|replace| DLFIRSTICB |of| CSB |with| 0)
|
||||
(AND NSHOSTNUMBER (COND
|
||||
((EQ NSHOSTNUMBER T)
|
||||
(\\BLT (LOCF (|fetch| DLLOCALHOST0 |of| CSB))
|
||||
(LOCF (|fetch| (IFPAGE |NSHost0|) |of|
|
||||
|\\InterfacePage|)
|
||||
)
|
||||
(LOCF (|fetch| (IFPAGE |NSHost0|) |of| |\\InterfacePage|))
|
||||
\\#WDS.NSHOSTNUMBER))
|
||||
(T (\\STORENSHOSTNUMBER (LOCF (|fetch| DLLOCALHOST0 |of|
|
||||
CSB))
|
||||
(T (\\STORENSHOSTNUMBER (LOCF (|fetch| DLLOCALHOST0 |of| CSB))
|
||||
NSHOSTNUMBER))))
|
||||
(AND OUTINTERRUPT (|replace| DLOUTPUTMASK |of| CSB |with| OUTINTERRUPT))
|
||||
(AND ININTERRUPT (|replace| DLINPUTMASK |of| CSB |with| ININTERRUPT))
|
||||
@@ -365,14 +347,14 @@
|
||||
(RETURN NDB))))
|
||||
|
||||
(\\MAIKO.10MB.RESTART.ETHER
|
||||
(LAMBDA (NDB) (* \; "Edited 11-May-88 16:08 by MASINTER")
|
||||
(LAMBDA (NDB) (* \; "Edited 11-May-88 16:08 by MASINTER")
|
||||
|
||||
(* |;;;| "Kick the Ethernet receiver task to restart the Ethernet receiver task. This function gets called when the 10MBDRIVER thinks the Ethernet has been accidentally disabled")
|
||||
|
||||
(SUBRCALL ETHER-RESUME)))
|
||||
|
||||
(\\MAIKO.CHECKSUM
|
||||
(LAMBDA (BASE NWORDS INITSUM) (* \; "Edited 20-May-88 11:48 by MASINTER")
|
||||
(LAMBDA (BASE NWORDS INITSUM) (* \; "Edited 20-May-88 11:48 by MASINTER")
|
||||
(SUBRCALL CHECK-SUM BASE NWORDS INITSUM)))
|
||||
)
|
||||
|
||||
@@ -391,41 +373,37 @@
|
||||
|
||||
(DECLARE\: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS \\MAIKO.10MB.NDB)
|
||||
)
|
||||
|
||||
(DECLARE\: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS \\MAIKO.IO-INTERRUPT-FLAGS \\MAIKO.IO-INTERRUPT-VECTOR)
|
||||
)
|
||||
)
|
||||
|
||||
(ADDTOVAR \\MAIKO.MOVDS (\\MAIKO.10MBSTARTDRIVER \\10MB.STARTDRIVER)
|
||||
(\\MAIKO.10MBWATCHER \\10MBWATCHER)
|
||||
(\\MAIKO.10MBSENDPACKET \\10MBSENDPACKET)
|
||||
(\\MAIKO.ETHERSUSPEND \\10MB.TURNOFFETHER)
|
||||
(\\MAIKO.10MBTURNONETHER \\10MB.TURNONETHER)
|
||||
(\\MAIKO.ETHERRESUME \\10MB.RESTART.ETHER)
|
||||
(\\MAIKO.CHECKSUM \\CHECKSUM))
|
||||
(\\MAIKO.10MBWATCHER \\10MBWATCHER)
|
||||
(\\MAIKO.10MBSENDPACKET \\10MBSENDPACKET)
|
||||
(\\MAIKO.ETHERSUSPEND \\10MB.TURNOFFETHER)
|
||||
(\\MAIKO.10MBTURNONETHER \\10MB.TURNONETHER)
|
||||
(\\MAIKO.ETHERRESUME \\10MB.RESTART.ETHER)
|
||||
(\\MAIKO.CHECKSUM \\CHECKSUM))
|
||||
|
||||
|
||||
|
||||
(* \;
|
||||
(* |;;|
|
||||
"MAIKO handler for new interrupt-driven incoming ethernet communication, rather than polling for it.")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(\\MAIKO.ETHER-INTERRUPT
|
||||
(LAMBDA NIL (* \; "Edited 4-May-91 13:46 by jds")
|
||||
(LAMBDA NIL (* \; "Edited 30-Dec-2025 18:36 by nhb")
|
||||
(* \; "Edited 4-May-91 13:46 by jds")
|
||||
|
||||
(* |;;| "This routine gets called when 10MB input signals an interrupt. See if the \\MAIKO.INPUT.PACKET has indeed been processed, and if so, take care of it")
|
||||
|
||||
(PROG ((NDB \\MAIKO.10MB.NDB)
|
||||
(PROG ((NDB \\10MBLOCALNDB)
|
||||
LENGTH)
|
||||
|
||||
(* |;;| "First, turn off the interrupt flag:")
|
||||
|
||||
(REPLACE (INTERRUPTSTATE ETHERINTERRUPT) OF \\INTERRUPTSTATE WITH NIL)
|
||||
(|replace| (INTERRUPTSTATE ETHERINTERRUPT) |of| \\INTERRUPTSTATE |with| NIL)
|
||||
|
||||
(* |;;| "Now handle it:")
|
||||
|
||||
@@ -437,33 +415,27 @@
|
||||
|
||||
READ-MORE-LOOP
|
||||
(COND
|
||||
((NEQ (SETQ LENGTH (|fetch| DLFIRSTICB |of| (|fetch| NDBCSB
|
||||
|of| NDB)))
|
||||
((NEQ (SETQ LENGTH (|fetch| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB)))
|
||||
\\ES.PENDING)
|
||||
(|replace| 10MBLENGTH |of| PACKET |with| LENGTH)
|
||||
(\\RCLK (LOCF (|fetch| EPTIMESTAMP |of| PACKET)))
|
||||
(|replace| EPNETWORK |of| PACKET |with| NDB)
|
||||
(|replace| EPTYPE |of| PACKET
|
||||
|with| (|for| PAIR |in| \\10MBTYPE.TRANSLATIONS
|
||||
|bind| (TYPE _ (|fetch| 10MBTYPE |of| PACKET
|
||||
))
|
||||
|when| (EQ TYPE (CAR PAIR))
|
||||
|do| (RETURN (CDR PAIR)) |finally| (RETURN
|
||||
TYPE)))
|
||||
|bind| (TYPE _ (|fetch| 10MBTYPE |of| PACKET))
|
||||
|when| (EQ TYPE (CAR PAIR)) |do| (RETURN (CDR PAIR))
|
||||
|finally| (RETURN TYPE)))
|
||||
(COND
|
||||
(\\RAWTRACING (\\MAYBEPRINTPACKET PACKET 'RAWGET)))
|
||||
(\\HANDLE.RAW.PACKET PACKET)
|
||||
(SETQ \\MAIKO.INPUT.PACKET (\\ALLOCATE.ETHERPACKET))
|
||||
(|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB)
|
||||
|with| \\ES.PENDING)
|
||||
(|replace| DLFIRSTICB |of| (|fetch| NDBCSB |of| NDB) |with| \\ES.PENDING)
|
||||
(COND
|
||||
((SUBRCALL ETHER-GET \\10MBPACKETLENGTH (|fetch| 10MBPACKETBASE
|
||||
|of|
|
||||
\\MAIKO.INPUT.PACKET)
|
||||
)
|
||||
|of| \\MAIKO.INPUT.PACKET))
|
||||
|
||||
(* |;;|
|
||||
"Returned T, so there's another packet waiting already. Process it.")
|
||||
"Returned T, so there's another packet waiting already. Process it.")
|
||||
|
||||
(SETQ PACKET \\MAIKO.INPUT.PACKET)
|
||||
(GO READ-MORE-LOOP)))))))))))
|
||||
@@ -471,7 +443,7 @@
|
||||
|
||||
|
||||
|
||||
(* \;
|
||||
(* |;;|
|
||||
"MAIKO Log & Console message handling. Interrupt-driven message printing, instead of polled printing."
|
||||
)
|
||||
|
||||
@@ -527,14 +499,13 @@
|
||||
(RPAQ \\MAIKO.IO-INTERRUPT-FLAGS (\\CREATECELL \\FIXP))
|
||||
|
||||
(RPAQQ \\MAIKO.IO-INTERRUPT-VECTOR NIL)
|
||||
(PUTPROPS MAIKOETHER COPYRIGHT ("Venue & Xerox Corporation" 1988 1989 1990 1991 2021))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (2591 22216 (\\10MB.RESTART.ETHER 2601 . 2761) (\\10MB.STARTDRIVER 2763 . 4522) (
|
||||
\\10MB.TURNOFFETHER 4524 . 4684) (\\10MB.TURNONETHER 4686 . 7056) (\\10MBSENDPACKET 7058 . 9429) (
|
||||
\\10MBWATCHER 9431 . 10770) (\\MAIKO.10MBSENDPACKET 10772 . 13150) (\\MAIKO.10MBWATCHER 13152 . 14497)
|
||||
(\\MAIKO.ETHERRESUME 14499 . 14658) (\\MAIKO.ETHERSUSPEND 14660 . 14821) (\\MAIKO.INPUT.INTERRUPT
|
||||
14823 . 17085) (\\NS.SETTIME 17087 . 17367) (\\PUP.SETTIME 17369 . 17650) (\\MAIKO.10MBSTARTDRIVER
|
||||
17652 . 19307) (\\MAIKO.10MBTURNONETHER 19309 . 21684) (\\MAIKO.10MB.RESTART.ETHER 21686 . 22039) (
|
||||
\\MAIKO.CHECKSUM 22041 . 22214)) (23271 26336 (\\MAIKO.ETHER-INTERRUPT 23281 . 26334)) (26458 27821 (
|
||||
\\MAIKO.CONSOLE-LOG-PRINT 26468 . 27819)) (27867 28547 (\\MAIKO.IO-INTERRUPT 27877 . 28545)))))
|
||||
(FILEMAP (NIL (2301 20787 (\\10MB.RESTART.ETHER 2311 . 2475) (\\10MB.STARTDRIVER 2477 . 3863) (
|
||||
\\10MB.TURNOFFETHER 3865 . 4029) (\\10MB.TURNONETHER 4031 . 6121) (\\10MBSENDPACKET 6123 . 8481) (
|
||||
\\10MBWATCHER 8483 . 9926) (\\MAIKO.10MBSENDPACKET 9928 . 12296) (\\MAIKO.10MBWATCHER 12298 . 13747) (
|
||||
\\MAIKO.ETHERRESUME 13749 . 13912) (\\MAIKO.ETHERSUSPEND 13914 . 14079) (\\MAIKO.INPUT.INTERRUPT 14081
|
||||
. 15925) (\\NS.SETTIME 15927 . 16211) (\\PUP.SETTIME 16213 . 16498) (\\MAIKO.10MBSTARTDRIVER 16500 .
|
||||
18150) (\\MAIKO.10MBTURNONETHER 18152 . 20247) (\\MAIKO.10MB.RESTART.ETHER 20249 . 20606) (
|
||||
\\MAIKO.CHECKSUM 20608 . 20785)) (21751 24528 (\\MAIKO.ETHER-INTERRUPT 21761 . 24526)) (24652 26015 (
|
||||
\\MAIKO.CONSOLE-LOG-PRINT 24662 . 26013)) (26061 26741 (\\MAIKO.IO-INTERRUPT 26071 . 26739)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 9-Oct-2025 15:20:59" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;242 59604
|
||||
(FILECREATED "23-Jan-2026 15:10:16" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;249 60332
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS MEDLEYFONT.GETCHARSET)
|
||||
:CHANGES-TO (FNS MEDLEYFONT.FILENAME MEDLEYFONT.WRITE.FONT MEDLEYFONT.READ.FONT
|
||||
MEDLEYFONT.READ.VERIFIEDFONT)
|
||||
|
||||
:PREVIOUS-DATE " 7-Oct-2025 12:43:33" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;241)
|
||||
:PREVIOUS-DATE " 9-Oct-2025 15:20:59" {WMEDLEY}<sources>MEDLEYFONTFORMAT.;242)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEYFONTFORMATCOMS)
|
||||
@@ -59,7 +60,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.WRITE.FONT
|
||||
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 2-Sep-2025 23:01 by rmk")
|
||||
[LAMBDA (FONT FILE CHARSETNOS OTHERFONTPROPS NOINDIRECTS) (* ; "Edited 20-Jan-2026 22:36 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 23:01 by rmk")
|
||||
(* ; "Edited 15-Jul-2025 16:43 by rmk")
|
||||
(* ; "Edited 9-Jul-2025 09:32 by rmk")
|
||||
(* ; "Edited 19-Jun-2025 10:59 by rmk")
|
||||
@@ -70,8 +72,7 @@
|
||||
(* ; "Edited 16-May-2025 20:17 by rmk")
|
||||
(* ; "Edited 14-May-2025 17:45 by rmk")
|
||||
(SETQ FONT (FONTCREATE FONT))
|
||||
(CL:UNLESS FILE
|
||||
(SETQ FILE (MEDLEYFONT.FILENAME FONT CHARSETNOS)))
|
||||
(SETQ FILE (MEDLEYFONT.FILENAME FILE FONT CHARSETNOS))
|
||||
(SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS)))
|
||||
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION)
|
||||
(MEDLEYFONT.WRITE.HEADER STREAM OTHERFONTPROPS)
|
||||
@@ -279,14 +280,15 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.READ.FONT
|
||||
[LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 31-Aug-2025 14:42 by rmk")
|
||||
[LAMBDA (FILE CHARSETNOS FONT) (* ; "Edited 20-Jan-2026 22:31 by rmk")
|
||||
(* ; "Edited 31-Aug-2025 14:42 by rmk")
|
||||
(* ; "Edited 15-Jul-2025 20:20 by rmk")
|
||||
(* ; "Edited 9-Jul-2025 00:06 by rmk")
|
||||
(* ; "Edited 6-Jul-2025 11:45 by rmk")
|
||||
(CL:UNLESS FILE (SETQ FILE FONT))
|
||||
(CL:WHEN (OR (type? FONTDESCRIPTOR FILE)
|
||||
(LISTP FILE))
|
||||
(SETQ FILE (MEDLEYFONT.FILENAME FILE)))
|
||||
(SETQ FONT (CL:IF FONT
|
||||
(FONTCREATE FONT)
|
||||
(create FONTDESCRIPTOR)))
|
||||
(SETQ FILE (MEDLEYFONT.FILENAME FILE FONT))
|
||||
(SETQ CHARSETNOS (SORT (MKLIST CHARSETNOS)))
|
||||
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT)
|
||||
(CL:UNLESS (MEDLEYFONT.FILEP STREAM)
|
||||
@@ -510,14 +512,13 @@
|
||||
(bind PAIR until [EQ 'STOP (CAR (SETQ PAIR (MEDLEYFONT.READ.ITEM STREAM] collect PAIR])
|
||||
|
||||
(MEDLEYFONT.READ.VERIFIEDFONT
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 2-Sep-2025 23:52 by rmk")
|
||||
[LAMBDA (STREAM FONT) (* ; "Edited 20-Jan-2026 22:31 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 23:52 by rmk")
|
||||
(* ; "Edited 12-Aug-2025 17:57 by rmk")
|
||||
(* ; "Edited 10-Jun-2025 20:57 by rmk")
|
||||
(* ; "Edited 21-May-2025 22:55 by rmk")
|
||||
(* ; "Edited 19-May-2025 17:42 by rmk")
|
||||
(* ; "Edited 16-May-2025 10:28 by rmk")
|
||||
(CL:UNLESS FONT
|
||||
(SETQ FONT (create FONTDESCRIPTOR)))
|
||||
(LET ((FONTPROPS (MEDLEYFONT.READ.FONTPROPS STREAM)))
|
||||
(for P VAL in FONTPROPS do (SETQ VAL (CADR P))
|
||||
(SELECTQ (CAR P)
|
||||
@@ -842,35 +843,33 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MEDLEYFONT.FILENAME
|
||||
[LAMBDA (FONT CHARSET EXTENSION DIRECTORY) (* ; "Edited 7-Oct-2025 11:50 by rmk")
|
||||
[LAMBDA (FILE FONT CHARSET EXTENSION DIRECTORY) (* ; "Edited 23-Jan-2026 15:10 by rmk")
|
||||
(* ; "Edited 20-Jan-2026 17:39 by rmk")
|
||||
(* ; "Edited 7-Oct-2025 11:50 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 08:48 by rmk")
|
||||
(* ; "Edited 10-Jun-2025 11:02 by rmk")
|
||||
(* ; "Edited 25-May-2025 21:25 by rmk")
|
||||
(* ; "Edited 19-May-2025 17:42 by rmk")
|
||||
(* ; "Edited 16-May-2025 14:09 by rmk")
|
||||
|
||||
(* ;; "If EXTENSION and FILE are NIL, puts the file in the MEDLEYDIR fonts/medley[device]fonts/ directory with extension MEDLEY[device]FONT. If CHARSET, goes in the CHARSET subdirectory.")
|
||||
|
||||
(LET (FAMILY SIZE FACE DEVICE ROTATION FILENAME)
|
||||
(SPREADFONTSPEC (CL:IF (type? FONTDESCRIPTOR FONT)
|
||||
(FONTPROP FONT 'SPEC)
|
||||
(\FONT.CHECKARGS FONT)))
|
||||
(CL:UNLESS EXTENSION
|
||||
(SETQ EXTENSION (CONCAT "MEDLEY" (U-CASE DEVICE)
|
||||
"FONT")))
|
||||
(CL:UNLESS DIRECTORY
|
||||
[SETQ DIRECTORY (PSEUDOFILENAME (CONCAT (MEDLEYDIR)
|
||||
(CONCAT "fonts/" (L-CASE EXTENSION)
|
||||
"s"])
|
||||
(SETQ FILENAME (PACK* FAMILY (CL:IF (ILEQ SIZE 9)
|
||||
"0"
|
||||
"")
|
||||
SIZE "-" (FONTFACETOATOM FACE)
|
||||
(CL:IF (SMALLP CHARSET)
|
||||
(CONCAT "-C" (OCTALSTRING CHARSET))
|
||||
"")
|
||||
"." EXTENSION))
|
||||
(CONCAT DIRECTORY ">" FILENAME])
|
||||
(LET [(FONTSPEC (AND FONT (\FONT.CHECKARGS FONT NIL NIL NIL NIL T]
|
||||
(CL:UNLESS EXTENSION (* ;
|
||||
"EXTENSION may be needed for DIRECTORY below")
|
||||
(SETQ EXTENSION (OR (FILENAMEFIELD FILE 'EXTENSION)
|
||||
(CONCAT "MEDLEY" (OR (AND FONTSPEC (fetch (FONTSPEC FSDEVICE)
|
||||
of FONTSPEC))
|
||||
(ERROR "Font device not known"))
|
||||
"FONT"))))
|
||||
(PACKFILENAME.STRING `(BODY ,FILE ,@(UNPACKFILENAME.STRING (AND FONTSPEC
|
||||
(\FONTFILENAME FONTSPEC NIL
|
||||
NIL NIL CHARSET)))
|
||||
DIRECTORY
|
||||
,(OR DIRECTORY (FILENAMEFIELD FILE 'DIRECTORY)
|
||||
(PSEUDOFILENAME (CONCAT (MEDLEYDIR)
|
||||
"fonts/"
|
||||
(L-CASE EXTENSION)
|
||||
"s")))
|
||||
EXTENSION
|
||||
,EXTENSION])
|
||||
)
|
||||
|
||||
(ADDTOVAR DISPLAYFONTEXTENSIONS MEDLEYDISPLAYFONT)
|
||||
@@ -921,11 +920,11 @@
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2128 16674 (MEDLEYFONT.WRITE.FONT 2138 . 7104) (MEDLEYFONT.GETCHARSET 7106 . 11133) (
|
||||
MEDLEYFONT.CHARSET? 11135 . 12604) (MEDLEYFONT.GETFILEPROP 12606 . 14706) (MEDLEYFONT.FILEP 14708 .
|
||||
16672)) (16700 38890 (MEDLEYFONT.READ.FONT 16710 . 21142) (MEDLEYFONT.READ.CHARSET 21144 . 26502) (
|
||||
MEDLEYFONT.READ.ITEM 26504 . 32653) (MEDLEYFONT.PEEK.ITEM 32655 . 33517) (MEDLEYFONT.READ.FONTPROPS
|
||||
33519 . 33984) (MEDLEYFONT.READ.VERIFIEDFONT 33986 . 38888)) (38916 56753 (MEDLEYFONT.WRITE.CHARSET
|
||||
38926 . 43488) (MEDLEYFONT.WRITE.ITEM 43490 . 52543) (MEDLEYFONT.WRITE.FONTPROPS 52545 . 56098) (
|
||||
MEDLEYFONT.WRITE.HEADER 56100 . 56751)) (56754 58719 (MEDLEYFONT.FILENAME 56764 . 58717)))))
|
||||
(FILEMAP (NIL (2222 16857 (MEDLEYFONT.WRITE.FONT 2232 . 7287) (MEDLEYFONT.GETCHARSET 7289 . 11316) (
|
||||
MEDLEYFONT.CHARSET? 11318 . 12787) (MEDLEYFONT.GETFILEPROP 12789 . 14889) (MEDLEYFONT.FILEP 14891 .
|
||||
16855)) (16883 39217 (MEDLEYFONT.READ.FONT 16893 . 21429) (MEDLEYFONT.READ.CHARSET 21431 . 26789) (
|
||||
MEDLEYFONT.READ.ITEM 26791 . 32940) (MEDLEYFONT.PEEK.ITEM 32942 . 33804) (MEDLEYFONT.READ.FONTPROPS
|
||||
33806 . 34271) (MEDLEYFONT.READ.VERIFIEDFONT 34273 . 39215)) (39243 57080 (MEDLEYFONT.WRITE.CHARSET
|
||||
39253 . 43815) (MEDLEYFONT.WRITE.ITEM 43817 . 52870) (MEDLEYFONT.WRITE.FONTPROPS 52872 . 56425) (
|
||||
MEDLEYFONT.WRITE.HEADER 56427 . 57078)) (57081 59447 (MEDLEYFONT.FILENAME 57091 . 59445)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
380
sources/PUP
380
sources/PUP
@@ -1,15 +1,13 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP" BASE 8)
|
||||
(FILECREATED " 1-May-2021 19:49:18" {DSK}<home>larry>ilisp>medley>sources>PUP.;2 336270Q
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 8)
|
||||
|
||||
changes to%: (FNS \PUP.SETTIME CANONICAL.HOSTNAME)
|
||||
(VARS PUPCOMS)
|
||||
(FILECREATED "22-Dec-2025 11:58:55" {DSK}<Users>briggs>projects>medley>sources>PUP.;4 334515Q
|
||||
|
||||
previous date%: "19-Jan-93 11:14:09" {DSK}<home>larry>ilisp>medley>sources>PUP.;1)
|
||||
:EDIT-BY nhb
|
||||
|
||||
:CHANGES-TO (FNS \FIND.LOCALPUPHOSTNUMBER)
|
||||
|
||||
:PREVIOUS-DATE "20-Dec-2025 13:51:34" {DSK}<Users>briggs>projects>medley>sources>PUP.;3)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT PUPCOMS)
|
||||
|
||||
@@ -45,13 +43,13 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(FNS CLEARPUP PUTPUPWORD GETPUPBYTE PUTPUPBYTE GETPUPSTRING GETPUPSTREAM PUTPUPSTRING)
|
||||
(OPTIMIZERS GETPUPWORD PUTPUPWORD GETPUPBYTE PUTPUPBYTE))
|
||||
(COMS (* ;
|
||||
"Reading property lists from streams")
|
||||
"Reading property lists from streams")
|
||||
(FNS READPLIST)
|
||||
(INITVARS \READPLIST.READTABLES)
|
||||
(GLOBALVARS \READPLIST.READTABLES))
|
||||
(COMS (FNS \CANONICAL.HOSTNAME \CANONICALIZE.PUP.HOSTNAME)
|
||||
(P (* ;
|
||||
"Default this for when IP not loaded")
|
||||
"Default this for when IP not loaded")
|
||||
(MOVD? 'NILL '\CANONICALIZE.IP.HOSTNAME NIL T))
|
||||
(ADDVARS (\HOSTNAMES)
|
||||
(\SYSTEMCACHEVARS \HOSTNAMES))
|
||||
@@ -138,53 +136,52 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS PUP [(PUPBASE (LOCF (fetch (ETHERPACKET EPBODY) of DATUM]
|
||||
[BLOCKRECORD PUPBASE ((PUPLENGTH WORD)
|
||||
(PUPTCONTROL BYTE)
|
||||
(PUPTYPE BYTE)
|
||||
(PUPID FIXP)
|
||||
(PUPDEST WORD)
|
||||
(PUPDESTSOCKET FIXP)
|
||||
(PUPSOURCE WORD)
|
||||
(PUPSOURCESOCKET FIXP)
|
||||
(PUPDATASTART 412Q WORD))
|
||||
(BLOCKRECORD PUPBASE ((NIL WORD)
|
||||
(TYPEWORD WORD)
|
||||
(PUPIDHI WORD)
|
||||
(PUPIDLO WORD)
|
||||
(PUPDESTNET BYTE)
|
||||
(PUPDESTHOST BYTE)
|
||||
(PUPDESTSOCKETHI WORD)
|
||||
(PUPDESTSOCKETLO WORD)
|
||||
(PUPSOURCENET BYTE)
|
||||
(PUPSOURCEHOST BYTE)
|
||||
(PUPSOURCESOCKETHI WORD)
|
||||
(PUPSOURCESOCKETLO WORD))
|
||||
[BLOCKRECORD PUPBASE ((PUPLENGTH WORD)
|
||||
(PUPTCONTROL BYTE)
|
||||
(PUPTYPE BYTE)
|
||||
(PUPID FIXP)
|
||||
(PUPDEST WORD)
|
||||
(PUPDESTSOCKET FIXP)
|
||||
(PUPSOURCE WORD)
|
||||
(PUPSOURCESOCKET FIXP)
|
||||
(PUPDATASTART 412Q WORD))
|
||||
(BLOCKRECORD PUPBASE ((NIL WORD)
|
||||
(TYPEWORD WORD)
|
||||
(PUPIDHI WORD)
|
||||
(PUPIDLO WORD)
|
||||
(PUPDESTNET BYTE)
|
||||
(PUPDESTHOST BYTE)
|
||||
(PUPDESTSOCKETHI WORD)
|
||||
(PUPDESTSOCKETLO WORD)
|
||||
(PUPSOURCENET BYTE)
|
||||
(PUPSOURCEHOST BYTE)
|
||||
(PUPSOURCESOCKETHI WORD)
|
||||
(PUPSOURCESOCKETLO WORD))
|
||||
(* ; "Temporary extra synonyms")
|
||||
(SYNONYM PUPDESTNET (DESTNET))
|
||||
(SYNONYM PUPDESTHOST (DESTHOST))
|
||||
(SYNONYM PUPDESTSOCKETHI (DESTSKTHI))
|
||||
(SYNONYM PUPDESTSOCKETLO (DESTSKTLO))
|
||||
(SYNONYM PUPSOURCENET (SOURCENET))
|
||||
(SYNONYM PUPSOURCEHOST (SOURCEHOST))
|
||||
(SYNONYM PUPSOURCESOCKETHI (SOURCESKTHI))
|
||||
(SYNONYM PUPSOURCESOCKETLO (SOURCESKTLO)))
|
||||
(SYNONYM PUPDEST (DEST))
|
||||
(SYNONYM PUPDESTSOCKET (DESTSKT))
|
||||
(SYNONYM PUPSOURCE (SOURCE))
|
||||
(SYNONYM PUPSOURCESOCKET (SOURCESKT))
|
||||
(ACCESSFNS PUPDATASTART ((PUPCONTENTS (LOCF DATUM]
|
||||
[ACCESSFNS PUP [(PUPCHECKSUMBASE (fetch PUPBASE of DATUM))
|
||||
(PUPCHECKSUMLOC (\ADDBASE (fetch PUPBASE of DATUM)
|
||||
(FOLDLO (SUB1 (fetch PUPLENGTH
|
||||
of DATUM))
|
||||
BYTESPERWORD]
|
||||
(BLOCKRECORD PUPCHECKSUMLOC ((PUPCHECKSUM WORD]
|
||||
(TYPE? (type? ETHERPACKET DATUM)))
|
||||
(SYNONYM PUPDESTNET (DESTNET))
|
||||
(SYNONYM PUPDESTHOST (DESTHOST))
|
||||
(SYNONYM PUPDESTSOCKETHI (DESTSKTHI))
|
||||
(SYNONYM PUPDESTSOCKETLO (DESTSKTLO))
|
||||
(SYNONYM PUPSOURCENET (SOURCENET))
|
||||
(SYNONYM PUPSOURCEHOST (SOURCEHOST))
|
||||
(SYNONYM PUPSOURCESOCKETHI (SOURCESKTHI))
|
||||
(SYNONYM PUPSOURCESOCKETLO (SOURCESKTLO)))
|
||||
(SYNONYM PUPDEST (DEST))
|
||||
(SYNONYM PUPDESTSOCKET (DESTSKT))
|
||||
(SYNONYM PUPSOURCE (SOURCE))
|
||||
(SYNONYM PUPSOURCESOCKET (SOURCESKT))
|
||||
(ACCESSFNS PUPDATASTART ((PUPCONTENTS (LOCF DATUM]
|
||||
[ACCESSFNS PUP [(PUPCHECKSUMBASE (fetch PUPBASE of DATUM))
|
||||
(PUPCHECKSUMLOC (\ADDBASE (fetch PUPBASE of DATUM)
|
||||
(FOLDLO (SUB1 (fetch PUPLENGTH of DATUM))
|
||||
BYTESPERWORD]
|
||||
(BLOCKRECORD PUPCHECKSUMLOC ((PUPCHECKSUM WORD]
|
||||
(TYPE? (type? ETHERPACKET DATUM)))
|
||||
|
||||
(ACCESSFNS PUPADDRESS ((PUPNET# (LRSH DATUM 10Q))
|
||||
(PUPHOST# (LOGAND DATUM 377Q)))
|
||||
(CREATE (IPLUS (LLSH PUPNET# 10Q)
|
||||
PUPHOST#)))
|
||||
(PUPHOST# (LOGAND DATUM 377Q)))
|
||||
(CREATE (IPLUS (LLSH PUPNET# 10Q)
|
||||
PUPHOST#)))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
@@ -274,23 +271,26 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(RETURN T])])
|
||||
|
||||
(\FIND.LOCALPUPHOSTNUMBER
|
||||
[LAMBDA (NDB EVENT QUIET) (* bvm%: "26-Jul-84 16:27")
|
||||
[LAMBDA (NDB EVENT QUIET) (* ; "Edited 22-Dec-2025 11:58 by nhb")
|
||||
(* ; "Edited 20-Dec-2025 13:51 by nhb")
|
||||
(* bvm%: "26-Jul-84 16:27")
|
||||
|
||||
(* ;; "Finds out our pup address on this 10mb NDB")
|
||||
|
||||
(PROG (NEWNUMBER)
|
||||
[COND
|
||||
((NOT (\ETHER-AVAILABLE))
|
||||
(RETURN NIL))
|
||||
[(SETQ NEWNUMBER (\LOOKUPPUPNUMBER \MY.NSHOSTNUMBER NDB))
|
||||
(COND
|
||||
(PUPTRACEFLG (printout PUPTRACEFILE "My pup address = " (fetch PUPNET#
|
||||
of NEWNUMBER)
|
||||
(PUPTRACEFLG (printout PUPTRACEFILE "My pup address = " (fetch PUPNET# of NEWNUMBER)
|
||||
"#"
|
||||
(fetch PUPHOST# of NEWNUMBER)
|
||||
"#" T]
|
||||
(QUIET (RETURN NIL))
|
||||
(T (SETQ NEWNUMBER (\PROMPT.FOR.PUP.NUMBER (AND (EQ EVENT 'AFTERLOGOUT)
|
||||
(NEQ \OLDPUPHOST# 0)
|
||||
(OCTALSTRING \OLDPUPHOST#]
|
||||
(NEQ \OLDPUPHOST# 0)
|
||||
(OCTALSTRING \OLDPUPHOST#]
|
||||
|
||||
(* ;; "Only rely on the host number part of reply. There is confusion for machines that exist on more than one net")
|
||||
|
||||
@@ -470,14 +470,14 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(ACCESSFNS ERRORPUP ((ERRORPUPBASE (fetch PUPCONTENTS of DATUM)))
|
||||
(BLOCKRECORD ERRORPUPBASE ((ERRORPUPCOPY 12Q WORD)
|
||||
(BLOCKRECORD ERRORPUPBASE ((ERRORPUPCOPY 12Q WORD)
|
||||
(* ; "Copy of pup header")
|
||||
(ERRORPUPCODE WORD)
|
||||
(ERRORPUPARG WORD)
|
||||
(ERRORPUPCODE WORD)
|
||||
(ERRORPUPARG WORD)
|
||||
(* ; "Usually zero")
|
||||
(ERRORPUPSTRINGBASE WORD)
|
||||
(ERRORPUPSTRINGBASE WORD)
|
||||
(* ; "Human readable message")
|
||||
)))
|
||||
)))
|
||||
)
|
||||
|
||||
(RPAQQ PUPERRORCODES
|
||||
@@ -1174,24 +1174,22 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(DEFOPTIMIZER GETPUPWORD (PUPARG WORD#)
|
||||
`(\GETBASE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET))
|
||||
,WORD#))
|
||||
`(\GETBASE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET))
|
||||
,WORD#))
|
||||
|
||||
(DEFOPTIMIZER PUTPUPWORD (PUPARG WORD# VALUE)
|
||||
`(\PUTBASE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET))
|
||||
,WORD#
|
||||
,VALUE))
|
||||
`(\PUTBASE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET))
|
||||
,WORD#
|
||||
,VALUE))
|
||||
|
||||
(DEFOPTIMIZER GETPUPBYTE (PUPARG BYTE#)
|
||||
`(\GETBASEBYTE (fetch PUPCONTENTS of (\DTEST ,PUPARG
|
||||
'ETHERPACKET))
|
||||
,BYTE#))
|
||||
`(\GETBASEBYTE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET))
|
||||
,BYTE#))
|
||||
|
||||
(DEFOPTIMIZER PUTPUPBYTE (PUPARG BYTE# VALUE)
|
||||
`(\PUTBASEBYTE (fetch PUPCONTENTS of (\DTEST ,PUPARG
|
||||
'ETHERPACKET))
|
||||
,BYTE#
|
||||
,VALUE))
|
||||
`(\PUTBASEBYTE (fetch PUPCONTENTS of (\DTEST ,PUPARG 'ETHERPACKET))
|
||||
,BYTE#
|
||||
,VALUE))
|
||||
|
||||
|
||||
|
||||
@@ -1282,7 +1280,7 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
)
|
||||
|
||||
(* ;
|
||||
"Default this for when IP not loaded")
|
||||
"Default this for when IP not loaded")
|
||||
|
||||
(MOVD? 'NILL '\CANONICALIZE.IP.HOSTNAME NIL T)
|
||||
|
||||
@@ -1301,8 +1299,8 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS BINDPUPS MACRO [X (CONS (LIST 'LAMBDA (CAR X)
|
||||
(CONS 'PROGN (CDR X)))
|
||||
(in (CAR X) collect (LIST 'ALLOCATE.PUP])
|
||||
(CONS 'PROGN (CDR X)))
|
||||
(in (CAR X) collect (LIST 'ALLOCATE.PUP])
|
||||
)
|
||||
|
||||
(PUTPROPS BINDPUPS INFO BINDS)
|
||||
@@ -1597,12 +1595,12 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(DECLARE%: DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(BLOCKRECORD PUPROUTINGINFO ( (* ;
|
||||
"Format of each entry in a pup routing info packet. We only actually use NET# and #HOPS")
|
||||
(NET# BYTE)
|
||||
(GATENET# BYTE)
|
||||
(GATEHOST# BYTE)
|
||||
(%#HOPS BYTE)))
|
||||
(BLOCKRECORD PUPROUTINGINFO ( (* ;
|
||||
"Format of each entry in a pup routing info packet. We only actually use NET# and #HOPS")
|
||||
(NET# BYTE)
|
||||
(GATENET# BYTE)
|
||||
(GATEHOST# BYTE)
|
||||
(%#HOPS BYTE)))
|
||||
)
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
@@ -1628,24 +1626,24 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE PUPSOCKET ((NIL BITS 4)
|
||||
(PUPSOCLINK POINTER) (* ; "So that we can Queue them")
|
||||
(PSOCKET# FIXP)
|
||||
(INQUEUE POINTER)
|
||||
(INQUEUELENGTH WORD)
|
||||
(PUPSOC#ALLOCATION WORD)
|
||||
(PUPSOCHANDLE WORD) (* ; "Back-fitting for Bcpl")
|
||||
(PUPSOCPUPADDRESS WORD) (* ; "Local net/host")
|
||||
(NIL BITS 4)
|
||||
(PUPSOCEVENT POINTER) (* ;
|
||||
"Event that is notified when a pup arrives on this socket")
|
||||
(NIL BITS 4)
|
||||
(NIL POINTER))
|
||||
(BLOCKRECORD PUPSOCKET ((NIL BITS 4)
|
||||
(NIL POINTER)
|
||||
(PSOCKETHI WORD)
|
||||
(PSOCKETLO WORD)))
|
||||
INQUEUE _ (create SYSQUEUE)
|
||||
PUPSOC#ALLOCATION _ \MAX.EPKTS.ON.PUPSOCKET)
|
||||
(PUPSOCLINK POINTER) (* ; "So that we can Queue them")
|
||||
(PSOCKET# FIXP)
|
||||
(INQUEUE POINTER)
|
||||
(INQUEUELENGTH WORD)
|
||||
(PUPSOC#ALLOCATION WORD)
|
||||
(PUPSOCHANDLE WORD) (* ; "Back-fitting for Bcpl")
|
||||
(PUPSOCPUPADDRESS WORD) (* ; "Local net/host")
|
||||
(NIL BITS 4)
|
||||
(PUPSOCEVENT POINTER) (* ;
|
||||
"Event that is notified when a pup arrives on this socket")
|
||||
(NIL BITS 4)
|
||||
(NIL POINTER))
|
||||
(BLOCKRECORD PUPSOCKET ((NIL BITS 4)
|
||||
(NIL POINTER)
|
||||
(PSOCKETHI WORD)
|
||||
(PSOCKETLO WORD)))
|
||||
INQUEUE _ (create SYSQUEUE)
|
||||
PUPSOC#ALLOCATION _ \MAX.EPKTS.ON.PUPSOCKET)
|
||||
)
|
||||
|
||||
(/DECLAREDATATYPE 'PUPSOCKET '((BITS 4)
|
||||
@@ -1670,11 +1668,11 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \PUPSOCKET.FROM# MACRO (OPENLAMBDA (SOCHI SOCLO)
|
||||
(for SOC in \PUPSOCKETS
|
||||
when (AND (EQ (fetch PSOCKETLO of SOC)
|
||||
SOCLO)
|
||||
(EQ (fetch PSOCKETHI of SOC)
|
||||
SOCHI)) do (RETURN SOC))))
|
||||
(for SOC in \PUPSOCKETS
|
||||
when (AND (EQ (fetch PSOCKETLO of SOC)
|
||||
SOCLO)
|
||||
(EQ (fetch PSOCKETHI of SOC)
|
||||
SOCHI)) do (RETURN SOC))))
|
||||
)
|
||||
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
@@ -1704,17 +1702,17 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR SYSTEMRECLST
|
||||
|
||||
(DATATYPE PUPSOCKET ((NIL BITS 4)
|
||||
(PUPSOCLINK POINTER)
|
||||
(PSOCKET# FIXP)
|
||||
(INQUEUE POINTER)
|
||||
(INQUEUELENGTH WORD)
|
||||
(PUPSOC#ALLOCATION WORD)
|
||||
(PUPSOCHANDLE WORD)
|
||||
(PUPSOCPUPADDRESS WORD)
|
||||
(NIL BITS 4)
|
||||
(PUPSOCEVENT POINTER)
|
||||
(NIL BITS 4)
|
||||
(NIL POINTER)))
|
||||
(PUPSOCLINK POINTER)
|
||||
(PSOCKET# FIXP)
|
||||
(INQUEUE POINTER)
|
||||
(INQUEUELENGTH WORD)
|
||||
(PUPSOC#ALLOCATION WORD)
|
||||
(PUPSOCHANDLE WORD)
|
||||
(PUPSOCPUPADDRESS WORD)
|
||||
(NIL BITS 4)
|
||||
(PUPSOCEVENT POINTER)
|
||||
(NIL BITS 4)
|
||||
(NIL POINTER)))
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
@@ -1826,21 +1824,21 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(BLOCKRECORD PORT ((NETHOST WORD)
|
||||
(SOCKET FIXP))
|
||||
(BLOCKRECORD PORT ((NET BYTE)
|
||||
(HOST BYTE)
|
||||
(SOCKETHI WORD)
|
||||
(SOCKETLO WORD))))
|
||||
(SOCKET FIXP))
|
||||
(BLOCKRECORD PORT ((NET BYTE)
|
||||
(HOST BYTE)
|
||||
(SOCKETHI WORD)
|
||||
(SOCKETLO WORD))))
|
||||
|
||||
(ACCESSFNS ERRORPUP ((ERRORPUPBASE (fetch PUPCONTENTS of DATUM)))
|
||||
(BLOCKRECORD ERRORPUPBASE ((ERRORPUPCOPY 12Q WORD)
|
||||
(BLOCKRECORD ERRORPUPBASE ((ERRORPUPCOPY 12Q WORD)
|
||||
(* ; "Copy of pup header")
|
||||
(ERRORPUPCODE WORD)
|
||||
(ERRORPUPARG WORD)
|
||||
(ERRORPUPCODE WORD)
|
||||
(ERRORPUPARG WORD)
|
||||
(* ; "Usually zero")
|
||||
(ERRORPUPSTRINGBASE WORD)
|
||||
(ERRORPUPSTRINGBASE WORD)
|
||||
(* ; "Human readable message")
|
||||
)))
|
||||
)))
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
@@ -1868,20 +1866,20 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS \GETPUPWORD DMACRO ((PUP WORD#)
|
||||
(\GETBASE (fetch PUPCONTENTS of PUP)
|
||||
WORD#)))
|
||||
(\GETBASE (fetch PUPCONTENTS of PUP)
|
||||
WORD#)))
|
||||
|
||||
(PUTPROPS \PUTPUPWORD DMACRO ((PUP WORD# VALUE)
|
||||
(\PUTBASE (fetch PUPCONTENTS of PUP)
|
||||
WORD# VALUE)))
|
||||
(\PUTBASE (fetch PUPCONTENTS of PUP)
|
||||
WORD# VALUE)))
|
||||
|
||||
(PUTPROPS \GETPUPBYTE DMACRO ((PUP BYTE#)
|
||||
(\GETBASEBYTE (fetch PUPCONTENTS of PUP)
|
||||
BYTE#)))
|
||||
(\GETBASEBYTE (fetch PUPCONTENTS of PUP)
|
||||
BYTE#)))
|
||||
|
||||
(PUTPROPS \PUTPUPBYTE DMACRO ((PUP BYTE# VALUE)
|
||||
(\PUTBASEBYTE (fetch PUPCONTENTS of PUP)
|
||||
BYTE# VALUE)))
|
||||
(\PUTBASEBYTE (fetch PUPCONTENTS of PUP)
|
||||
BYTE# VALUE)))
|
||||
)
|
||||
|
||||
(RPAQQ RAWPUPTYPES
|
||||
@@ -2033,13 +2031,13 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(RPAQ? PUPTYPES RAWPUPTYPES)
|
||||
|
||||
(RPAQQ WELLKNOWNPUPSOCKETS ((\PUPSOCKET.TELNET 1)
|
||||
(\PUPSOCKET.ROUTING 2)
|
||||
(\PUPSOCKET.FTP 3)
|
||||
(\PUPSOCKET.MISCSERVICES 4)
|
||||
(\PUPSOCKET.ECHO 5)
|
||||
(\PUPSOCKET.EFTP 20Q)
|
||||
(\PUPSOCKET.PRINTERSTATUS 21Q)
|
||||
(\PUPSOCKET.LEAF 43Q)))
|
||||
(\PUPSOCKET.ROUTING 2)
|
||||
(\PUPSOCKET.FTP 3)
|
||||
(\PUPSOCKET.MISCSERVICES 4)
|
||||
(\PUPSOCKET.ECHO 5)
|
||||
(\PUPSOCKET.EFTP 20Q)
|
||||
(\PUPSOCKET.PRINTERSTATUS 21Q)
|
||||
(\PUPSOCKET.LEAF 43Q)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ \PUPSOCKET.TELNET 1)
|
||||
@@ -2074,9 +2072,9 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
|
||||
|
||||
(RPAQQ PUPCONSTANTS ((\PUPHEADERLEN 24Q)
|
||||
(\NetMask 177400Q)
|
||||
(\HILOCALSOCKET 1)
|
||||
(\PORTIDLEN 3)))
|
||||
(\NetMask 177400Q)
|
||||
(\HILOCALSOCKET 1)
|
||||
(\PORTIDLEN 3)))
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQQ \PUPHEADERLEN 24Q)
|
||||
@@ -2097,28 +2095,28 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS PUPDEBUGGING MACRO [(X . Y)
|
||||
(COND
|
||||
(PUPTRACEFLG (printout PUPTRACEFILE X . Y])
|
||||
(COND
|
||||
(PUPTRACEFLG (printout PUPTRACEFILE X . Y])
|
||||
)
|
||||
|
||||
|
||||
(ADDTOVAR PUPPRINTMACROS (210Q CHARS)
|
||||
(214Q CHARS)
|
||||
(211Q CHARS)
|
||||
(213Q CHARS)
|
||||
(201Q WORDS 2 CHARS 24Q |...|)
|
||||
(30Q CHARS))
|
||||
(214Q CHARS)
|
||||
(211Q CHARS)
|
||||
(213Q CHARS)
|
||||
(201Q WORDS 2 CHARS 24Q |...|)
|
||||
(30Q CHARS))
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(BLOCKRECORD TIMEPUPCONTENTS ((TIMEPUPVALUEHI WORD)
|
||||
(TIMEPUPVALUELO WORD)
|
||||
(TIMEPUPEASTP FLAG)
|
||||
(TIMEPUPHOURS BITS 7)
|
||||
(TIMEPUPMINUTES BITS 10Q)
|
||||
(TIMEPUPBEGINDST WORD)
|
||||
(TIMEPUPENDDST WORD)) (* ; "format of alto time response")
|
||||
)
|
||||
(TIMEPUPVALUELO WORD)
|
||||
(TIMEPUPEASTP FLAG)
|
||||
(TIMEPUPHOURS BITS 7)
|
||||
(TIMEPUPMINUTES BITS 10Q)
|
||||
(TIMEPUPBEGINDST WORD)
|
||||
(TIMEPUPENDDST WORD)) (* ; "format of alto time response")
|
||||
)
|
||||
)
|
||||
)
|
||||
|
||||
@@ -2447,10 +2445,10 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR PUPIGNORETYPES )
|
||||
|
||||
(ADDTOVAR PUPPRINTMACROS (4 . PRINTERRORPUP)
|
||||
(220Q CHARS)
|
||||
(221Q REPEAT BYTES -2 WORDS -4)
|
||||
(223Q BYTES -2 WORDS)
|
||||
(224Q CHARS))
|
||||
(220Q CHARS)
|
||||
(221Q REPEAT BYTES -2 WORDS -4)
|
||||
(223Q BYTES -2 WORDS)
|
||||
(224Q CHARS))
|
||||
(DECLARE%: DONTEVAL@LOAD
|
||||
|
||||
(\PUPINIT)
|
||||
@@ -2469,32 +2467,30 @@ Copyright (c) 3676-3711, 3745 by Venue & Xerox Corporation.
|
||||
(PUTPROPS PUP MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP" :BASE 10Q))
|
||||
|
||||
(PUTPROPS PUP FILETYPE CL:COMPILE-FILE)
|
||||
(PUTPROPS PUP COPYRIGHT ("Venue & Xerox Corporation" 3676Q 3677Q 3700Q 3701Q 3702Q 3703Q 3704Q 3705Q
|
||||
3706Q 3707Q 3710Q 3711Q 3745Q))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (25631Q 61606Q (\STARTPUP 25643Q . 26515Q) (ASSURE.PUP.READY 26517Q . 34612Q) (
|
||||
\FIND.LOCALPUPHOSTNUMBER 34614Q . 37012Q) (\PROMPT.FOR.PUP.NUMBER 37014Q . 41034Q) (\HANDLE.RAW.PUP
|
||||
41036Q . 57136Q) (\FORWARD.PUP 57140Q . 60060Q) (\SETPUPCHECKSUM 60062Q . 61604Q)) (66376Q 73470Q (
|
||||
\PUPERROR 66410Q . 73466Q)) (73527Q 112663Q (SETUPPUP 73541Q . 76727Q) (SWAPPUPPORTS 76731Q . 77546Q)
|
||||
(GETPUP 77550Q . 102462Q) (SENDPUP 102464Q . 106306Q) (EXCHANGEPUPS 106310Q . 110346Q) (DISCARDPUPS
|
||||
110350Q . 111154Q) (GETPUPWORD 111156Q . 111475Q) (\PUPINIT 111477Q . 112661Q)) (112664Q 154244Q (
|
||||
ETHERHOSTNAME 112676Q . 122024Q) (ETHERHOSTNUMBER 122026Q . 122441Q) (ETHERPORT 122443Q . 126162Q) (
|
||||
BESTPUPADDRESS 126164Q . 136224Q) (NETDAYTIME0 136226Q . 136557Q) (\PUP.SETTIME 136561Q . 137206Q) (
|
||||
\SETNEWTIME0 137210Q . 140270Q) (\NET.SETTIME 140272Q . 141361Q) (NETDATE 141363Q . 141720Q) (
|
||||
\LOOKUPPORT 141722Q . 147561Q) (\PARSE.PORTCONSTANT 147563Q . 152673Q) (\FIXLOCALNET 152675Q . 154242Q
|
||||
)) (154245Q 155602Q (PORTSTRING 154257Q . 155246Q) (OCTALSTRING 155250Q . 155600Q)) (156174Q 165305Q (
|
||||
CLEARPUP 156206Q . 160721Q) (PUTPUPWORD 160723Q . 161250Q) (GETPUPBYTE 161252Q . 161575Q) (PUTPUPBYTE
|
||||
161577Q . 162130Q) (GETPUPSTRING 162132Q . 163563Q) (GETPUPSTREAM 163565Q . 164514Q) (PUTPUPSTRING
|
||||
164516Q . 165303Q)) (167410Q 175227Q (READPLIST 167422Q . 175225Q)) (175410Q 200610Q (
|
||||
\CANONICAL.HOSTNAME 175422Q . 176467Q) (\CANONICALIZE.PUP.HOSTNAME 176471Q . 200606Q)) (203163Q
|
||||
236370Q (\PUPGATELISTENER 203175Q . 207026Q) (\HANDLE.PUP.ROUTING.INFO 207030Q . 221367Q) (\ROUTE.PUP
|
||||
221371Q . 225224Q) (\LOCATE.PUPNET 225226Q . 231763Q) (SORT.PUPHOSTS.BY.DISTANCE 231765Q . 234241Q) (
|
||||
\PUPNET.CLOSERP 234243Q . 235424Q) (PUPNET.DISTANCE 235426Q . 236366Q)) (250017Q 257771Q (
|
||||
OPENPUPSOCKET 250031Q . 254512Q) (CLOSEPUPSOCKET 254514Q . 256173Q) (PUPSOCKETNUMBER 256175Q . 256426Q
|
||||
) (PUPSOCKETFROMNUMBER 256430Q . 257067Q) (PUPSOCKETEVENT 257071Q . 257350Q) (\FLUSHPUPSOCQUEUE
|
||||
257352Q . 257767Q)) (257772Q 260537Q (\GETMISCSOCKET 260004Q . 260535Q)) (300551Q 313341Q (
|
||||
PUP.ECHOSERVER 300563Q . 303370Q) (PUP.ECHOUSER 303372Q . 313337Q)) (313372Q 322523Q (\PEEKPUP 313404Q
|
||||
. 320535Q) (\MAYBEPEEKPUP 320537Q . 322521Q)) (323124Q 334361Q (PRINTPUP 323136Q . 327306Q) (
|
||||
PRINTPUPROUTE 327310Q . 331255Q) (PRINTPUPDATA 331257Q . 331727Q) (PRINTERRORPUP 331731Q . 332431Q) (
|
||||
PUPTRACE 332433Q . 332744Q) (PRINTCONSTANT 332746Q . 334357Q)))))
|
||||
(FILEMAP (NIL (25117Q 61405Q (\STARTPUP 25131Q . 26003Q) (ASSURE.PUP.READY 26005Q . 34100Q) (
|
||||
\FIND.LOCALPUPHOSTNUMBER 34102Q . 36611Q) (\PROMPT.FOR.PUP.NUMBER 36613Q . 40633Q) (\HANDLE.RAW.PUP
|
||||
40635Q . 56735Q) (\FORWARD.PUP 56737Q . 57657Q) (\SETPUPCHECKSUM 57661Q . 61403Q)) (66151Q 73243Q (
|
||||
\PUPERROR 66163Q . 73241Q)) (73302Q 112436Q (SETUPPUP 73314Q . 76502Q) (SWAPPUPPORTS 76504Q . 77321Q)
|
||||
(GETPUP 77323Q . 102235Q) (SENDPUP 102237Q . 106061Q) (EXCHANGEPUPS 106063Q . 110121Q) (DISCARDPUPS
|
||||
110123Q . 110727Q) (GETPUPWORD 110731Q . 111250Q) (\PUPINIT 111252Q . 112434Q)) (112437Q 154017Q (
|
||||
ETHERHOSTNAME 112451Q . 121577Q) (ETHERHOSTNUMBER 121601Q . 122214Q) (ETHERPORT 122216Q . 125735Q) (
|
||||
BESTPUPADDRESS 125737Q . 135777Q) (NETDAYTIME0 136001Q . 136332Q) (\PUP.SETTIME 136334Q . 136761Q) (
|
||||
\SETNEWTIME0 136763Q . 140043Q) (\NET.SETTIME 140045Q . 141134Q) (NETDATE 141136Q . 141473Q) (
|
||||
\LOOKUPPORT 141475Q . 147334Q) (\PARSE.PORTCONSTANT 147336Q . 152446Q) (\FIXLOCALNET 152450Q . 154015Q
|
||||
)) (154020Q 155355Q (PORTSTRING 154032Q . 155021Q) (OCTALSTRING 155023Q . 155353Q)) (155747Q 165060Q (
|
||||
CLEARPUP 155761Q . 160474Q) (PUTPUPWORD 160476Q . 161023Q) (GETPUPBYTE 161025Q . 161350Q) (PUTPUPBYTE
|
||||
161352Q . 161703Q) (GETPUPSTRING 161705Q . 163336Q) (GETPUPSTREAM 163340Q . 164267Q) (PUTPUPSTRING
|
||||
164271Q . 165056Q)) (166651Q 174470Q (READPLIST 166663Q . 174466Q)) (174651Q 200051Q (
|
||||
\CANONICAL.HOSTNAME 174663Q . 175730Q) (\CANONICALIZE.PUP.HOSTNAME 175732Q . 200047Q)) (202406Q
|
||||
235613Q (\PUPGATELISTENER 202420Q . 206251Q) (\HANDLE.PUP.ROUTING.INFO 206253Q . 220612Q) (\ROUTE.PUP
|
||||
220614Q . 224447Q) (\LOCATE.PUPNET 224451Q . 231206Q) (SORT.PUPHOSTS.BY.DISTANCE 231210Q . 233464Q) (
|
||||
\PUPNET.CLOSERP 233466Q . 234647Q) (PUPNET.DISTANCE 234651Q . 235611Q)) (247006Q 256760Q (
|
||||
OPENPUPSOCKET 247020Q . 253501Q) (CLOSEPUPSOCKET 253503Q . 255162Q) (PUPSOCKETNUMBER 255164Q . 255415Q
|
||||
) (PUPSOCKETFROMNUMBER 255417Q . 256056Q) (PUPSOCKETEVENT 256060Q . 256337Q) (\FLUSHPUPSOCQUEUE
|
||||
256341Q . 256756Q)) (256761Q 257526Q (\GETMISCSOCKET 256773Q . 257524Q)) (277224Q 312014Q (
|
||||
PUP.ECHOSERVER 277236Q . 302043Q) (PUP.ECHOUSER 302045Q . 312012Q)) (312045Q 321176Q (\PEEKPUP 312057Q
|
||||
. 317210Q) (\MAYBEPEEKPUP 317212Q . 321174Q)) (321577Q 333034Q (PRINTPUP 321611Q . 325761Q) (
|
||||
PRINTPUPROUTE 325763Q . 327730Q) (PRINTPUPDATA 327732Q . 330402Q) (PRINTERRORPUP 330404Q . 331104Q) (
|
||||
PUPTRACE 331106Q . 331417Q) (PRINTCONSTANT 331421Q . 333032Q)))))
|
||||
STOP
|
||||
|
||||
BIN
sources/PUP.LCOM
BIN
sources/PUP.LCOM
Binary file not shown.
Reference in New Issue
Block a user