aboutsummaryrefslogtreecommitdiff
path: root/src/interp/br-op1.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/br-op1.boot.pamphlet')
-rw-r--r--src/interp/br-op1.boot.pamphlet1161
1 files changed, 1161 insertions, 0 deletions
diff --git a/src/interp/br-op1.boot.pamphlet b/src/interp/br-op1.boot.pamphlet
new file mode 100644
index 00000000..aea5b89b
--- /dev/null
+++ b/src/interp/br-op1.boot.pamphlet
@@ -0,0 +1,1161 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/br-op1.boot} Pamphlet}
+\author{The Axiom Team}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\section{License}
+
+<<license>>=
+-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
+-- All rights reserved.
+--
+-- Redistribution and use in source and binary forms, with or without
+-- modification, are permitted provided that the following conditions are
+-- met:
+--
+-- - Redistributions of source code must retain the above copyright
+-- notice, this list of conditions and the following disclaimer.
+--
+-- - Redistributions in binary form must reproduce the above copyright
+-- notice, this list of conditions and the following disclaimer in
+-- the documentation and/or other materials provided with the
+-- distribution.
+--
+-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the
+-- names of its contributors may be used to endorse or promote products
+-- derived from this software without specific prior written permission.
+--
+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+@
+<<*>>=
+<<license>>
+
+--====================> WAS b-op1.boot <================================
+
+--=======================================================================
+-- Operation Page Menu
+--=======================================================================
+--opAlist has form [[op,:alist],:.] where each alist
+-- has form [sig,pred,origin,exposeFlag,comments]
+
+dbFromConstructor?(htPage) == htpProperty(htPage,'conform)
+
+dbPresentOps(htPage,which,:exclusions) ==
+ true => dbPresentOpsSaturn(htPage,which,exclusions)
+--Flags:
+-- fromConPage?: came (originally) from a constructor page
+-- usage?: display usage?
+-- star?: display exposed/*=unexposed
+-- implementation?: display implementation?
+ htSay('"{\em Views:}")
+ asharp? := htpProperty(htPage,'isAsharpConstructor)
+ fromConPage? := (conname := opOf htpProperty(htPage,'conform))
+ usage? := $UserLevel = 'development and fromConPage? and which = '"operation"
+ and not (GETDATABASE(conname,'CONSTRUCTORKIND) = 'category)
+ and not asharp?
+ star? := not fromConPage? or which = '"package operation"
+ implementation? := not asharp? and
+ $UserLevel = 'development and $conformsAreDomains --and not $includeUnexposed?
+ rightmost? := star? or (implementation? and not $includeUnexposed?)
+ tabs :=
+ which = '"attribute" => '("12" "12" "25" "40" 13)
+ star? => '("12" "19" "31" "43" 10)
+ implementation? => '("9" "16" "28" "44" 9)
+ '("9" "16" "28" "41" 12)
+ if INTEGERP first exclusions then exclusions := ['documentation]
+ htpSetProperty(htPage,'exclusion,first exclusions)
+ opAlist :=
+ which = '"operation" => htpProperty(htPage,'opAlist)
+ htpProperty(htPage,'attrAlist)
+ empty? := null opAlist
+ htTab
+ which = '"attribute" => tabs.1
+ tabs.0
+ if empty? or member('names,exclusions) or null KDR opAlist
+ then htSay '"{\em names}"
+ else htMakePage [['bcLispLinks,['"names",'"",'dbShowOps,which,'names]]]
+ if which ^= '"attribute" then
+ htTab tabs.1
+ if empty? or member('signatures,exclusions)
+ then htSay '"{\em signatures}"
+ else htMakePage [['bcLispLinks,['"signatures",'"",'dbShowOps,which,'signatures]]]
+ htTab tabs.2
+ if empty? or member('parameters,exclusions) --also test for some parameter
+ or not dbDoesOneOpHaveParameters? opAlist
+ then htSay '"{\em parameters}"
+ else htMakePage [['bcLispLinks,['"parameters",'"",'dbShowOps,which,'parameters]]]
+ htTab tabs.3
+ if not empty? and null IFCDR opAlist and not htpProperty(htPage,'noUsage)
+ then
+ if htpProperty(htPage,'conform)
+ then htMakePage
+ [['bcLinks,['"generalise",'"",'dbShowOps,which,'generalise]]]
+ else htMakePage
+ [['bcLinks,['"all domains",'"",'dbShowOps,which,'allDomains]]]
+ else
+ if empty? or MEMQ('usage,exclusions) or htpProperty(htPage,'noUsage) then htSay '"{\em filter}" else
+ htMakePage [['bcLinks,['"filter",'"",'dbShowOps,which,'filter]]]
+ htMakePage [['bcStrings, [tabs.4,'"",'filter,'EM]]]
+ htSay('"\newline ")
+ if star?
+ then
+ if $exposedOnlyIfTrue
+ then htMakePage
+ [['bcLinks,['"exposed",'" {\em only}",'dbShowOps,which,'exposureOff]]]
+ else
+ htSay('"*{\em =}")
+ htMakePage [['bcLinks,['"unexposed",'"",'dbShowOps,which,'exposureOn]]]
+-- else if (updown := dbCompositeWithMap htPage)
+-- then htMakePage [['bcLispLinks,[updown,'"",'dbShowUpDown,updown]]]
+ htTab tabs.0
+ if usage? then
+ if empty? or member('usage,exclusions) or GETDATABASE(conname,'CONSTRUCTORKIND) = 'category or HGET($defaultPackageNamesHT,conname) or htpProperty(htPage,'noUsage)
+ then htSay '"{\em usage}"
+ else htMakePage [['bcLispLinks,['"usage",'"",'whoUsesOperation,which,nil]]]
+ htTab tabs.1
+ if empty? or member('origins,exclusions)
+ then htSay '"{\em origins}"
+ else htMakePage [['bcLispLinks,['"origins",'"",'dbShowOps,which,'origins]]]
+ htTab tabs.2
+ if implementation? then
+ if member('implementation,exclusions) or which = '"attribute" or
+ ((conname := opOf htpProperty(htPage,'conform)) and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category)
+ then htSay '"{\em implementation}"
+ else htMakePage [['bcLispLinks,['"implementation",'"",'dbShowOps,which,'implementation]]]
+ else if empty? or member('conditions,exclusions) or (htpProperty(htPage,'condition?) = 'no)
+ then htSay '"{\em conditions}"
+ else htMakePage [['bcLispLinks,['"conditions",'"",'dbShowOps,which,'conditions]]]
+ htTab tabs.3
+ if empty? or member('documentation,exclusions)
+ then htSay '"{\em description}"
+ else htMakePage [['bcLispLinks,['"description",'"",'dbShowOps,which,'documentation]]]
+ htShowPageNoScroll()
+
+htTab s == htSay('"\tab{",s,'"}")
+
+dbDoesOneOpHaveParameters? opAlist ==
+ or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn ==
+ STRINGP x => dbPart(x,2,1) ^= '"0"
+ KAR x
+--============================================================================
+-- Master Switch Functions for Operation Views
+--============================================================================
+
+dbShowOps(htPage,which,key,:options) ==
+ --NEXT LINE SHOULD BE REMOVED if we are sure that which is a string
+ which := STRINGIMAGE which
+ if MEMQ(key,'(extended basic all)) then
+ $groupChoice := key
+ key := htpProperty(htPage,'key) or 'names
+ opAlist :=
+ which = '"operation" => htpProperty(htPage,'opAlist)
+-- al := reduceByGroup(htPage,htpProperty(htPage,'principalOpAlist))
+-- htpSetProperty(htPage,'opAlist,al)
+-- al
+ htpProperty(htPage,'attrAlist)
+ key = 'generalise =>
+ arg := STRINGIMAGE CAAR opAlist
+ which = '"attribute" => aPage arg
+ oPage arg
+ key = 'allDomains => dbShowOpAllDomains(htPage,opAlist,which)
+ key = 'filter =>
+ --if $saturn, IFCAR options contains filter string
+ filter := IFCAR options or pmTransFilter(dbGetInputString htPage)
+ filter is ['error,:.] => bcErrorPage filter
+ opAlist:= [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)]
+ null opAlist => emptySearchPage(which,filter)
+ htPage := htInitPageNoScroll(htCopyProplist htPage)
+ if which = '"operation"
+ then htpSetProperty(htPage,'opAlist,opAlist)
+ else htpSetProperty(htPage,'attrAlist,opAlist)
+ if not htpProperty(htPage,'condition?) = 'no then
+ dbResetOpAlistCondition(htPage,which,opAlist)
+ dbShowOps(htPage,which,htpProperty(htPage,'exclusion))
+ htpSetProperty(htPage,'key,key)
+ if MEMQ(key,'(exposureOn exposureOff)) then
+ $exposedOnlyIfTrue :=
+ key = 'exposureOn => 'T
+ nil
+ key := htpProperty(htPage,'exclusion)
+ dbShowOp1(htPage,opAlist,which,key)
+
+reduceByGroup(htPage,opAlist) ==
+ not dbFromConstructor?(htPage) or null $groupChoice => opAlist
+ dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false)
+ bitNumber := HGET($topicHash,$groupChoice)
+ res := [[op,:newItems] for [op,:items] in opAlist | newItems] where
+ newItems ==
+ null bitNumber => items
+ [x for x in items | FIXP (code := myLastAtom x) and LOGBITP(bitNumber,code)]
+ res
+
+
+dbShowOp1(htPage,opAlist,which,key) ==
+ --set up for filtering below in dbGatherData
+ $which: local := which
+ if INTEGERP key then
+ opAlist := dbSelectData(htPage,opAlist,key)
+ ------> Jump out for constructor names in file <--------
+ INTEGERP key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile)
+ and constructor? con => return conPageChoose con
+ if INTEGERP key then
+ htPage := htInitPageNoScroll(htCopyProplist htPage)
+ if which = '"operation"
+ then htpSetProperty(htPage,'opAlist,opAlist)
+ else htpSetProperty(htPage,'attrAlist,opAlist)
+ if not htpProperty(htPage,'condition?) = 'no then
+ dbResetOpAlistCondition(htPage,which,opAlist)
+ dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false)
+ if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then
+ --opAlist is expanded to form [[op,[sig,pred,origin,exposed,comments],...],...]
+ opAlist:=[item for [op,:items] in opAlist | item] where
+ item ==
+ acc := nil
+ for x in items | x.3 repeat acc:= [x,:acc]
+ null acc => nil
+ [op,:NREVERSE acc]
+ $conformsAreDomains : local := htpProperty(htPage,'domname)
+ opCount := opAlistCount(opAlist, which)
+ branch :=
+ INTEGERP key =>
+ opCount <= $opDescriptionThreshold => 'documentation
+ 'names
+ key = 'names and null rest opAlist => --means a single op
+ opCount <= $opDescriptionThreshold => 'documentation
+ 'names
+ key
+ [what,whats,fn] := LASSOC(branch,$OpViewTable)
+ data := dbGatherData(htPage,opAlist,which,branch)
+ dataCount := +/[1 for x in data | (what = '"Name" and $exposedOnlyIfTrue => atom x; true)]
+ namedPart :=
+ null rest opAlist =>
+ ops := escapeSpecialChars STRINGIMAGE CAAR opAlist
+ ['" {\em ",ops,'"}"]
+ nil
+ if what = '"Condition" and null KAR KAR data then dataCount := dataCount - 1
+ exposurePart :=
+ $exposedOnlyIfTrue => '(" Exposed ")
+ nil
+ firstPart :=
+ opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which]
+ dataCount = 1 or dataCount = opCount =>
+ opCount = 1 => [:exposurePart, capitalize which,:namedPart]
+ [STRINGIMAGE opCount,'" ",:exposurePart,
+ pluralize capitalize which,:namedPart]
+ prefix := pluralSay(dataCount,what,whats)
+ [:prefix,'" for ",STRINGIMAGE opCount,'" ",pluralize capitalize which,:namedPart]
+ page := htInitPageNoScroll(htCopyProplist htPage)
+ ------------>above line used to call htInitPageHoHeading<----------
+ htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch)
+ htpSetProperty(page,'data,data)
+ htpSetProperty(page,'branch,branch)
+ -- the only place where specialMessage property is set seems to be commented. out
+ if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u)
+ htSayStandard('"\beginscroll ")
+ FUNCALL(fn,page,opAlist,which,data) --apply branch function
+ dbOpsExposureMessage()
+ htSayStandard("\endscroll ")
+ dbPresentOps(page,which,branch)
+ htShowPageNoScroll()
+
+opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo ==
+ null $exposedOnlyIfTrue or which = '"attribute" => #items
+ --count if unexpanded---CDDR(w) = nil---or if w.3 = true
+ +/[1 for w in items | null (p := CDDR w) or p . 1]
+
+dbShowOpHeading(heading, branch) ==
+ suffix :=
+-- branch = 'signatures => '" viewed as signatures"
+ branch = 'parameters => '" viewed with parameters"
+ branch = 'origins => '" organized by origins"
+ branch = 'conditions => '" organized by conditions"
+ '""
+ [:heading, suffix]
+
+dbOpsExposureMessage() ==
+ $atLeastOneUnexposed => htSay '"{\em *} = unexposed"
+
+fromHeading htPage ==
+ null htPage => '""
+ $pn := [htPage.0,'"}{"]
+ updomain := htpProperty(htPage,'updomain) =>
+ dnForm := dbExtractUnderlyingDomain updomain
+ dnString:= form2StringList dnForm
+ dnFence := form2Fence dnForm
+-- upString:= form2StringList updomain
+ upFence := form2Fence updomain
+ upOp := PNAME opOf updomain
+ ['" {\em from} ",:dbConformGen dnForm,'" {\em under} \ops{",upOp,'"}{",:$pn,:upFence,'"}"]
+ domname := htpProperty(htPage,'domname)
+ numberOfUnderlyingDomains := #[x for x in rest GETDATABASE(opOf domname,'COSIG) | x]
+-- numberOfUnderlyingDomains = 1 and
+-- KDR domname and (dn := dbExtractUnderlyingDomain domname) =>
+-- ['" {\em from} ",:pickitForm(domname,dn)]
+ KDR domname => ['" {\em from} ",:dbConformGen domname]
+ htpProperty(htPage,'fromHeading)
+
+pickitForm(form,uarg) ==
+ conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg)
+
+conformString(form) ==
+ KDR form =>
+ conform2StringList(form,FUNCTION conname2StringList,FUNCTION conformString,nil)
+ form2StringList form
+
+conform2StringList(form,opFn,argFn,exception) ==
+ exception := exception or '"%%%nothing%%%"
+ [op1,:args] := form
+ op := IFCAR HGET($lowerCaseConTb,op1) or op1
+ null args => APPLY(opFn,[op])
+ special := MEMQ(op,'(Union Record Mapping))
+ cosig :=
+ special => ['T for x in args]
+ rest GETDATABASE(op,'COSIG)
+ atypes :=
+ special => cosig
+ rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP)
+ sargl := [fn for x in args for atype in atypes for pred in cosig] where fn ==
+ keyword :=
+ x is [":",y,t] =>
+ x := t
+ y
+ nil
+ res :=
+ x = exception => dbOpsForm exception
+ pred =>
+ STRINGP x => [x]
+ u := APPLY(argFn,[x])
+ atom u and [u] or u
+ typ := sublisFormal(args,atype)
+ if x is ['QUOTE,a] then x := a
+ u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u]
+ NUMBERP x or STRINGP x => [x]
+ systemError()
+ keyword => [keyword,'": ",:res]
+ res
+ op = 'Mapping => dbMapping2StringList sargl
+ head :=
+ special => [op]
+ APPLY(opFn,[form])
+ [:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"]
+
+
+dbMapping2StringList [target,:sl] ==
+ null sl => target
+ restPart :=
+ null rest sl => nil
+ "append"/[[",",:y] for y in rest sl]
+ sourcePart :=
+ restPart => ['"(",:first sl,:restPart,'")"]
+ first sl
+ [:sourcePart,'" -> ",:target]
+
+dbOuttran form ==
+ if LISTP form then
+ [op,:args] := form
+ else
+ op := form
+ args := nil
+ cosig := rest GETDATABASE(op,'COSIG)
+ atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP)
+ argl := [fn for x in args for atype in atypes for pred in cosig] where fn ==
+ pred => x
+ typ := sublisFormal(args,atype)
+ arg :=
+ x is ['QUOTE,a] => a
+ x
+ res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm))
+ NUMBERP res or STRINGP res => res
+ ['QUOTE,res]
+ [op,:argl]
+
+dbOpsForm form ==
+--one button for the operations of a type
+--1st arg: like "Matrix(Integer)" or "UP('x,Integer)" <---all highlighted
+--2nd arg: like (|Matrix| (|Integer|)) and (|U..P..| (QUOTE |x|) (|Integer|))
+ ["\ops{",:conform2StringList(form,FUNCTION conname2StringList,FUNCTION conformString,nil),'"}{",:$pn,:form2Fence form,'"}"]
+
+dbConform form ==
+--------------------> OBSELETE <--------------------------
+--one button for the main constructor page of a type
+--NOTE: Next line should be as follows---but form2Fence form will
+-- put, e.g. '((2 1 . 0) (0 1 . 0)) instead of x**2 + 1
+ $saturn => ["\conf{",:form2StringList opOf form,
+ '"}{\lispLink{\verb!{(|conForm| '",:form2Fence dbOuttran form,'")!}}}"]
+ ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"]
+--["\conf{",:form2StringList opOf form,'"}{",:form2Fence opOf form,'"}"]
+
+
+dbConformGen form == dbConformGen1(form,true)
+--many buttons: one for the type and one for each inner type
+--NOTE: must only be called on types KNOWN to be correct
+
+dbConformGenUnder form == dbConformGen1(form,false)
+--same as above, except buttons only for the inner types
+
+dbConformGen1(form,opButton?) ==
+ opFunction :=
+ opButton? => FUNCTION dbConform
+ FUNCTION conname2StringList
+ originalOp := opOf form
+ op := unAbbreviateIfNecessary opOf form
+ args := IFCDR form
+ form :=
+ originalOp=op => form
+ [op, :args]
+ args => conform2StringList(form, opFunction,FUNCTION dbConformGen,nil)
+ APPLY(opFunction,[form])
+
+unAbbreviateIfNecessary op == IFCAR HGET($lowerCaseConTb, op) or op
+
+conname2StringList form == [PNAME unAbbreviateIfNecessary opOf form]
+
+--===========================================================================
+-- Data Gathering Code
+--============================================================================
+dbGatherData(htPage,opAlist,which,key) ==
+ key = 'implementation => dbGatherDataImplementation(htPage,opAlist)
+ dataFunction := LASSOC(key,table) where
+ table ==
+ $dbDataFunctionAlist or
+ ($dbDataFunctionAlist := [
+ ['signatures,:function dbMakeSignature],
+ ['parameters,:function dbContrivedForm],
+ ['origins,:function dbGetOrigin],
+ ['domains,:function dbGetOrigin],
+ ['conditions,:function dbGetCondition]])
+ null dataFunction =>
+ --key= names or filter or documentation; do not expand
+ if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then
+ opAlist := --to get indexing correct
+ which = '"operation" => htpProperty(htPage,'opAlist)
+ htpProperty(htPage,'attrAlist)
+ acc := nil
+ initialExposure :=
+ htPage and htpProperty(htPage,'conform) and which ^= '"package operation"
+ => true
+ --never star ops from a constructor
+ nil
+ for [op,:alist] in opAlist repeat
+ exposureFlag := initialExposure
+ while alist repeat
+ item := first alist
+ isExposed? :=
+ STRINGP item => dbExposed?(item,char 'o) --unexpanded case
+ null (r := rest rest item) => true --assume true if unexpanded
+ r . 1 --expanded case
+ if isExposed? then return (exposureFlag := true)
+ alist := rest alist
+ node :=
+ exposureFlag => op
+ [op,nil]
+ acc := [node,:acc]
+ NREVERSE acc
+ data := nil
+ dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in '(origins documentation),false)
+ --create data, a list of the form ((entry,exposeFlag,:entries)...)
+ for [op,:alist] in opAlist repeat
+ for item in alist repeat
+ entry := FUNCALL(dataFunction,op,item)--get key item
+ exposeFlag := --is the current op-sig exposed?
+ null (r := rest rest item) => true --not given, assume yes
+ r . 1 --is given, use value
+ tail :=
+ item is [.,'ASCONST,:.] => 'ASCONST
+ nil
+ newEntry :=
+ u := ASSOC(entry,data) => --key seen before? look on DATA
+ RPLACA(CDR u,CADR u or exposeFlag)--yes, expose if any 1 is exposed
+ u
+ data := [y := [entry,exposeFlag,:tail],:data]
+ y --no, create new entry in DATA
+ if member(key,'(origins conditions)) then
+ r := CDDR newEntry
+ if atom r then r := nil --clear out possible 'ASCONST
+ RPLACD(CDR newEntry, --store op/sigs under key if needed
+ insert([dbMakeSignature(op,item),exposeFlag,:tail],r))
+ if member(key,'(origins conditions)) then
+ for entry in data repeat --sort list of entries (after the 2nd)
+ tail := CDDR entry
+ tail :=
+ atom tail => tail
+ listSort(function LEXLESSEQP,tail)
+ RPLACD(CDR entry,tail)
+ data := listSort(function LEXLESSEQP,data)
+ data
+
+dbGatherDataImplementation(htPage,opAlist) ==
+--returns data, of form ((implementor exposed? entry entry...)...
+-- where entry has form ((op sig . implementor) . stuff)
+ conform := htpProperty(htPage,'conform)
+ domainForm := htpProperty(htPage,'domname)
+ dom := EVAL domainForm
+ which := '"operation"
+ [nam,:$domainArgs] := domainForm
+ $predicateList: local := GETDATABASE(nam,'PREDICATES)
+ predVector := dom.3
+ u := getDomainOpTable(dom,true,ASSOCLEFT opAlist)
+ --u has form ((op,sig,:implementor)...)
+ --sort into 4 groups: domain exports, unexports, default exports, others
+
+ for (x := [.,.,:key]) in u for i in 0.. repeat
+ key = domainForm => domexports := [x,:domexports]
+ INTEGERP key => unexports := [x,:unexports]
+ isDefaultPackageForm? key => defexports := [x,:defexports]
+ key = 'nowhere => nowheres := [x,:nowheres]
+ key = 'constant =>constants := [x,:constants]
+ others := [x,:others] --add chain domains go here
+ fn [nowheres,constants,domexports,SORTBY('CDDR,NREVERSE others),SORTBY('CDDR,
+ NREVERSE defexports),SORTBY('CDDR,NREVERSE unexports)] where
+ fn l ==
+ alist := nil
+ for u in l repeat
+ while u repeat
+ key := CDDAR u --implementor
+ entries :=
+ [[CAR u,true],:[u and [CAR u,true] while key = CDDAR (u := rest u)]]
+ alist := [[key,gn key,:entries],:alist]
+ NREVERSE alist
+ gn key ==
+ atom key => true
+ isExposedConstructor CAR key
+
+dbSelectData(htPage,opAlist,key) ==
+ branch := htpProperty(htPage,'branch)
+ data := htpProperty(htPage,'data)
+ MEMQ(branch,'(signatures parameters)) =>
+ dbReduceOpAlist(opAlist,data.key,branch)
+ MEMQ(branch,'(origins conditions implementation)) =>
+ key < 8192 => dbReduceOpAlist(opAlist,data.key,branch)
+ [newkey,binkey] := DIVIDE(key,8192) --newkey is 1 too large
+ innerData := CDDR data.(newkey - 1)
+ dbReduceOpAlist(opAlist,innerData.binkey,'signatures)
+ [opAlist . key]
+
+dbReduceOpAlist(opAlist,data,branch) ==
+ branch = 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data)
+ branch = 'origins => dbReduceBySelection(opAlist,CAR data,function CADDR)
+ branch = 'conditions => dbReduceBySelection(opAlist,CAR data,function CADR)
+ branch = 'implementation => dbReduceByOpSignature(opAlist,CDDR data)
+ branch = 'parameters => dbReduceByForm(opAlist,CAR data)
+ systemError ['"Unexpected branch: ",branch]
+
+dbReduceByOpSignature(opAlist,datalist) ==
+--reduces opAlist by implementation datalist, one of the form
+-- (((op,sig,:implementor),:stuff),...)
+ ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.]
+ acc := nil
+ for [op,:alist] in opAlist | MEMQ(op,ops) repeat
+ entryList := [entry for (entry := [sig,:.]) in alist | test] where test ==
+ or/[x for x in datalist | x is [[=op,=sig,:.],:.]]
+ entryList => acc := [[op,:NREVERSE entryList],:acc]
+ NREVERSE acc
+
+dbReduceBySignature(opAlist,op,sig) ==
+--reduces opAlist to one with a fixed op and sig
+ [[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]]
+
+dbReduceByForm(opAlist,form) ==
+ acc := nil
+ for [op,:alist] in opAlist repeat
+ items := [x for x in alist | dbContrivedForm(op,x) = form] =>
+ acc := [[op,:items],:acc]
+ NREVERSE acc
+
+dbReduceBySelection(opAlist,key,fn) ==
+ acc := nil
+ for [op,:alist] in opAlist repeat
+ items := [x for x in alist | FUNCALL(fn,x) = key] =>
+ acc := [[op,:items],:acc]
+ NREVERSE acc
+
+dbContrivedForm(op,[sig,:.]) ==
+ $which = '"attribute" => [op,sig]
+ dbMakeContrivedForm(op,sig)
+
+dbMakeSignature(op,[sig,:.]) == [op,sig] --getDomainOpTable format
+
+dbGetOrigin(op,[.,.,origin,:.]) == origin
+
+dbGetCondition(op,[.,pred,:.]) == pred
+
+--dbInsertOpAlist(op,item,opAlist) ==
+-- insertAlist(op,[item,:LASSOC(op,opAlist)],opAlist)
+
+--dbSortOpAlist opAlist ==
+-- [[op,:listSort(function LEXLESSEQP,alist)]
+-- for [op,:alist] in listSort(function LEXLESSEQP,opAlist)]
+
+--============================================================================
+-- Branches of Views
+--============================================================================
+dbShowOpNames(htPage,opAlist,which,data) ==
+ single? := opAlist and null rest data
+ single? =>
+ ops := escapeSpecialChars STRINGIMAGE CAAR opAlist
+ htSayStandard('"Select a view below")
+ htSaySaturn '"Select a view with the right mouse button"
+ exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage)
+ dbShowOpItems(which,data,exposedOnly?)
+
+dbShowOpItems(which,data,exposedOnly?) ==
+ htBeginTable()
+ firstTime := true
+ for i in 0.. for item in data repeat
+ if firstTime then firstTime := false
+ else htSaySaturn '"&"
+ if atom item then
+ op := item
+ exposeFlag := true
+ else
+ [op,exposeFlag] := item
+ ops := escapeSpecialChars STRINGIMAGE op
+ exposeFlag or not exposedOnly? =>
+ htSay('"{")
+ bcStarSpaceOp(ops,exposeFlag)
+ htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]]
+ htSay('"}")
+ htEndTable()
+
+dbShowOpAllDomains(htPage,opAlist,which) ==
+ dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false)
+ catOriginAlist := nil --list of category origins
+ domOriginAlist := nil --list of domain origins
+ for [op,:items] in opAlist repeat
+ for [.,predicate,origin,:.] in items repeat
+ conname := CAR origin
+ GETDATABASE(conname,'CONSTRUCTORKIND) = 'category =>
+ pred := simpOrDumb(predicate,LASSQ(conname,catOriginAlist) or true)
+ catOriginAlist := insertAlist(conname,pred,catOriginAlist)
+ pred := simpOrDumb(predicate,LASSQ(conname,domOriginAlist) or true)
+ domOriginAlist := insertAlist(conname,pred,domOriginAlist)
+ --the following is similar to "domainsOf" but do not sort immediately
+ u := [COPY key for key in HKEYS _*HASCATEGORY_-HASH_*
+ | LASSQ(CDR key,catOriginAlist)]
+ for pair in u repeat
+ [dom,:cat] := pair
+ LASSQ(cat,catOriginAlist) = 'etc => RPLACD(pair,'etc)
+ RPLACD(pair,simpOrDumb(GETDATABASE(pair,'HASCATEGORY),true))
+ --now add all of the domains
+ for [dom,:pred] in domOriginAlist repeat
+ u := insertAlist(dom,simpOrDumb(pred,LASSQ(dom,u) or true),u)
+ cAlist := listSort(function GLESSEQP,u)
+ for pair in cAlist repeat RPLACA(pair,getConstructorForm first pair)
+ htpSetProperty(htPage,'cAlist,cAlist)
+ htpSetProperty(htPage,'thing,'"constructor")
+ htpSetProperty(htPage,'specialHeading,'"hoho")
+ dbShowCons(htPage,'names)
+
+simpOrDumb(new,old) ==
+ new = 'etc => 'etc
+ atom new => old
+ 'etc
+
+dbShowOpOrigins(htPage,opAlist,which,data) ==
+ dbGatherThenShow(htPage,opAlist,which,data,true,'"from",function bcStarConform)
+
+dbShowOpImplementations(htPage,opAlist,which,data) ==
+ dbGatherThenShow(htPage,opAlist,which,data,true,'"by",function bcStarConform)
+
+dbShowOpConditions(htPage,opAlist,which,data) ==
+ dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred)
+
+dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) ==
+-----------------> OBSELETE
+ single? := null rest data
+ htSay('"\beginmenu ")
+ bincount := 0
+ for [thing,exposeFlag,:items] in data repeat
+ htSay('"\item ")
+ if single? then htSay(menuButton())
+ else htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]]
+ htSay '"{\em "
+ htSay
+ thing = 'nowhere => '"implemented nowhere"
+ thing = 'constant => '"constant"
+ thing = '_$ => '"by the domain"
+ INTEGERP thing => '"unexported"
+ constructorIfTrue =>
+ htSay word
+ atom thing => '" an unknown constructor"
+ '""
+ atom thing => '"unconditional"
+ '""
+ htSay '"}"
+ if null atom thing then
+ if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}")
+ htSay '" "
+ FUNCALL(fn,thing)
+ htSay('":\newline ")
+ dbShowOpSigList(which,items,(1 + bincount) * 8192)
+ bincount := bincount + 1
+ htSay '"\endmenu "
+
+dbShowKind conform ==
+ conname := CAR conform
+ kind := GETDATABASE(conname,'CONSTRUCTORKIND)
+ kind = 'domain =>
+ (s := PNAME conname).(MAXINDEX s) = '_& => '"default package"
+ '"domain"
+ PNAME kind
+
+dbShowOpSignatures(htPage,opAlist,which,data) == dbShowOpSigList(which,data,0)
+
+dbShowOpSigList(which,dataItems,count) ==
+--dataItems is (((op,sig,:.),exposureFlag,...)
+ single? := null rest dataItems
+ htBeginTable()
+ firstTime := true
+ for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat
+ if firstTime then firstTime := false
+ else htSaySaturn '"&";
+ ops := escapeSpecialChars STRINGIMAGE op
+ htSay '"{"
+-- if single? then htSay('"{\em ",ops,'"}") else.....
+ htSayExpose(ops,exposureFlag)
+ htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]]
+ if which = '"attribute" then htSay args2HtString (sig and [sig]) else
+ htSay '": "
+ tail = 'ASCONST => bcConform first sig
+ bcConform ['Mapping,:sig]
+ htSay '"}"
+ count := count + 1
+ htEndTable()
+ count
+
+dbShowOpParameters(htPage,opAlist,which,data) ==
+ single? := null rest data
+ count := 0
+ htBeginTable()
+ firstTime := true
+ for item in data repeat
+ if firstTime then firstTime := false
+ else htSaySaturn '"&"
+ [opform,exposeFlag,:tail] := item
+ op := intern IFCAR opform
+ args := IFCDR opform
+ ops := escapeSpecialChars STRINGIMAGE op
+ htSay '"{"
+ htSayExpose(ops,exposeFlag)
+ n := #opform
+ do
+ n = 2 and LASSOC('Nud,PROPLIST op) =>
+ dbShowOpParameterJump(ops,which,count,single?)
+ htSay('" {\em ",KAR args,'"}")
+ n = 3 and LASSOC('Led,PROPLIST op) =>
+ htSay('"{\em ",KAR args,'"} ")
+ dbShowOpParameterJump(ops,which,count,single?)
+ htSay('" {\em ",KAR KDR args,'"}")
+ dbShowOpParameterJump(ops,which,count,single?)
+ tail = 'ASCONST or member(op,'(0 1)) or which = '"attribute" and null IFCAR args => 'skip
+ htSay('"(")
+ if IFCAR args then htSay('"{\em ",IFCAR args,'"}")
+ for x in IFCDR args repeat
+ htSay('",{\em ",x,'"}")
+ htSay('")")
+ htSay '"}"
+ count := count + 1
+ htEndTable()
+
+dbShowOpParameterJump(ops,which,count,single?) ==
+ single? => htSay('"{\em ",ops,'"}")
+ htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]]
+
+dbShowOpDocumentation(htPage,opAlist,which,data) ==
+ if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then
+ opAlist :=
+ which = '"operation" => htpProperty(htPage,'opAlist)
+ htpProperty(htPage,'attrAlist)
+ --NOTE: this line is necessary to get indexing right.
+ --The test below for $exposedOnlyIfTrue causes unexposed items
+ --to be skipped.
+ newWhich :=
+ conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform)
+ which = '"package operation" => '"operation"
+ which
+ expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false)
+ if expand then
+ condata := dbGatherData(htPage,opAlist,which,'conditions)
+ htpSetProperty(htPage,'conditionData,condata)
+ base := -8192
+ exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp
+ htSaySaturn '"\begin{description}"
+ for [op,:alist] in opAlist repeat
+ base := 8192 + base
+ for item in alist for j in 0.. repeat
+ [sig,predicate,origin,exposeFlag,comments] := item
+ exposeFlag or not $exposedOnlyIfTrue =>
+ if comments ^= '"" and STRINGP comments and (k := string2Integer comments) then
+ comments :=
+ MEMQ(k,'(0 1)) => '""
+ dbReadComments k
+ tail := CDDDDR item
+ RPLACA(tail,comments)
+ doc := (STRINGP comments and comments ^= '"" => comments; nil)
+ pred := predicate or true
+ index := (exactlyOneOpSig => nil; base + j)
+ if which = '"package operation" then
+ sig := SUBST(conform,'_$,sig)
+ origin := SUBST(conform,'_$,origin)
+ displayDomainOp(htPage,newWhich,origin,op,sig,pred,doc,index,'dbChooseDomainOp,null exposeFlag,true)
+ htSaySaturn '"\end{description}"
+
+dbChooseDomainOp(htPage,which,index) ==
+ [opKey,entryKey] := DIVIDE(index,8192)
+ opAlist :=
+ which = '"operation" => htpProperty(htPage,'opAlist)
+ htpProperty(htPage,'attrAlist)
+ [op,:entries] := opAlist . opKey
+ entry := entries . entryKey
+ htPage := htInitPageNoScroll(htCopyProplist htPage)
+ if which = '"operation"
+ then htpSetProperty(htPage,'opAlist,[[op,entry]])
+ else htpSetProperty(htPage,'attrAlist,[[op,entry]])
+ if not htpProperty(htPage,'condition?) = 'no then
+ dbResetOpAlistCondition(htPage,which,opAlist)
+ dbShowOps(htPage,which,'documentation)
+
+htSayExpose(op,flag) ==
+ $includeUnexposed? =>
+ flag => htBlank()
+ op.0 = char '_* => htSay '"{\em *} "
+ htSayUnexposed()
+ htSay '""
+--============================================================================
+-- Branch-in From Other Places
+--============================================================================
+dbShowOperationsFromConform(htPage,which,opAlist) == --branch in with lists
+ $groupChoice := nil
+ conform := htpProperty(htPage,'conform)
+ --prepare opAlist for possible filtering of groups
+ if null BOUNDP '$topicHash then
+ $topicHash := MAKE_-HASHTABLE 'ID
+ for [x,:c] in '((extended . 0) (basic . 1) (hidden . 2)) repeat
+ HPUT($topicHash,x,c)
+ if domform := htpProperty(htPage,'domname) then
+ $conformsAreDomains : local := true
+ reduceOpAlistForDomain(opAlist,domform,conform)
+ conform := domform or conform
+ kind := capitalize htpProperty(htPage,'kind)
+ exposePart :=
+ isExposedConstructor opOf conform => '""
+ '" Unexposed "
+ fromPart :=
+ domform => evalableConstructor2HtString domform
+ form2HtString conform
+ heading :=
+ ['" from ",exposePart,kind,'" {\em ",fromPart,'"}"]
+ expandProperty :=
+ which = '"operation" => 'expandOperations
+ 'expandAttributes
+ htpSetProperty(htPage,expandProperty,'lists)
+ htpSetProperty(htPage,'fromHeading,heading)
+ reducedOpAlist :=
+ which = '"operation" => reduceByGroup(htPage,opAlist)
+ opAlist
+ if which = '"operation"
+ then
+ htpSetProperty(htPage,'principalOpAlist,opAlist)
+ htpSetProperty(htPage,'opAlist,reducedOpAlist)
+ else htpSetProperty(htPage,'attrAlist,opAlist)
+ if domform
+ then htpSetProperty(htPage,'condition?,'no)
+ else dbResetOpAlistCondition(htPage,which,opAlist)
+ dbShowOp1(htPage,reducedOpAlist,which,'names)
+
+reduceOpAlistForDomain(opAlist,domform,conform) ==
+--destructively simplify all predicates; filter out any that fail
+ form1 := [domform,:rest domform]
+ form2 := ['$,:rest conform]
+ for pair in opAlist repeat
+ RPLACD(pair,[test for item in rest pair | test]) where test ==
+ [head,:tail] := item
+ CAR tail = true => item
+ pred := simpHasPred SUBLISLIS(form1,form2,QCAR tail)
+ null pred => false
+ RPLACD(item,[pred])
+ item
+ opAlist
+
+dbShowOperationLines(which,linelist) == --branch in with lines
+ htPage := htInitPage(nil,nil) --create empty page
+ opAlist := nil
+ lines := linelist
+ while lines repeat
+ name := dbName (x := first lines)
+ pile := [x]
+ while (lines := rest lines) and name = dbName (x := first lines) repeat
+ pile := [x,:pile]
+ opAlist := [[name,:NREVERSE pile],:opAlist]
+ opAlist := listSort(function LEXLESSEQP,NREVERSE opAlist)
+ if which = '"operation"
+ then htpSetProperty(htPage,'opAlist,opAlist)
+ else htpSetProperty(htPage,'attrAlist,opAlist)
+ expandProperty :=
+ which = '"operation" => 'expandOperations
+ 'expandAttributes
+ htpSetProperty(htPage,expandProperty,'strings)
+ dbResetOpAlistCondition(htPage,which,opAlist)
+ if which = '"attribute" and BOUNDP '$attributeArgs and $attributeArgs then
+ --code needed to handle commutative("*"); called from aPage
+ --must completely expand the opAlist then check for those with
+ --arguments equal to $attributeArgs
+ --here: opAlist is [[op,:itemlist]]
+ dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,false)
+ opAlist := [[CAAR opAlist,:[item for item in CDAR opAlist | first item = $attributeArgs]]]
+ dbShowOp1(htPage,opAlist,which,'names)
+
+--============================================================================
+-- Code to Expand opAlist
+--============================================================================
+dbResetOpAlistCondition(htPage,which,opAlist) ==
+ value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true)
+ htpSetProperty(htPage,'condition?,(value => 'yes; 'no))
+ value
+
+dbSetOpAlistCondition(htPage,opAlist,which) ==
+--called whenever a new opAlist is needed
+--property can only be inherited if 'no (a subset says NO if whole says NO)
+ condition := htpProperty(htPage,'condition?)
+ MEMQ(condition,'(yes no)) => condition = 'yes
+ value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true)
+ htpSetProperty(htPage,'condition?,(value => 'yes; 'no))
+ value
+
+dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) ==
+--if condition? = true, stop when you find a non-trivial predicate
+--otherwise, expand in full
+--RETURNS:
+-- non-trivial predicate, if condition? = true and it finds one
+-- nil, otherwise
+--SIDE-EFFECT: this function references the "expand" property (set elsewhere):
+-- 'strings, if not fully expanded and it contains strings
+-- i.e. opAlist is ((op . (string ...))...) if unexpanded
+-- 'lists, if not fully expanded and it contains lists
+-- i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded
+ condition? := condition? and not $exposedOnlyIfTrue
+ value := nil --return value
+ expandProperty :=
+ which = '"operation" => 'expandOperations
+ 'expandAttributes
+ expandFlag := htpProperty(htPage,expandProperty)
+ expandFlag = 'fullyExpanded => nil
+ expandFlag = 'strings => --strings are partially expanded
+ for pair in opAlist repeat
+ [op,:lines] := pair
+ acc := nil
+ for line in lines repeat
+ --NOTE: we must expand all lines here for a given op
+ -- since below we will change opAlist
+ --Case 1: Already expanded; just cons it onto ACC
+ null STRINGP line => --already expanded
+ if condition? then --this could have been expanded at a lower level
+ if null atom (pred := CADR line) then value := pred
+ acc := [line,:acc] --this one is already expanded; record it anyway
+ --Case 2: unexpanded; expand it then cons it onto ACC
+ [name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1)
+ predicate := ncParseFromString pred
+ if condition? and null atom predicate then value := predicate
+ sig := ncParseFromString sigs --is (Mapping,:.)
+ if which = '"operation" then
+ if sig isnt ['Mapping,:.]
+ then sayBrightly ['"Unexpected signature for ",name,'": ",sigs]
+ else sig := rest sig
+ conname := intern dbNewConname line
+ origin := [conname,:getConstructorArgs conname]
+ exposeFlag := dbExposed?(line,char 'o)
+ acc := [[sig,predicate,origin,exposeFlag,comments],:acc]
+ --always store the fruits of our labor:
+ RPLACD(pair,NREVERSE acc) --at least partially expand it
+ condition? and value => return value --early exit
+ value => value
+ condition? => nil
+ htpSetProperty(htPage,expandProperty,'fullyExpanded)
+ expandFlag = 'lists => --lists are partially expanded
+ -- entry is [sig, predicate, origin, exposeFlag, comments]
+ $value: local := nil
+ $docTableHash := MAKE_-HASHTABLE 'EQUAL
+ packageSymbol := false
+ domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform)
+ if isDefaultPackageName opOf domform then
+ catname := intern SUBSTRING(s := PNAME opOf domform,0,MAXINDEX s)
+ packageSymbol := first rest domform
+ domform := [catname,:rest rest domform] --skip first argument ($)
+ docTable:= dbDocTable domform
+ for [op,:alist] in opAlist repeat
+ for [sig,:tail] in alist repeat
+ condition? => --the only purpose here is to find a non-trivial pred
+ null atom (pred := CAR tail) => return ($value := pred)
+ 'skip
+ u :=
+ tail is [.,origin,:.] and origin =>
+-- must change any % into $ otherwise we will not pick up comments properly
+-- delete the SUBLISLIS when we fix on % or $
+ dbGetDocTable(op,SUBLISLIS(['$],['%],sig),dbDocTable origin,which,nil)
+ if packageSymbol then sig := SUBST('_$,packageSymbol,sig)
+ dbGetDocTable(op,sig,docTable,which,nil)
+ origin := IFCAR u or origin
+ docCode := IFCDR u --> (doc . code)
+-- if null FIXP CDR docCode then harhar(op) -->
+ if null doc and which = '"attribute" then doc := getRegistry(op,sig)
+ RPLACD(tail,[origin,isExposedConstructor opOf origin,:docCode])
+ $value => return $value
+ $value => $value
+ condition? => nil
+ htpSetProperty(htPage,expandProperty,'fullyExpanded)
+ 'done
+
+getRegistry(op,sig) ==
+ u := GETDATABASE('AttributeRegistry,'DOCUMENTATION)
+ v := LASSOC(op,u)
+ match := or/[y for y in v | y is [['attribute,: =sig],:.]] => CADR match
+ '""
+
+evalableConstructor2HtString domform ==
+ if VECP domform then domform := devaluate domform
+ conname := first domform
+ coSig := rest GETDATABASE(conname,'COSIG)
+ --entries are T for arguments which are domains; NIL for computational objects
+ and/[x for x in coSig] => form2HtString(domform,nil,true)
+ arglist := [unquote x for x in rest domform] where
+ unquote arg ==
+ arg is [f,:args] =>
+ f = 'QUOTE => first args
+ [f,:[unquote x for x in args]]
+ arg
+ fargtypes:=CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP)
+--argtypes:= sublisFormal(arglist,fargtypes)
+ form2HtString([conname,:[fn for arg in arglist for x in coSig
+ for ftype in fargtypes]],nil,true) where
+ fn ==
+ x => arg
+ typ := sublisFormal(arglist,ftype)
+ mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm))
+
+mathform2HtString form == escapeString
+ $fortInts2Floats: local := false
+ form := niladicHack form
+ form is ['QUOTE,a] => STRCONC('"'","STRCONC"/fortexp0 a)
+ form is ['BRACKET,['AGGLST,:arg]] =>
+ if arg is ['construct,:r] then arg := r
+ arg :=
+ atom arg => [arg]
+ [y for x in arg | y := (x is ['QUOTE,a] => a; x)]
+ tailPart := "STRCONC"/[STRCONC('",",STRINGIMAGE x) for x in rest arg]
+ STRCONC('"[",STRINGIMAGE first arg,tailPart,'"]")
+ form is ['BRACKET,['AGGLST,'QUOTE,arg]] =>
+ if atom arg then arg := [arg]
+ tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg]
+ STRCONC('"[",first arg,tailPart,'"]")
+ atom form => form
+ "STRCONC"/fortexp0 form
+
+niladicHack form ==
+ atom form => form
+ form is [x] and GETL(x,'NILADIC) => x
+ [niladicHack x for x in form]
+
+--============================================================================
+-- Getting Operations from Domain
+--============================================================================
+
+getDomainOpTable(dom,fromIfTrue,:options) ==
+ ops := KAR options
+ $predEvalAlist : local := nil
+ $returnNowhereFromGoGet: local := true
+ domname := dom.0
+ conname := CAR domname
+ abb := getConstructorAbbreviation conname
+ opAlist := getOperationAlistFromLisplib conname
+ "append"/[REMDUP [[op1,:fn] for [sig,slot,pred,key,:.] in u
+ | key ^= 'Subsumed and ((null ops and (op1 := op)) or (op1 := memq(op,ops)))]
+ for [op,:u] in opAlist] where
+ memq(op,ops) == --dirty trick to get 0 and 1 instead of Zero and One
+ MEMQ(op,ops) => op
+ EQ(op,'One) => MEMQ(1,ops) and 1
+ EQ(op,'Zero) => MEMQ(0,ops) and 0
+ false
+ fn ==
+ sig1 := sublisFormal(rest domname,sig)
+ predValue := evalDomainOpPred(dom,pred)
+ info :=
+ null predValue =>
+ 1 -- signifies not exported
+ null fromIfTrue => nil
+ cell := compiledLookup(op,sig1,dom) =>
+ [f,:r] := cell
+ f = 'nowhere => 'nowhere --see replaceGoGetSlot
+ f = 'makeSpadConstant => 'constant
+ f = function IDENTITY => 'constant
+ f = 'newGoGet => SUBST('_$,domname,devaluate CAR r)
+ null VECP r => systemError devaluateList r
+ SUBST('_$,domname,devaluate r)
+ 'nowhere
+ [sig1,:info]
+
+evalDomainOpPred(dom,pred) == process(dom,pred) where
+ process(dom,pred) ==
+ u := convert(dom,pred)
+ u = 'T => true
+ evpred(dom,u)
+ convert(dom,pred) ==
+ pred is [op,:argl] =>
+ MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]]
+ MEMQ(op,'(OR or)) => ['OR,:[convert(dom,x) for x in argl]]
+ MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)]
+ op = 'has =>
+ [arg,p] := argl
+ p is ['ATTRIBUTE,a] => ['HasAttribute,arg,MKQ a]
+ ['HasCategory,arg,convertCatArg p]
+ systemError '"unknown predicate form"
+ pred = 'T => true
+ systemError nil
+ convertCatArg p ==
+ atom p or #p = 1 => MKQ p
+ ['LIST,MKQ first p,:[convertCatArg x for x in rest p]]
+ evpred(dom,pred) ==
+ k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1)
+ evpred1(dom,pred)
+ evpred1(dom,pred) ==
+ pred is [op,:argl] =>
+ MEMQ(op,'(AND and)) => "and"/[evpred1(dom,x) for x in argl]
+ MEMQ(op,'(OR or)) => "or"/[evpred1(dom,x) for x in argl]
+ op = 'NOT => not evpred1(dom,first argl)
+ k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1)
+ op = 'HasAttribute =>
+ [arg,[.,a]] := argl
+ attPredIndex := LASSOC(a,dom.2)
+ null attPredIndex => nil
+ attPredIndex = 0 => true
+ testBitVector(dom.3,attPredIndex)
+ nil
+ pred = 'T => true
+ systemError '"unknown atomic predicate form"
+
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}