mirror of
https://github.com/PDP-10/its.git
synced 2026-05-09 17:17:58 +00:00
Package system for Muddle.
This commit is contained in:
Lars Brinkhoff
521
src/rrs/itspkg.urs233
Normal file
521
src/rrs/itspkg.urs233
Normal file
@@ -0,0 +1,521 @@
|
||||
|
||||
"ITSPKG URS227 PART 1"
|
||||
|
||||
|
||||
;" ITSPKG is a minimal PACKAGE handling routines for ITS MUDDLE.
|
||||
Based RRS's code and MIMPCK
|
||||
"
|
||||
|
||||
<BLOCK (<ROOT>)>
|
||||
;" atoms on <root> used by the PACKAGE handling routines.
|
||||
At the present time Only PACKAGE, ENTRY, ENDPACKAGE, USE and
|
||||
L_UNUSE are supported by ITSPKG RRS "
|
||||
|
||||
PACKAGE-MODE PACKAGE RPACKAGE ENTRY RENTRY SURVIVOR EXTERNAL USE
|
||||
USE-WHEN USE-TOTAL USE-DEBUG USE-DEFER EXPORT INCLUDE INCLUDE-WHEN
|
||||
INCLUDE-DEBUG COMPILING? DEBUGGING? DEFINITIONS END-DEFINITIONS DROP
|
||||
NULL-OBLIST ENDPACKAGE L-SEARCH-PATH L-SECOND-NAMES L-OPEN L-FLOAD
|
||||
L-LOAD L-LOADER L-NO-FILES L-NO-MAGIC L-ALWAYS-INQUIRE L-UNUSE
|
||||
UNUSE L-GASSIGNED? L-NOISY L-VERY-NOISY L-TRANSLATIONS
|
||||
L-USE-ABSTRACTS? TRANSLATE UNTRANSLATE TRANSLATIONS IN-COLLECTION
|
||||
OBLIST IOBLIST DISMISS
|
||||
;"NPCK is loaded before INT.
|
||||
|
||||
On root oblist used by PACKAGE routines. "
|
||||
<MOBLIST PACKAGE>
|
||||
<MOBLIST PKG!-PACKAGE>
|
||||
|
||||
|
||||
;" Build oblists package we are building "
|
||||
<BLOCK (<MOBLIST IPKG!-PKG!-PACKAGE> <MOBLIST PKG!-PACKAGE> <ROOT>)>
|
||||
|
||||
|
||||
<PARSE "SEARCH!-PKG!-PACKAGE"> ;" create atom SEARCH!-PKG!-PACKAGE "
|
||||
|
||||
" USED BY L PACKAGE "
|
||||
<SETG PKG!-PACKAGE .OBLIST>
|
||||
<SETG PKG-OB <MOBLIST PACKAGE>>
|
||||
<SETG COL-OB <MOBLIST RPACKAGE>>
|
||||
<SETG LAST-SEARCH-VAL <>>
|
||||
"..................................................."
|
||||
|
||||
"________________________PART 2____________________________________________"
|
||||
" For debugging
|
||||
Print names of oblists on .OBLIST
|
||||
--------------------------------------------------"
|
||||
<DEFINE PRTDOBL!- ()<MAPF ,LIST #FUNCTION( (OBL)<GET .OBL OBLIST>) .OBLIST>>
|
||||
|
||||
<DEFINE PKG-OBL!- () <GET PACKAGE!- OBLIST>>
|
||||
|
||||
;" set .OBLIST for PACKAGE debugging"
|
||||
<DEFINE RECONFIG!- ("AUX" NMS)
|
||||
;<SET NLS (IPKG!-PKG!-PACKAGE PKG!-PACKAGE INITIAL!- ROOT!- )>
|
||||
<SET NLS (IPKG!-PKG!-PACKAGE PKG!-PACKAGE ROOT!- )>
|
||||
<SET RSTLSTS
|
||||
<MAPF ,LIST #FUNCTION((LN) <GET .LN OBLIST>) .NLS> >
|
||||
<BLOCK <REST .RSTLSTS 0> >
|
||||
.NLS
|
||||
;<REST .RSTLSTS 0>>
|
||||
|
||||
;" GET OBLIST FOR OBLIST NAMED .PNAM "
|
||||
<DEFINE GETOBLNMD!- (PNAM)
|
||||
#DECL ((PNAM) STRING (VALUE) OBLIST)
|
||||
<GET <PARSE .PNAM> OBLIST>>
|
||||
|
||||
"...................PART 3.........................................."
|
||||
|
||||
|
||||
|
||||
"------------------------------PART 4---------------------------"
|
||||
|
||||
"BEFORE GDECL"
|
||||
|
||||
<GDECL (LAST-SEARCH-VAL) <OR STRING CHANNEL VECTOR FALSE>
|
||||
(L-SEARCH-PATH) <LIST [REST <OR STRING VECTOR>]>>
|
||||
"AFTER GDECL"
|
||||
|
||||
"========================PART 5=========================="
|
||||
<SETG L-NO-FILES <>>
|
||||
<SETG L-NOISY T>
|
||||
<SETG L-VERY-NOISY <>>
|
||||
"BEFORE OR GASSIGNED?"
|
||||
|
||||
<OR <GASSIGNED? L-TRANSLATIONS> <SETG L-TRANSLATIONS ()>>
|
||||
|
||||
"BEFORE GDECL"
|
||||
;"THIS SHOULD BE SETG'ED TO T IN COMPILERS."
|
||||
<OR <GASSIGNED? L-USE-ABSTRACTS?> <SETG L-USE-ABSTRACTS? #FALSE()> >
|
||||
"AFTER GDECL"
|
||||
|
||||
;"-------------------------------------------------------------
|
||||
modified bY rrs on 210308 "
|
||||
|
||||
<DEFINE PACKAGE (NAME
|
||||
"OPT" (INAME .NAME)
|
||||
"AUX" (TNAME <TRANSLATE? .NAME>) ATM
|
||||
IATM OBL IOBL TMP
|
||||
(OBLIS .OBLIST))
|
||||
#DECL( (NAME INAME) STRING
|
||||
(TNAME) <OR FALSE STRING>
|
||||
(VALUE ATM IATM) ATOM
|
||||
(TMP OBLIS) LIST
|
||||
(OBL IOBL) OBLIST )
|
||||
<COND (.TNAME
|
||||
<COND (<==? .INAME .NAME> <SET INAME <STRING !\I .TNAME>>)>
|
||||
<SET ATM <OR <LOOKUP .TNAME ,PKG-OB> <INSERT .TNAME ,PKG-OB>>>
|
||||
<SET OBL <MOBLIST .ATM>>
|
||||
<SET IATM <OR <LOOKUP .INAME .OBL> <INSERT .INAME .OBL>>>
|
||||
<SET IOBL <MOBLIST .IATM>>
|
||||
<BLOCK <SETG .ATM <SET TMP (.IOBL .OBL <ROOT>)>>>
|
||||
<COND (<AND <ASSIGNED? NO-LOAD> .NO-LOAD>
|
||||
<PUTPROP .TMP NOT-LOADED NOT-LOADED>)>)
|
||||
(<BLOCK <SET TMP (<1 .OBLIS> !.OBLIS)>> <SET ATM T>)>
|
||||
<COND (.TNAME <PUTPROP .ATM IOBLIST .IOBL>)>
|
||||
<PUTPROP .TMP IN-COLLECTION .ATM>
|
||||
.ATM>
|
||||
|
||||
|
||||
;"-------------------------------------------------------------"
|
||||
<DEFINE TRANSLATE? (NAME) ;" temporary TRANSLATE? Function"
|
||||
#DECL( (NAME) STRING
|
||||
(VALUE) <OR FALSE STRING> )
|
||||
.NAME>
|
||||
|
||||
;"
|
||||
PKG-OB is the PACKAGE!- oblist.
|
||||
-taa
|
||||
-------------------------------------------------------------
|
||||
|
||||
|
||||
ENTRY function of the PACKAGE routines
|
||||
|
||||
-------------------------------------------------------------"
|
||||
|
||||
<DEFINE ENTRY ("TUPLE" NAMES ) ;" modified by rrs on 210317"
|
||||
#DECL ((NAMES) <TUPLE [REST ATOM]>
|
||||
(VALUE) ATOM)
|
||||
<COND (<NOT <GETPROP <2 .OBLIST> DEFINITIONS>>
|
||||
<DO-ENTRY .NAMES <2 .OBLIST>>)>>
|
||||
|
||||
|
||||
<DEFINE DO-ENTRY (NAMES OBL
|
||||
"AUX" (OBLIS .OBLIST);" modified by rrs on 210317"
|
||||
(NAME T) ) ;"modified by RRS on 210310"
|
||||
#DECL ( (NAMES) <TUPLE [REST ATOM]>
|
||||
(OBLIS) LIST
|
||||
(NAME VALUE) ATOM )
|
||||
<PUTPROP .OBL USE-DEFER>
|
||||
<COND (<NOT <GETPROP .OBLIS IN-COLLECTION>>
|
||||
<ERROR ENTRY NOT-IN-PACKAGE-OR-COLLECTION!-ERRORS>)>
|
||||
<REPEAT ()
|
||||
<COND (<EMPTY? .NAMES> <RETURN .NAME>)>
|
||||
<SET NAME <1 .NAMES>>
|
||||
<SET NAMES <REST .NAMES>>
|
||||
<COND (<==? .OBL <ROOT>> <PUTPROP .NAME USE-DEFER>)>
|
||||
<COND (<==? <OBLIST? .NAME> <1 .OBLIS>>
|
||||
<INSERT <REMOVE .NAME> .OBL>)
|
||||
(<NOT <==? <OBLIST? .NAME> .OBL>>
|
||||
<ERROR ENTRY .NAME ALREADY-USED-ELSEWHERE!-ERRORS>)>>>
|
||||
|
||||
;"-------------------------------------------------------------
|
||||
|
||||
USE MODIFIED ON 210319 BY RRS
|
||||
-------------------------------------------------------------"
|
||||
|
||||
|
||||
<SETG L-SEARCH-PATH!- (<SNAME> "MUDDLE" "RRS")>
|
||||
|
||||
|
||||
<DEFINE USE ("TUPLE" NAMES
|
||||
"AUX" (OBLIS .OBLIST) NAME
|
||||
PK OBL N M ) ;"MODIFIED BY RRS 219318
|
||||
CONVERTED TO ITS MDL"
|
||||
#DECL ( (NAMES) <TUPLE [REST STRING]>
|
||||
(VALUE) ATOM
|
||||
(OBLIS) <LIST [REST OBLIST]>
|
||||
(NAME) STRING
|
||||
(PK) <OR ATOM FALSE>
|
||||
(OBL) <OR FALSE OBLIST>
|
||||
(N M)FIX )
|
||||
<REPEAT ((L-SP ,L-SEARCH-PATH))
|
||||
#DECL ( (L-SP) <LIST [REST <OR VECTOR STRING>]> )
|
||||
<COND (<EMPTY? .NAMES> <RETURN USE>)>
|
||||
<SET NAME <1 .NAMES>>
|
||||
<SET NAMES <REST .NAMES>>
|
||||
<SET PK <FIND/LOAD .NAME .L-SP PACKAGE-FIND>>
|
||||
<COND (<NOT .PK> <ERROR PACKAGE .NAME NOT-FOUND!-ERRORS>)
|
||||
(<==? .PK T>)
|
||||
(<GETPROP <SET OBL <MOBLIST .PK>> DEFINITIONS>
|
||||
<ERROR NOT-A-PROGRAM-MODULE!-ERRORS .PK USE>
|
||||
<SET PK %<>>)
|
||||
(<NOT <MEMQ .OBL .OBLIS>>
|
||||
<COND (<NOT <0? <SET N <LENGTH <MEMQ ,PKG-OB .OBLIS>>>>>
|
||||
<PUTREST <REST .OBLIS <- <SET M <LENGTH .OBLIS>> .N 1>>
|
||||
(.OBL !<REST .OBLIS <- .M .N>>)>)
|
||||
(T
|
||||
<PUTREST <REST .OBLIS <- <LENGTH .OBLIS> 1>> (.OBL)>)>)>
|
||||
<COND (.PK
|
||||
<DO-EXPORTS .PK>)>>>
|
||||
|
||||
|
||||
|
||||
<DEFINE DO-EXPORTS (PKNAME
|
||||
"AUX" (L <GETPROP .PKNAME EXPORT>))
|
||||
;"MODIFIED BY RRS 219318"
|
||||
#DECL ( (PKNAME) ATOM
|
||||
(L) <OR LIST FALSE> )
|
||||
<COND (<AND .L <NOT <EMPTY? .L>>>
|
||||
<USE !.L>)>>
|
||||
|
||||
|
||||
|
||||
;" ------------------------------------------------------------------------------------------
|
||||
FIND/LOAD and friends
|
||||
this is called by USE to find packaghes in memory or disk file
|
||||
FixED SearthPath Error --- RRS 210615
|
||||
------------------------------------------------------------------------------------------"
|
||||
<DEFINE FIND/LOAD (PKNAM
|
||||
"OPT" (SRCHPATH ,L-SEARCH-PATH) (INDC %<>)
|
||||
"AUX" (PKG-OB ,PKG-OB) TMP1 TMP2 TMP3
|
||||
(TMP %<>) (TL %<>) (NO-LOAD <>)
|
||||
(L .SRCHPATH) (OBLIS .OBLIST)
|
||||
(LACTION .INDC)
|
||||
(STR .PKNAM) (TSTR <TRANSLATE? .STR>)
|
||||
(OUTCHAN ,OUTCHAN)
|
||||
RESULT CH LDRSLT
|
||||
"ACT" FL)
|
||||
|
||||
#DECL( (PKNAM) STRING
|
||||
(SRCHPATH L) <OR LIST STRING>
|
||||
(VALUE TMP1) <OR ATOM FALSE>
|
||||
(TL) <OR FALSE LIST>
|
||||
(INDC LACTION) <OR ATOM FALSE>
|
||||
(PKG-OB) OBLIST
|
||||
(OBLIS) <LIST [REST OBLIST]>
|
||||
(TMP2 TMP3) ANY
|
||||
(OUTCHAN) <SPECIAL CHANNEL>
|
||||
(CH) CHANNEL
|
||||
(NO-LOAD) <SPECIAL ANY>
|
||||
(FL) ACTIVATION)
|
||||
|
||||
;" PKNAM, STR. <-- .NAME IS PACKAGE NAME TO FIND / LOAD
|
||||
SRCHPATH, L <-- IS THE SEARCH PATH
|
||||
INDC. <-- PACKAGE-FIND.. IS ATOM, INDCATOR OF WHAT IT FIND??
|
||||
VALUE. IS ATOM OF FOUND PACKAGE OR FALSE
|
||||
PKG-OB. <-- <GET PACKAGE!- OBLIST>
|
||||
"
|
||||
<SET TMP1 <LOOKUP .PKNAM .PKG-OB> >
|
||||
;"IF .TMP1 is <> then PACKAGE NOT LOADED OR NONEXISTANT"
|
||||
.TMP1
|
||||
<COND (.TMP1 .TMP1) ;"Package is already in memory"
|
||||
(<NOT .TMP1> ;"Needs to be loaded"
|
||||
<SET LDRSLT <MYPKGLOADER .PKNAM .SRCHPATH>>
|
||||
<SET TMP1 .LDRSLT> )>
|
||||
<COND (<NOT .TMP1> <SET TMP1 #FALSE("PACKAGE NOT FOUND")>)>
|
||||
.TMP1>
|
||||
|
||||
|
||||
|
||||
<DEFINE MYPKGLOADER (PCKNAM
|
||||
"OPT" (SRCHPATH ,L-SEARCH-PATH)
|
||||
"AUX" (PKG-OB ,PKG-OB) TMP1 TMP2 TMP3
|
||||
"ACT" AMPL )
|
||||
#DECL( (PCKNAM) STRING
|
||||
(SRCHPATH L) <OR LIST STRING>
|
||||
(VALUE TMP1) <OR ATOM FALSE> )
|
||||
<COND(<TYPE? .SRCHPATH LIST>
|
||||
<MAPF <>
|
||||
#FUNCTION((SDIR)
|
||||
<SET PFNAM <STRING .SDIR ";" .PCKNAM " >">>
|
||||
<COND( <FILE-EXISTS? .PFNAM>
|
||||
<SET CH <OPEN "READ" .PFNAM>>
|
||||
<COND (.CH
|
||||
<LOAD .CH> <CLOSE .CH>
|
||||
<RETURN <LOOKUP .PCKNAM .PKG-OB> .AMPL> )> )> )
|
||||
.SRCHPATH > )
|
||||
(<TYPE? .SRCHPATH STRING> <>);" DON'T DO TWINEX MUDDLE"
|
||||
(T <ERROR INVALID-SCRCHPATH!-ERRORS!- .SCRHPATH>)>
|
||||
#FALSE("PACKAGE NOT FOUND")>
|
||||
|
||||
" ------------------------------------------------------------------------------------------"
|
||||
|
||||
|
||||
|
||||
;"-------------------------------------------------------------
|
||||
|
||||
ENDPACKAGE function
|
||||
|
||||
-------------------------------------------------------------"
|
||||
|
||||
|
||||
<DEFINE ENDPACKAGE ("OPT" (PKNM %<>)
|
||||
"AUX" (OBLIS .OBLIST) PK) ;" MODIFIED BY RRS ON 210310"
|
||||
#DECL( (PKNM) <OR FALSE ATOM STRING>
|
||||
(OBLIS) <LIST [REST OBLIST]>
|
||||
(PK) <OR ATOM FALSE> )
|
||||
<REPEAT ()
|
||||
<COND (<SET PK <GETPROP .OBLIS IN-COLLECTION>>
|
||||
<PUTPROP .OBLIS IN-COLLECTION>
|
||||
<ENDBLOCK>
|
||||
<SET OBLIS .OBLIST>
|
||||
.PK)
|
||||
(<TYPE? .PKNM ATOM> <RETURN>)
|
||||
(T
|
||||
<ERROR UNMATCHED-ENDPACKAGE-OR-ENDCOLLECTION!-ERRORS>
|
||||
<RETURN>)>
|
||||
<COND (<OR <NOT .PKNM> <=? <SPNAME .PK> .PKNM>> <RETURN>)>>>
|
||||
|
||||
|
||||
;" ---------------------------------------------------------------
|
||||
DROP AND FRIENDS BY RRS ON 210415
|
||||
---------------------------------------------------------------
|
||||
|
||||
find the index needed by NTH of the package's oblist in .OBLIST."
|
||||
<DEFINE FNDOBLIDX (PKN "OPT" (OBLS .OBLIST)
|
||||
"AUX" (IDX 0) X Y Z )
|
||||
#DECL( (PKN) STRING (OBLS) <LIST [REST OBLIST]>
|
||||
(IDX VALUE) <OR FIX FALSE> )
|
||||
<REPEAT ((I 1)(LEN <LENGTH .OBLS>) OBL)
|
||||
#DECL( (I LEN) FIX (OBL) OBLIST )
|
||||
<SET OBL <NTH .OBLS .I>>
|
||||
<SET OBNAM <PNAME <GET .OBL OBLIST>>>
|
||||
<COND (<=? .PKN .OBNAM>
|
||||
<SET IDX .I> <RETURN .I> )
|
||||
(T <SET I <+ .I 1>> )>
|
||||
<AND <G? .I .LEN> <RETURN <SET IDX 0>> >
|
||||
>
|
||||
<COND (<0? .IDX> <SET IDX #FALSE(OBLIST-NOT-FOUND) >)>
|
||||
.IDX>
|
||||
|
||||
|
||||
;" REMOVE THE NTH NODE IN A LIST. Doesn't MODIFIES THE ORGINAL LIST
|
||||
LIKE REST FOR N ==? 0 RETURN THE LIST UNCHANGED. LST IS A SALLOW
|
||||
COPY OF .L"
|
||||
<DEFINE LRM (L N "AUX" X Y Z (LST <LIST !.L>) "ACT" A)
|
||||
#DECL ((L LST VALUE) LIST (N) FIX)
|
||||
<COND (<==? .N 0> <RETURN <SET LST .LST> .A>)
|
||||
(<==? .N 1> <RETURN <SET LST <REST .LST>> .A>)>
|
||||
<PUTREST <REST .LST <- .N 2>> <REST .LST <+ .N 0>>>
|
||||
.LST>
|
||||
|
||||
;" REMOVE A DROPPED PACKAGE FROM .OBLIST . IF THE PACKAGE
|
||||
IS NOT FOUND, THEN NO CHANGES TO .OBLIST ARE MADE"
|
||||
<DEFINE DROP(PKN "AUX" NOBLS OOBLS N X Y Z)
|
||||
#DECL((PKN) STRING (N) <OR FIX FALSE>
|
||||
(NOBLS OOBLS)<OR <LIST [REST OBLIST]> FALSE>
|
||||
(VALUE) STRING )
|
||||
<SET OOBLS .OBLIST>
|
||||
<SET N <FNDOBLIDX .PKN>>
|
||||
<OR .N <SET N 0>>
|
||||
<SET NOBLS <LRM .OOBLS .N>>
|
||||
;"Danger! Will Robbinson"
|
||||
<SET OBLIST .NOBLS>
|
||||
"PAGKAGE DROPPED" >
|
||||
|
||||
|
||||
" -------------------------------------------------------------
|
||||
|
||||
PACKAGE routine's L-UNUSE function and friends
|
||||
|
||||
-------------------------------------------------------------"
|
||||
|
||||
;" PACKAGE routine's L-UNUSE function
|
||||
Modified by RRS on 210310
|
||||
Modified by RRS on 210406 fixed TMP's DECL
|
||||
Modified by RRS on 210527 added SPCL-ATOM-TABLE"
|
||||
|
||||
<DEFINE L-UNUSE (STR
|
||||
"AUX" TMP ATM IATM)
|
||||
#DECL( (STR) <OR STRING FALSE>
|
||||
(ATM IATM) <OR OBLIST FALSE>
|
||||
(TMP) <OR ATOM FALSE>
|
||||
(ATOM-TABLE) <OR <LIST [REST ATOM]> FALSE>)
|
||||
<SET STR <TRANSLATE? .STR>>
|
||||
<SET ATOM-TABLE
|
||||
<SPCL-ATOM-TABLE .STR>> ;" ADDED 210527 "
|
||||
<COND (<NOT .STR>);" input STR is FALSE do nothing "
|
||||
(<AND <SET TMP <LOOKUP .STR ,PKG-OB>> <GASSIGNED? .TMP>>
|
||||
<SET ATM <MOBLIST .TMP>>
|
||||
<DROP .STR>
|
||||
<SET IATM <GETPROP .TMP IOBLIST>>
|
||||
" ---------OLD CODE---commented out------------- "
|
||||
;<MAPF %<>
|
||||
<FUNCTION (L)
|
||||
#DECL((L) ;"LIST" ANY)
|
||||
<MAPF %<>
|
||||
<FUNCTION (A)
|
||||
#DECL( (A) <OR ATOM LINK>)
|
||||
<COND (<OR <==? <OBLIST? .A> .ATM>
|
||||
<==? <OBLIST? .A> .IATM>>
|
||||
<REMOVE .A>)>>
|
||||
.L>>
|
||||
;",ATOM-TABLE> whats this??? REMOVED 210527 "
|
||||
.ATOM-TABLE> ;" ADDED 210527 "
|
||||
" -------------------NEW code ------------------- "
|
||||
<MAPF %<>
|
||||
,UNASS-REMOV
|
||||
.ATOM-TABLE >
|
||||
" --------------------------------------------- "
|
||||
<GUNASSIGN .TMP>
|
||||
<PUTPROP .TMP IOBLIST>
|
||||
<REMOVE .TMP ,PKG-OB>
|
||||
"PACKAGE REMOVED")
|
||||
(T #FALSE ("NOT PACKAGE OR DATUM"));" STR is not a valid PACKAGE">>
|
||||
|
||||
<SETG UNUSE ,L-UNUSE>
|
||||
|
||||
" ---------------------------------------------------------------------------------------"
|
||||
;" UNSET / UNSETG A GIVE ATOM AND REMOVE IT "
|
||||
<DEFINE UNASS-REMOV( ATOM )
|
||||
#DECL((ATOM) ATOM)
|
||||
<COND(<GASSIGNED? .ATOM> <GUNASSIGN .ATOM>)>
|
||||
<COND (<ASSIGNED? .ATOM> <UNASSUGN .ATOM>)>
|
||||
<REMOVE .ATOM> >
|
||||
|
||||
;"MAKE A SPECAL ATOM-TABLE FOR L-UNUSE
|
||||
ONLY LOOK AT THE PACKAGES TWO OBLIST. I DON'T THINK
|
||||
THIS WILL WORK FOR RPACKAGES"
|
||||
<DEFINE SPCL-ATOM-TABLE (PKGNAM
|
||||
"OPT" (FLAGS 0) "AUX" X Y Z "ACT" A)
|
||||
#DECL ( (VALUE LE LI ATOM-TABLE) <OR FALSE <LIST [REST ATOM]>>
|
||||
(PKGNAM STRE STRI) STRING
|
||||
(ATME ATMI) ATOM
|
||||
(POBLE POBLI) OBLIST
|
||||
(FLAGS) <PRIMTYPE WORD>
|
||||
(X Y Z) ANY
|
||||
(A) ACTIVATION)
|
||||
<SET STRE .PKGNAM> ;"Name of package & external oblist"
|
||||
<SET ATME <LOOKUP .STRE
|
||||
<GET PACKAGE OBLIST>>> ;"Atom's PNAME is name package oblist"
|
||||
<OR .ATME <RETURN #FALSE("PKG DOESN'T EXIST") .A> >
|
||||
<SET STRI <STRING !"I .STRE>> ;"Name of package's internal oblist"
|
||||
<SET ATMI
|
||||
<LOOKUP .STRI
|
||||
<GET .ATME OBLIST>>> ;"Atom's PNAME is name package internal oblist"
|
||||
<SET POBLE <GET .ATME OBLIST>> :"Package external oblist"
|
||||
<SET POBLI <GET .ATMI OBLIST>> ;"Package internal oblist"
|
||||
<SET LE <OBL2ALST .POBLE>> ;"Flatten Package external oblist"
|
||||
<SET LI <OBL2ALST .POBLI>> ;"Flatten Package internal oblist"
|
||||
<SET ATOM-TABLE <LIST !.LI !.LE>> ;"Build atom-table."
|
||||
.ATOM-TABLE >
|
||||
|
||||
;" OBL2ALST CREATES A FLAT LIST OF ATOMS FROM AN OBLIUST
|
||||
THIS FUNCTION WAS DESIGNED TO WORK WITH THE OLD FORM
|
||||
OF OBLISTS, BUT WORKS FINE ON THE NEW FORM OF OBLISTS"
|
||||
<DEFINE OBL2ALST (OBL
|
||||
"AUX" (ALST ()) TMP )
|
||||
#DECL ((OBL) <OR OBLIST <UVECTOR [REST LIST]>>
|
||||
(ALST VALUE) LIST (TMP) ANY)
|
||||
<MAPF %<>
|
||||
#FUNCTION ((OB) <SET ALST <LIST !.ALST !.OB>>)
|
||||
.OBL>
|
||||
.ALST>
|
||||
|
||||
<SETG UNUSE ,L-UNUSE>
|
||||
|
||||
" --------------------------------------------------------------------------------------"
|
||||
|
||||
|
||||
;"-------------------------------------------------------------
|
||||
|
||||
|
||||
unused at the minute. RRS 210310 at the present time
|
||||
-------------------------------------------------------------"
|
||||
|
||||
;<DEFINE TRANSLATE? (NAME:STRING
|
||||
"AUX" (L:<LIST [REST STRING <OR STRING FALSE>]>
|
||||
,L-TRANSLATIONS))
|
||||
<REPEAT ()
|
||||
<COND (<EMPTY? .L> <RETURN .NAME>)
|
||||
(<=? <1 .L>:STRING .NAME> <RETURN <2 .L>>)>
|
||||
<SET L <REST .L 2>>>>
|
||||
|
||||
;<DEFINE TRANSLATE (FROM:STRING TO:<OR FALSE STRING>
|
||||
"AUX" (L:<LIST [REST STRING <OR FALSE STRING>]>
|
||||
,L-TRANSLATIONS) (OUTCHAN:CHANNEL ,OUTCHAN))
|
||||
<REPEAT ()
|
||||
<COND (<EMPTY? .L>
|
||||
<SETG L-TRANSLATIONS (.FROM .TO !,L-TRANSLATIONS)>
|
||||
<RETURN>)
|
||||
(<=? <1 .L>:STRING .FROM> <PUT .L 2 .TO> <RETURN>)>
|
||||
<SET L <REST .L 2>>>
|
||||
<PRINC .FROM>
|
||||
<PRINC " --> ">
|
||||
<PRINC .TO>
|
||||
<CRLF>>
|
||||
|
||||
;<DEFINE UNTRANSLATE ("OPT" (NAME:STRING "")
|
||||
"AUX" (L:<LIST [REST STRING <OR FALSE STRING>]>
|
||||
,L-TRANSLATIONS))
|
||||
<COND (<EMPTY? .NAME>
|
||||
<SETG L-TRANSLATIONS '()>
|
||||
<PRINC "All gone">
|
||||
<CRLF>)
|
||||
(T
|
||||
<REPEAT ((L1:<LIST [REST STRING <OR FALSE STRING>]> .L)
|
||||
L2:<LIST [REST <OR FALSE STRING>]>)
|
||||
<COND (<EMPTY? .L1> <RETURN #FALSE ("NOT TRANSLATED")>)
|
||||
(<=? <1 .L1>:STRING .NAME>
|
||||
<COND (<==? .L .L1>
|
||||
<SETG L-TRANSLATIONS <REST .L 2>>)
|
||||
(<PUTREST <REST .L2> <REST .L1 2>>)>
|
||||
<RETURN .NAME>)>
|
||||
<SET L2 .L1>
|
||||
<SET L1 <REST .L1 2>>>)>>
|
||||
;"-------------------------------------------------------------
|
||||
|
||||
|
||||
|
||||
; -------------------------------------------------------------
|
||||
|
||||
; clean up at the end of ITSPKG "
|
||||
|
||||
<SETG L-NO-MAGIC <>>
|
||||
<SETG L-ALWAYS-INQUIRE <>>
|
||||
<SETG IOB <MOBLIST <LOOKUP "INITIAL" <ROOT>>>>
|
||||
<ENDBLOCK>
|
||||
<ENDBLOCK>
|
||||
<SET OBLIST ,OBLIST>
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user