(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(FILECREATED " 6-Nov-87 18:41:12" {PHYLUM}<CTAMARIN>EMULATOR>EMULATORCONTROL.;50 41177
changes to%: (FNS MakeIOList DefineSection InitNodeInfo InitEmulat getnode)
previous date%: "14-Oct-87 13:48:28" {PHYLUM}<CTAMARIN>EMULATOR>EMULATORCONTROL.;47)
(* "
Copyright (c) 1986, 1987 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT EMULATORCONTROLCOMS)
(RPAQQ EMULATORCONTROLCOMS ((RECORDS SectionRec WireRec)
(* * Make Control Functions)
(FNS DefineSections DefineSection)
(* * Code Generation Functions to Setup the Values)
(FNS MakeConversion)
(* * Code Generation Functions to Save the Values)
(FNS MakeCompare)
(* * RunTime Value Setting Routines)
(FNS SetVal)
(* * Make Control Create-Time Service Routines)
(FNS MakeParmList MakeIOList InitNodeInfo AddRef)
(* * Routines which clear out old section info)
(FNS ClearSectionLinks ClearProps)
(* * Service Macros)
(FUNCTIONS DefSection ELTX ELTMI)
(* * Macro Support Routines)
(FNS AddToDefList MakeTFExpr AddInputOutputs)
(* * Initialization Routines)
(FNS InitEmulat AddGlobal)
(* * NoNodes Simulator Routines)
(FNS NodelessSetup NodelessSimStep senque queuexenques queuewires setall
getnode findnode clearnode initsim walknet queueall)
(FUNCTIONS queued)))
(DECLARE%: EVAL@COMPILE
(DATATYPE SectionRec ((elink XPOINTER)
(SectionName POINTER)
(CallProc POINTER)
(queued POINTER)))
(DATATYPE WireRec ((elink XPOINTER)
(name XPOINTER)
(value POINTER)
(setby POINTER)
(newvalue POINTER)
(newsetby POINTER)
(input FLAG)))
)
(/DECLAREDATATYPE 'SectionRec '(XPOINTER POINTER POINTER POINTER) '((SectionRec 0 XPOINTER)
(SectionRec 2 POINTER)
(SectionRec 4 POINTER)
(SectionRec 6 POINTER))
'8)
(/DECLAREDATATYPE 'WireRec '(XPOINTER XPOINTER POINTER POINTER POINTER POINTER FLAG)
'((WireRec 0 XPOINTER)
(WireRec 2 XPOINTER)
(WireRec 4 POINTER)
(WireRec 6 POINTER)
(WireRec 8 POINTER)
(WireRec 10 POINTER)
(WireRec 10 (FLAGBITS . 0)))
'12)
(* * Make Control Functions)
(DEFINEQ
(DefineSections
[LAMBDA (compilefns?) (* rtk "17-Oct-86 15:13")
(if (BOUNDP 'SectionNames)
then (for i in SectionNames do (ClearSectionLinks i)))
(SETQ EMULATORMADEFNSCOMS NIL)
(SetBusSizes)
(SETQ SectionNames (SetSectionInfo))
(for i in SectionNames do (DefineSection i compilefns?])
(DefineSection
[LAMBDA (SectionName compilefns makevectors) (* ; "Edited 5-Nov-87 11:50 by Krivacic")
(DECLARE (GLOBALVARS *LASTVECTORSECTION* *LASTSECTION*))
(if (NULL SectionName)
then (SETQ SectionName *LASTSECTION*))
(SETQ *LASTSECTION* SectionName)
(if makevectors
then (SETQ *LASTVECTORSECTION* SectionName))
(LET
[allnodes inputs outputs accessables codelist ↑enables enables letlist LocalGlobals
sectioninfolist sectionnode orginputs orgoutputs milist millist CallExpr testsetexpr
testretexpr testexpr (CallName (PACK (LIST 'Call SectionName)))
(testname (PACK (LIST 'Test SectionName]
(SETQ sectioninfolist (APPLY* SectionName T))
(PRINTOUT T "Creating Callfn for " SectionName T)
(ClearSectionLinks SectionName T)
(for j in sectioninfolist do (SELECTQ (CAR j)
(Inputs (SETQ inputs (MakeIOList SectionName j))
(PUTPROP SectionName 'SectionInputs inputs))
(OrgInputs (SETQ orginputs (CADR j)))
(OrgOutputs (SETQ orgoutputs (CADR j)))
(Mi (SETQ milist (COPY (CADR j)))
(PUTPROP SectionName 'MiFields milist))
(Mil (SETQ millist (COPY (CADR j)))
(PUTPROP SectionName 'MilFields millist))
(Accessables (SETQ accessables (MakeIOList SectionName j))
(PUTPROP SectionName 'SectionAccessables
accessables))
(Outputs (SETQ outputs (MakeIOList SectionName j))
(PUTPROP SectionName 'SectionOutputs outputs))
(Latches (PUTPROP SectionName 'SectionLatches j))
(↑Latches NIL)
(PassGates (PUTPROP SectionName 'SectionPassGates j)
(SETQ PassGates (APPEND (CADR j)
PassGates)))
(Code (SETQ codelist (CADR j)))
(BREAK1 NIL T (Illegal Node List)
NIL)))
[if (OR orgoutputs orginputs)
then (PUTPROP SectionName 'Vectors (TCONC NIL (LIST orginputs orgoutputs]
(SETQ EMULATORMADEFNSCOMS (CONS (LIST 'FNS CallName)
EMULATORMADEFNSCOMS))
(SETQ SectionNames (CONS SectionName SectionNames))
(MakeParmList inputs outputs accessables SectionName)
(* * Add Lets to set values)
[SETQ letlist (CONS `(SETQ vectors ,(if (AND orgoutputs (NOT orginputs))
then '(CONS NIL NIL)
else NIL))
(APPEND (for k in inputs when (NOT (NUMBERP k))
collect (MakeConversion k 'Input))
(for k in accessables collect (MakeConversion k 'Input))
(for k in '(Clock Clock2 nClock nClock2 WriteOk Done)
when [AND (OR (FMEMB 'Clocks inputs)
(FMEMB 'Clocks accessables))
(AND (NOT (FMEMB k inputs))
(NOT (FMEMB k accessables]
collect (MakeConversion k 'Clocks))
(for k in outputs
when [NOT (OR (NUMBERP k)
(FMEMB k (GETPROP SectionName 'SectionInputs))
(FMEMB k (GETPROP SectionName 'SectionAccessables]
collect (MakeConversion k))
(for k in milist collect (MakeConversion k 'Mi))
(for k in millist collect (MakeConversion k 'Mil]
(* * Set call & value return exprs)
(SETQ CallExpr
(APPEND letlist (if (AND makevectors orginputs)
then [SETQ testsetexpr (for wire in orginputs
collect `(SetVal ,wire ,(U-CASE wire]
[LIST `(SETQ vectors (CONS (LIST ,@orginputs)
NIL]
else NIL)
codelist
(if (AND makevectors orgoutputs)
then [SETQ testretexpr
`(CL:VALUES ,@(for wire in orgoutputs
collect `(fetch (WireRec newvalue) of ,(U-CASE wire]
[LIST `(PUTPROP SectionName 'Vectors (TCONC (GETPROP SectionName 'Vectors)
(RPLACD vectors
(LIST (LIST ,@orgoutputs]
else NIL)
(if outputs
then (for k in outputs collect (MakeCompare k SectionName))
else NIL)))
[while (GREATERP (LENGTH letlist)
0)
do (PROG ((worklist letlist))
(SETQ letlist (FNTH letlist 16))
(SETQ CallExpr (LIST (APPEND [LIST 'LET (for i from 1
to (MIN (LENGTH worklist)
15) as j in worklist
collect (CADR j))
(LIST 'DECLARE
(CONS 'LOCALVARS
(for i from 1
to (MIN (LENGTH worklist)
15) as j in worklist
collect (CADR j]
CallExpr]
(* * put inside the Lambda)
[SETQ CallExpr (LIST 'LAMBDA 'NIL (APPEND [LIST 'LET `((SectionName (QUOTE %, SectionName]
(APPEND [LIST `(DECLARE (LOCALVARS SectionName))
`(IF ShowEnterExit
THEN (PRINTOUT T SectionName]
CallExpr
(LIST `(IF ShowEnterExit
THEN (PRINTOUT T "...." T]
[if (OR testsetexpr testretexpr)
then (LET [(inputs (for i in orginputs
join (SELECTQ i
(Mi (for i in milist collect (PACK (LIST 'Mi- i))))
(Mil (for i in millist
collect (PACK (LIST 'Mil- i))))
(LIST i]
(SETQ testexpr (APPEND
(LIST 'CL:LAMBDA inputs)
[LIST '(DECLARE (GLOBALVARS *LASTVECTORSECTION*))
`(SETQ *LASTVECTORSECTION* ,(LIST 'QUOTE SectionName]
[if milist
then (LIST `(SETQ Mi (CREATE MI]
[if millist
then (LIST `(SETQ Mil (CREATE MI]
[for field in milist
collect `(replace (MI ,field) of Mi
with ,(PACK (LIST 'Mi- field]
[for field in millist
collect `(replace (MI ,field) of Mil
with ,(PACK (LIST 'Mil- field]
testsetexpr
(LIST (LIST CallName)
(LIST 'queuewires)
testretexpr]
(PUTD CallName CallExpr)
(if testexpr
then (PUTD testname testexpr))
(if compilefns
then (LET ((oldglobals GLOBALVARS))
(CL:UNWIND-PROTECT (PROG NIL
(SETQ GLOBALVARS (APPEND GLOBALVARS LocalGlobals))
(SETQ LCFIL NIL)
(COMPILE1 CallName CallExpr)
(if testexpr
then (COMPILE1 testname testexpr)))
(SETQ GLOBALVARS oldglobals])
)
(* * Code Generation Functions to Setup the Values)
(DEFINEQ
(MakeConversion
[LAMBDA (item wiremode) (* ; "Edited 19-Jun-87 14:47 by Krivacic")
(SELECTQ wiremode
(Input `[SETQ ,item (fetch (WireRec value) of ,(U-CASE item])
(Mi `(SETQ ,(PACK (LIST 'Mi- item)) (fetch (MI ,item) of (fetch (WireRec value) of MI))))
(Mil `(SETQ ,(PACK (LIST 'Mil- item)) (fetch (MI ,item) of (fetch (WireRec value)
of MIL))))
(Clocks `[SETQ ,item (ConcatBits '((Clocks 0 1 ,(ClockBit item])
`(SETQ ,item NIL])
)
(* * Code Generation Functions to Save the Values)
(DEFINEQ
(MakeCompare
[LAMBDA (item section) (* ; "Edited 28-May-87 15:35 by rtk")
(if (EQUAL item (U-CASE item))
then (PRINTOUT T "Global UpperCase Name Matches Local Name: " item T))
(LIST 'SetVal item (U-CASE item)
(LIST 'QUOTE section])
)
(* * RunTime Value Setting Routines)
(DEFINEQ
(SetVal
[LAMBDA (newval noderec section) (* ; "Edited 5-Jun-87 15:55 by rtk")
(if (NULL section)
then (SETQ section 'Input))
(PROG ((oldval (fetch (WireRec newvalue) of noderec))
(setby (fetch (WireRec newsetby) of noderec)))
(DECLARE (GLOBALVARS *SETWIRELIST* *SECTIONS*))
(if newval
then (if (AND setby (NEQ setby section)
(NEQ section 'Input)
(NOT (EQP newval oldval)))
then (PRINTOUT T "Two sections driving node: " (fetch (WireRec name)
of noderec)
" Driven By: "
(fetch (WireRec newsetby) of noderec)
" new section " section T)
(BREAK1 NIL T (Conflict))
elseif (AND (EQ section 'Input)
elist)
then (replace (WireRec value) of noderec with newval)
(replace (WireRec setby) of noderec with section)
(replace (WireRec newvalue) of noderec with newval)
(replace (WireRec newsetby) of noderec with NIL)
elseif (NOT (EQP newval oldval))
then (replace (WireRec newvalue) of noderec with newval)
(replace (WireRec newsetby) of noderec with section)
(if (NULL (fetch (WireRec elink) of noderec))
then (replace (WireRec elink) of noderec with *SETWIRELIST*)
(SETQ *SETWIRELIST* noderec)))
else (if (EQ setby section)
then (replace (WireRec newsetby) of noderec with NIL])
)
(* * Make Control Create-Time Service Routines)
(DEFINEQ
(MakeParmList
[LAMBDA (inputs outputs accessables sectionname) (* ; "Edited 28-May-87 15:40 by rtk")
(LET ((name NIL))
(for k in (LIST inputs outputs accessables) do (for j in k
do (SETQ name (U-CASE (CAR j)))
(AddGlobal name])
(MakeIOList
[LAMBDA (sectionname nodelistentry) (* ; "Edited 6-Nov-87 09:45 by Krivacic")
(LET (wire-name (nodetype (CAR nodelistentry)))
(for entry in (CADR nodelistentry) when (NOT (NUMBERP entry))
collect (SETQ wire-name (OR (AND (LISTP entry)
(CAR entry))
entry))
(InitNodeInfo entry SectionEnable sectionname)
[if (NOT (FMEMB sectionname (GETPROP wire-name nodetype)))
then (PUTPROP wire-name nodetype (CONS sectionname (GETPROP wire-name nodetype]
wire-name])
(InitNodeInfo
[LAMBDA (symbol unused sectionname) (* ; "Edited 5-Nov-87 11:44 by Krivacic")
(if (EQUAL symbol (U-CASE symbol))
then (PRINTOUT T "Global UpperCase Name Matches Local Name: " symbol T))
(if (NOT (FMEMB symbol allnodes))
then (SETQ allnodes (CONS symbol allnodes)))
(LET* ((capsymbol (U-CASE symbol))
(wire (getnode capsymbol))
(capsection (U-CASE sectionname)))
(SET capsymbol wire)
(AddGlobal capsymbol)
(replace (WireRec name) of wire with symbol)
(clearnode wire)
wire])
(AddRef
[LAMBDA (sectionname clocktype nodename) (* edited%: "28-Oct-86 12:49")
(IF (AND nodename (LITATOM nodename))
THEN (PUTPROP sectionname clocktype (CONS nodename (GETPROP sectionname clocktype])
)
(* * Routines which clear out old section info)
(DEFINEQ
(ClearSectionLinks
[LAMBDA (sectionname quiet) (* ; "Edited 5-Jun-87 13:34 by rtk")
(if (NOT quiet)
then (PRINTOUT T "Clearing " sectionname))
(SETQ SectionEnable NIL)
(ClearProps sectionname)
(SETQ sectionnode (getnode sectionname 'SectionRec))
(SET sectionname sectionnode)
(clearnode sectionnode)
(replace (SectionRec CallProc) of sectionnode with (PACK (LIST 'Call sectionname)))
(if (NOT quiet)
then (TERPRI T])
(ClearProps
[LAMBDA (section) (* ; "Edited 8-Jun-87 09:59 by Krivacic")
(REMPROPLIST section '(SectionInputs SectionAccessables SectionOutputs SectionLatches Vectors
MilFields MiFields])
)
(* * Service Macros)
(DEFMACRO DefSection (deflist)
[PROG (codelist enablelist enableinputlist quotelist inputlist outputlist accessablelist
↑latchlist gateexprs latchexprs orginputs orgoutputs proplist millist milist)
(DECLARE (CL:SPECIAL codelist enablelist enableinputlist quotelist inputlist outputlist
accessablelist ↑latchlist gateexprs latchexprs proplist millist milist))
(for i in deflist do (SELECTQ (CAR i)
(Inputs (SETQ inputlist i)
[SETQ orginputs (CONS 'OrgInputs (COPY (CDR i])
(Outputs (SETQ outputlist i)
[SETQ orgoutputs (CONS 'OrgOutputs (COPY (CDR i])
(Accessables (SETQ accessablelist i))
(Mil (SETQ millist i))
(Mi (SETQ milist i))
(Internals (FOR j IN (CADR i) do ((AddToDefList 'Inputs j)
(AddToDefList 'Outputs j))))
(Latches (Help)
(SETQ gateexprs (APPEND (CADR i)
gateexprs)))
(↑Latches (SETQ latchexprs (APPEND (CADR i)
latchexprs)))
(PassGates (Help)
(SETQ gateexprs (APPEND (CADR i)
gateexprs)))
(Globals (SETQ quotelist (CONS i quotelist)))
(Props (SETQ proplist (CADR i)))
(Code (SETQ codelist (CADR i))
(if (CADDR i)
then (PRINTOUT T "Error in Code List: " i T)
(BREAK1 NIL T (Code List Incorrectly Entered)))
(SETQ codelist (if (LISTP (CAR codelist))
then codelist
else (LIST codelist))))
(Enables (Help)
(SETQ enablelist (CONS 'Running (CADR i))))
(↑Enables (Help)
(SETQ enablelist (CONS 'Enableing (CADR i)))
(SETQ quotelist (CONS i quotelist)))
(BREAK1 NIL T (Illegal Section Parameter Name)
NIL)))
[for i in proplist
DO (SETQ codelist (LIST (APPEND [LIST 'LET (for propfield
in (GETPROP (L-CASE i)
'uField)
collect (CONS (PACK (LIST i '- (CAR
propfield
)))
(CDR propfield]
codelist]
[if gateexprs
then (for i in gateexprs
do (SETQ codelist
(CONS [APPEND (LIST 'IF (MakeTFExpr (CONS '(Not Latching) (CAR i))
T)
'THEN)
(for j in (CDR i)
collect (if (NOT (NUMBERP (CAR j)))
then (AddToDefList 'Inputs (CAR j))
(AddToDefList 'Outputs (CAR j)))
(AddToDefList 'Outputs (CADR j))
(AddToDefList 'Inputs (CADR j))
`(SetVal ,(CAR j) ,(U-CASE (CADR j)) SectionName)
`(SETQ ,(CADR j) ,(CAR j]
codelist]
(if latchexprs
then
(bind x for i in latchexprs
do (SETQ codelist
(CONS [APPEND (LIST 'IF (MakeTFExpr (CAR i)
T T)
'THEN)
(for j in (CDR i)
collect (IF [NOT (OR (FMEMB (CADR j)
(CADR inputlist))
(FMEMB (CADR j)
(CADR outputlist]
THEN (AddToDefList 'Inputs (CADR j)))
(AddToDefList 'Outputs (CADR j))
(IF [NOT (OR (NUMBERP (CAR j))
(FMEMB (CAR j)
(CADR inputlist))
(FMEMB (CAR j)
(CADR outputlist]
THEN (AddToDefList 'Outputs (CAR j)))
(AddToDefList 'Inputs (CAR j))
`(SETQ ,(CADR j) ,(CAR j]
codelist)))
(SETQ ↑latchlist (LIST '↑Latches ↑latchlist)))
(SETQ quotelist (if inputlist
then (CONS inputlist quotelist)
else quotelist))
(SETQ quotelist (if outputlist
then (CONS outputlist quotelist)
else quotelist))
(SETQ quotelist (if orginputs
then (CONS orginputs quotelist)
else quotelist))
(SETQ quotelist (if milist
then (CONS milist quotelist)
else quotelist))
(SETQ quotelist (if millist
then (CONS millist quotelist)
else quotelist))
(SETQ quotelist (if orgoutputs
then (CONS orgoutputs quotelist)
else quotelist))
(SETQ quotelist (if ↑latchlist
then (CONS ↑latchlist quotelist)
else quotelist))
(SETQ quotelist (if accessablelist
then (CONS accessablelist quotelist)
else quotelist))
(SETQ quotelist (if codelist
then (CONS (LIST 'Code codelist)
quotelist)
else quotelist))
(RETURN (LIST 'QUOTE (SORT quotelist T])
(DEFMACRO ELTX (array index) `(\GETBASEPTR (\GETBASEPTR ,array 0)
(LLSH ,index 1)) `(ELT ,array ,index))
(DEFMACRO ELTMI (array index) `(ELT ,array (OR (NUMBERP ,index)
0)))
(* * Macro Support Routines)
(DEFINEQ
(AddToDefList
[LAMBDA (kind val) (* ; "Edited 27-May-87 18:36 by rtk")
(if (EQ val 'Running)
then (SETQ kind 'Accessables))
(SELECTQ kind
(Inputs [if (NOT (FMEMB val (CADR inputlist)))
then (SETQ inputlist (LIST 'Inputs (CONS val (CADR inputlist])
(Accessables [if [NOT (OR (FMEMB val (CADR accessablelist))
(FMEMB val (CADR inputlist]
then (SETQ accessablelist (LIST 'Accessables (CONS val (CADR accessablelist])
(Outputs [if (NOT (FMEMB val (CADR outputlist)))
then (SETQ outputlist (LIST 'Outputs (CONS val (CADR outputlist])
NIL])
(MakeTFExpr
[LAMBDA (clocklist addtoinput addlatch addtocode) (* ; "Edited 28-May-87 12:13 by rtk")
(LET (enblist elselist)
(if (AND addtoinput addlatch)
then (AddToDefList 'Inputs 'Latching))
[SETQ enblist
(LIST 'TF (APPEND (if addlatch
then '(LAND Latching)
else '(LAND))
(for i in clocklist
collect (if (LISTP i)
then (SELECTQ (CAR i)
(Not (if addtoinput
then (AddToDefList 'Inputs (CADR i)))
`(LNOT %, (CADR i)))
(BREAK1 NIL T (Illegal Enable Clock CAR)))
else (if addtoinput
then (AddToDefList 'Inputs i))
i]
(if addtocode
then [SETQ elselist (AddInputOutputs (AND inputlist (CADR inputlist))
(AND outputlist (CADR outputlist]
[SETQ codelist (LIST (LIST 'PROG NIL
(if elselist
then (APPEND `(IF %, enblist
THEN) codelist '(ELSE) elselist)
else (APPEND `(IF %, enblist
THEN) codelist]
else enblist])
(AddInputOutputs
[LAMBDA (inputs outputs) (* rtk "21-Nov-86 09:51")
(for i in inputs when (FMEMB i outputs) collect `(SETQ %, i NIL])
)
(* * Initialization Routines)
(DEFINEQ
(InitEmulat
[LAMBDA (NoEmulator) (* ; "Edited 4-Nov-87 14:36 by Krivacic")
(if (NOT NoEmulator)
then (InitEmulator))
(initsim T)
(SETQ EMULATORMADEFNSCOMS NIL)
(SETQ *LASTVECTORSECTION* NIL)
(SetBusSizes])
(AddGlobal
[LAMBDA (varname) (* rtk "17-Oct-86 15:20")
[if (LISTP varname)
then (for v in varname do (AddGlobal v))
else (if (NOT (FMEMB varname LocalGlobals))
then (SETQ LocalGlobals (CONS varname LocalGlobals]
varname])
)
(* * NoNodes Simulator Routines)
(DEFINEQ
(NodelessSetup
[LAMBDA (queueall) (* ; "Edited 10-Jun-87 11:11 by Krivacic")
(DECLARE (GLOBALVARS elist clearlist *SETWIRELIST* *SECTIONS*))
(SETQ numsteps (ADD1 numsteps))
(if (OR queueall elist)
then (PRINTOUT T "All Queued" T)
(SETQ clearlist NIL)
(SETQ elist (SETQ elast NIL))
(SETQ *SETWIRELIST* NIL)
(SETQ *SECTIONS* NIL)
[walknet (FUNCTION (LAMBDA (n)
(clearnode n)
(if (TYPENAMEP n 'SectionRec)
then (SETQ *SECTIONS* (CONS n *SECTIONS*))
(senque n]
else (queuexenques])
(NodelessSimStep
[LAMBDA (canlatch) (* ; "Edited 13-Oct-87 18:13 by Krivacic")
(DECLARE (GLOBALVARS *LASTVECTORSECTION* LATCHING clearlist elist elast *CHIP-SAVE-MODE*))
(SetVal (OZ canlatch)
LATCHING
'Latcher)
(NodelessSetup)
(if (EQ *LASTVECTORSECTION* 'WholeChip)
then (SETQ *CHIP-SAVE-MODE* 'Inputs)
(CallChipVectors))
(repeatwhile elist do (while elist do (APPLY* (fetch (SectionRec CallProc) of elist))
(SETQ elast elist)
(SETQ elist (fetch (SectionRec elink) of elist))
(replace (SectionRec elink) of elast with NIL)
(replace (SectionRec queued) of elast with NIL)
(SETQ elast NIL))
(SetVal 0 LATCHING 'Latcher)
(UpdateClocks)
(queuexenques))
(if (EQ *LASTVECTORSECTION* 'WholeChip)
then (SETQ *CHIP-SAVE-MODE* 'Outputs)
(CallChipVectors])
(senque
[LAMBDA (m) (* ; "Edited 29-May-87 10:18 by rtk")
[if (NOT (queued m))
then (SETQ elast (if elast
then (replace (SectionRec elink) of elast with m)
m
else (SETQ elist m]
(replace (SectionRec queued) of m with NIL])
(queuexenques
[LAMBDA NIL (* ; "Edited 9-Jun-87 10:51 by Krivacic")
(SETQ elist (SETQ elast NIL))
(queuewires T)
(LET (n)
(DECLARE (GLOBALVARS *SETWIRELIST* *SECTIONS*))
(for i in *SECTIONS* do (if (fetch (SectionRec queued) of i)
then (senque i])
(queuewires
[LAMBDA (queueit) (* ; "Edited 9-Jun-87 10:52 by Krivacic")
(DECLARE (GLOBALVARS *SETWIRELIST* *SECTIONS*))
(LET ((wirelist *SETWIRELIST*)
lastwire)
(while wirelist do (for i in (GETPROP (fetch (WireRec name) of wirelist)
'Inputs) when (NEQ (fetch (WireRec newsetby)
of wirelist)
i) do (replace (SectionRec queued)
of (GETTOPVAL i)
with queueit))
(replace (WireRec value) of wirelist with (fetch (WireRec newvalue)
of wirelist))
(replace (WireRec setby) of wirelist with (fetch (WireRec newsetby)
of wirelist))
(replace (WireRec newsetby) of wirelist with NIL)
(SETQ lastwire wirelist)
(SETQ wirelist (fetch (WireRec elink) of wirelist))
(replace (WireRec elink) of lastwire with NIL)))
(SETQ *SETWIRELIST* NIL])
(setall
[LAMBDA (val) (* ; "Edited 28-May-87 17:50 by rtk")
(DECLARE (GLOBALVARS gpot))
(SETQ gpot val)
(walknet (FUNCTION (LAMBDA (n)
(if (AND (TYPENAMEP n 'WireRec)
(NEQ (fetch (WireRec setby) of n)
'Input))
then (replace (WireRec value) of n with gpot])
(getnode
[LAMBDA (nodename nodetype) (* ; "Edited 4-Nov-87 14:44 by Krivacic")
(PROG ((n (findnode nodename)))
(if (NOT n)
then (SETQ nodecount (ADD1 nodecount))
(SETQ n (if (EQ nodetype 'SectionRec)
then (create SectionRec)
else (create WireRec)))
(SETQ nodenames (CONS nodename nodenames))
(PUTHASH nodename n nethash)
(if (EQ nodetype 'SectionRec)
then (replace (SectionRec SectionName) of n with nodename)
else (replace (WireRec name) of n with nodename)
(replace (WireRec value) of n with 0)
(replace (WireRec setby) of n with NIL)))
(if (EQ nodetype 'SectionRec)
then (replace (SectionRec elink) of n with NIL)
else (replace (WireRec elink) of n with NIL))
(RETURN n])
(findnode
[LAMBDA (nodename) (* ; "Edited 28-May-87 15:19 by rtk")
(if [NOT (OR (TYPENAMEP nodename 'WireRec)
(TYPENAMEP nodename 'SectionRec]
then (GETHASH nodename nethash)
else nodename])
(clearnode
[LAMBDA (n) (* ; "Edited 10-Jun-87 11:03 by Krivacic")
(if (TYPENAMEP n 'SectionRec)
then (replace (SectionRec elink) of n with NIL)
(replace (SectionRec queued) of n with NIL)
[LET* [(name (fetch (SectionRec SectionName) of n))
(prop (GETPROP name 'Vectors]
(if prop
then (PUTPROP name 'Vectors (TCONC NIL (CAAR prop]
else (replace (WireRec elink) of n with NIL)
(replace (WireRec setby) of n with NIL)
(if (NULL (fetch (WireRec value) of n))
then (replace (WireRec value) of n with 0))
(replace (WireRec newvalue) of n with NIL)
(replace (WireRec newsetby) of n with NIL])
(initsim
[LAMBDA (fast) (* ; "Edited 22-Jun-87 10:43 by Krivacic")
(if (BOUNDP 'nethash)
then (CLRHASH nethash)
(for i from 0 to (SUB1 (ARRAYSIZE netarray)) do (SETA netarray i NIL))
(NodelessSetup T)
else (SETQ nethash (HASHARRAY 10000))
(SETQ netarray (ARRAY 25000 'POINTER NIL 0)))
(if (BOUNDP 'SectionNames)
then (for i in SectionNames
do [for k in '(SectionInputs SectionOutputs)
do (for j in (GETPROP i k) do (REMPROPLIST j '(Inputs Outputs Accessables]
(ClearProps i)))
(SETQ *SETWIRELIST* NIL)
(SETQ BreakOnAll NIL)
(SETQ nodecount 0)
(SETQ nodeoffset 0)
(SETQ nodemax 0)
(SETQ Cycles 100)
(SETQ ResetCycle 0)
(SETQ numsteps 0)
(SETQ nion 0)
(SETQ trancount 0)
(SETQ tindex 0)
(SETQ tracenumber 0)
(SETQ tracelist NIL)
(SETQ warning NIL)
(SETQ queuelist NIL)
(SETQ ShowEnterExit NIL)
(SETQ elast NIL)
(SETQ elist NIL)
(SETQ nodenames NIL)
(SETQ includetemps NIL)
(SETQ warningdisplay NIL)
(SETQ nodemaplist NIL)
(SETQ errortracefile NIL)
(SETQ recordchanges NIL)
(SETQ log T)
(SETQ doreques T)
(SETQ showdxs NIL)
(SETQ showreques NIL)
(SETQ ErrorCycles 0)
(SETQ ErrorCount 0)
(RECLAIM)
(* * EMULATORCONTORL VARS)
(SETQ report NIL)
(SETQ SectionQueue NIL)
(SETQ SectionNames NIL])
(walknet
[LAMBDA (func names) (* ; "Edited 28-May-87 17:19 by rtk")
(if names
then [PROG (node name)
(for i in names do (if (SETQ node (findnode i))
then (APPLY* func node]
else (MAPHASH nethash func])
(queueall
[LAMBDA NIL
(DECLARE (GLOBALVARS elist)) (* ; "Edited 5-Jun-87 13:28 by rtk")
(SETQ elist T])
)
(DEFMACRO queued (m) `(OR (fetch (SectionRec elink) of ,m)
(EQ elast ,m)))
(PUTPROPS EMULATORCONTROL COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (3124 13476 (DefineSections 3134 . 3537) (DefineSection 3539 . 13474)) (13535 14177 (
MakeConversion 13545 . 14175)) (14235 14563 (MakeCompare 14245 . 14561)) (14607 16737 (SetVal 14617 .
16735)) (16792 18855 (MakeParmList 16802 . 17216) (MakeIOList 17218 . 17933) (InitNodeInfo 17935 .
18598) (AddRef 18600 . 18853)) (18910 19749 (ClearSectionLinks 18920 . 19467) (ClearProps 19469 .
19747)) (27836 30691 (AddToDefList 27846 . 28615) (MakeTFExpr 28617 . 30486) (AddInputOutputs 30488 .
30689)) (30728 31387 (InitEmulat 30738 . 31034) (AddGlobal 31036 . 31385)) (31427 40970 (NodelessSetup
31437 . 32250) (NodelessSimStep 32252 . 33518) (senque 33520 . 33954) (queuexenques 33956 . 34370) (
queuewires 34372 . 35945) (setall 35947 . 36438) (getnode 36440 . 37592) (findnode 37594 . 37886) (
clearnode 37888 . 38825) (initsim 38827 . 40436) (walknet 40438 . 40807) (queueall 40809 . 40968)))))
STOP