login  home  contents  what's new  discussion  bug reports     help  links  subscribe  changes  refresh  edit

Edit detail for SandBoxDomainConstructor revision 4 of 1

4
Editor: Bill Page
Time: 2011/12/09 17:09:15 GMT-8
Note: |hahah|

changed:
-
\begin{axiom}
)set output tex off
)set output algebra on
\end{axiom}

First, fix a problem with as.boot. Unknown function BOOT::|hahah|

\begin{boot}
)package "BOOT"

--global hash tables for new compiler
$docHash  := MAKE_-HASH_-TABLE()
$conHash  := MAKE_-HASH_-TABLE()
$opHash   := MAKE_-HASH_-TABLE()
$asyPrint := false

asList() ==
  OBEY '"rm -f temp.text"
  OBEY '"ls as/*.asy > temp.text"
  instream := OPEN '"temp.text"
  lines := [READLINE instream while not EOFP instream]
  CLOSE instream
  lines

astran asyFile ==
--global hash tables for new compiler
  $docHash  := MAKE_-HASH_-TABLE()
  $conHash := MAKE_-HASH_-TABLE()
  $constantHash := MAKE_-HASH_-TABLE()
  $niladics : local := nil
  $asyFile: local := asyFile
  $asFilename: local := STRCONC(PATHNAME_-NAME asyFile,'".as")
  asytran asyFile
  conlist := [x for x in HKEYS $conHash | HGET($conHash,x) isnt [.,.,"function",:.]]
  $mmAlist : local :=
    [[con,:asyConstructorModemap con] for con in conlist]
  $docAlist : local :=
    [[con,:REMDUP asyDocumentation con] for con in conlist]
  $parentsHash : local := MAKE_-HASH_-TABLE()
--$childrenHash: local := MAKE_-HASH_-TABLE()
  for con in conlist repeat
    parents := asyParents con
    HPUT($parentsHash,con,asyParents con)
--  for [parent,:pred] in parents repeat
--    parentOp := opOf parent
--    HPUT($childrenHash,parentOp,insert([con,:pred],HGET($childrenHash,parentOp)))
  $newConlist := union(conlist, $newConlist)
  [[x,:asMakeAlist x] for x in HKEYS $conHash]

asyParents(conform) ==
  acc := nil
  con:= opOf conform
--formals := TAKE(#formalParams,$TriangleVariableList)
  modemap := LASSOC(con,$mmAlist)
  $constructorCategory :local := asySubstMapping CADAR modemap
  for x in folks $constructorCategory repeat
--  x := SUBLISLIS(formalParams,formals,x)
--  x := SUBLISLIS(IFCDR conform,formalParams,x)
    acc := [:explodeIfs x,:acc]
  NREVERSE acc

asySubstMapping u ==
  u is [op,:r] =>
    op = "->" =>
       [s, t] := r
       args :=
          s is [op,:u] and asyComma? op => [asySubstMapping y for y in u]
          [asySubstMapping s]
       ['Mapping, asySubstMapping t, :args]
    [asySubstMapping x for x in u]
  u

asyMkSignature(con,sig) ==
--  atom sig => ['TYPE,con,sig]
-- following line converts constants into nullary functions
  atom sig => ['SIGNATURE,con,[sig]]
  ['SIGNATURE,con,sig]

asMakeAlist con ==
  record := HGET($conHash,con)
  [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record
--TTT in case we put the wrong thing in for niladic catgrs
--if ATOM(form) and kind='category then form:=[form]
  if ATOM(form) then form:=[form]
  kind = 'function => asMakeAlistForFunction con
  abb := asyAbbreviation(con,#(KDR sig))
  if null KDR form then PUT(opOf form,'NILADIC,'T)
  modemap := asySubstMapping LASSOC(con,$mmAlist)
  $constructorCategory :local := CADAR modemap
  parents := mySort HGET($parentsHash,con)
--children:= mySort HGET($childrenHash,con)
  alists  := HGET($opHash,con)
  opAlist := SUBLISLIS($FormalMapVariableList,KDR form,CDDR alists)
  ancestorAlist:= SUBLISLIS($FormalMapVariableList,KDR form,CAR alists)
  catAttrs := [[x,:true] for x in getAttributesFromCATEGORY $constructorCategory]
  attributeAlist := REMDUP [:CADR alists,:catAttrs]
  documentation :=
    SUBLISLIS($FormalMapVariableList,KDR form,LASSOC(con,$docAlist))
  filestring := STRCONC(PATHNAME_-NAME STRINGIMAGE filename,'".as")
  constantPart := HGET($constantHash,con) and [['constant,:true]]
  niladicPart := MEMQ(con,$niladics) and [['NILADIC,:true]]
  falist :=  TAKE(#KDR form,$FormalMapVariableList)
  constructorCategory :=
    kind = 'category =>
      talist := TAKE(#KDR form, $TriangleVariableList)
      SUBLISLIS(talist, falist, $constructorCategory)
    SUBLISLIS(falist,KDR form,$constructorCategory)
  if constructorCategory='Category then kind := 'category
  exportAlist := asGetExports(kind, form, constructorCategory)
  constructorModemap  := SUBLISLIS(falist,KDR form,modemap)
--TTT fix a niladic category constructormodemap (remove the joins)
  if kind = 'category then
     SETF(CADAR(constructorModemap),['Category])
  res := [['constructorForm,:form],:constantPart,:niladicPart,
           ['constructorKind,:kind],
             ['constructorModemap,:constructorModemap],
              ['abbreviation,:abb],
               ['constructorCategory,:constructorCategory],
                ['parents,:parents],
                 ['attributes,:attributeAlist],
                  ['ancestors,:ancestorAlist],
                   --                ['children,:children],
                   ['sourceFile,:filestring],
                    ['operationAlist,:zeroOneConversion opAlist],
                     ['modemaps,:asGetModemaps(exportAlist,form,kind,modemap)],
                       ['sourcefile,:$asFilename],
                         ['typeCode,:typeCode],
                          ['documentation,:documentation]]
  if $asyPrint then asyDisplay(con,res)
  res

asGetExports(kind, conform, catform) ==
  u := asCategoryParts(kind, conform, catform, true) or return nil
  -- ensure that signatures are lists
  [[op, sigpred] for [op,sig,:pred] in CDDR u] where
    sigpred ==
      pred :=
        pred = "T" => nil
        pred
      [sig, nil, :pred]

asMakeAlistForFunction fn ==
  record := HGET($conHash,fn)
  [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record
  modemap := LASSOC(fn,$mmAlist)
  newsig := asySignature(sig,nil)
  opAlist := [[fn,[newsig,nil,:predlist]]]
  res := [['modemaps,:asGetModemaps(opAlist,fn,'function,modemap)],
            ['typeCode,:typeCode]]
  if $asyPrint then asyDisplay(fn,res)
  res

getAttributesFromCATEGORY catform ==
  catform is ['CATEGORY,.,:r] => [y for x in r | x is ['ATTRIBUTE,y]]
  catform is ['Join,:m,x]     => getAttributesFromCATEGORY x
  nil

displayDatabase x == main where
  main ==
    for y in
     '(CONSTRUCTORFORM CONSTRUCTORKIND _
       CONSTRUCTORMODEMAP _
       ABBREVIATION _
       CONSTRUCTORCATEGORY _
       PARENTS _
       ANCESTORS _
       SOURCEFILE _
       OPERATIONALIST _
       MODEMAPS _
       SOURCEFILE _
       DOCUMENTATION) repeat fn(x,y)
  fn(x,y) ==
    sayBrightly ['"----------------- ",y,'" --------------------"]
    pp GETDATABASE(x,y)

-- For some reason Dick has modified as.boot to convert the
-- identifier |0| or |1| to an integer in the list of operations.
-- This is WRONG, all existing code assumes that operation names
-- are always identifiers not numbers.
-- This function breaks the ability of the interpreter to find
-- |0| or |1| as exports of new compiler domains.
-- Unless someone has a strong reason for keeping the change,
-- this function should be no-opped, i.e.
-- zeroOneConversion opAlist == opAlist
-- If this change is made, then we are able to find asharp constants again.
--   bmt Mar 26, 1994  and executed by rss

zeroOneConversion opAlist == opAlist
--   for u in opAlist repeat
--     [op,:.] := u
--     DIGITP (PNAME op).0 => RPLACA(u, string2Integer PNAME op)
--   opAlist

asyDisplay(con,alist) ==
  banner := '"=============================="
  sayBrightly [banner,'" ",con,'" ",banner]
  for [prop,:value] in alist repeat
    sayBrightlyNT [prop,'": "]
    pp value

asGetModemaps(opAlist,oform,kind,modemap) ==
  acc:= nil
  rpvl:=
    MEMQ(kind, '(category function)) => rest $PatternVariableList -- *1 is special for $
    $PatternVariableList
  form := [opOf oform,:[y for x in KDR oform for y in rpvl]]
  dc :=
    MEMQ(kind, '(category function)) => "*1"
    form
  pred1 :=
    kind = 'category => [["*1",form]]
    nil
  signature  := CDAR modemap
  domainList :=
    [[a,m] for a in rest form for m in rest signature |
       asIsCategoryForm m]
  catPredList:=
    kind = 'function => [["isFreeFunction","*1",opOf form]]
    [['ofCategory,:u] for u in [:pred1,:domainList]]
--  for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat
--  the code seems to oscillate between generating $FormalMapVariableList
--  and generating $TriangleVariableList
  for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat
    for [sig0, pred] in itemlist repeat
      sig := SUBST(dc,"$",sig0)
      pred:= SUBST(dc,"$",pred)
      sig := SUBLISLIS(rpvl,KDR oform,sig)
      pred:= SUBLISLIS(rpvl,KDR oform,pred)
      pred := pred or 'T
  ----------> Constants change <--------------
      if IDENTP sig0 then
          sig := [sig]
          pred := MKPF([pred,'(isAsConstant)],'AND)
      pred' := MKPF([pred,:catPredList],'AND)
      mm := [[dc,:sig],[pred']]
      acc := [[op,:interactiveModemapForm mm],:acc]
  NREVERSE acc

asIsCategoryForm m ==
  m = 'BasicType or GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'category

asyDocumentation con ==
  docHash := HGET($docHash,con)
  u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash
           | rec := HGET(docHash,op)] where fn(x,op) ==
    [form,sig,pred,origin,where?,comments,:.] := x
    ----------> Constants change <--------------
    if IDENTP sig then sig := [sig]
    [asySignature(sig,nil),trimComments comments]
  [form,sig,pred,origin,where?,comments] := first HGET($conHash,con)
  --above "first" assumes only one entry
  comments := trimComments asyExtractDescription comments
  [:u,['constructor,[nil,comments]]]

asyExtractDescription str ==
  k := STRPOS('"Description:",str,0,nil) => asyExtractDescription SUBSTRING(str,k + 12,nil)
  k := STRPOS('"Author:",str,0,nil) => asyExtractDescription SUBSTRING(str,0,k)
  str

trimComments str ==
  null str or str = '"" => '""
  m := MAXINDEX str
  str := SUBSTRING(str,0,m)
  trimString str

asyExportAlist con ==
--format of 'operationAlist property of LISPLIBS (as returned from koOps):
--    <sig slotNumberOrNil optPred optELT>
--    <sig sig'            predOrT "Subsumed">
--!!! asyFile NEED: need to know if function is implemented by domain!!!
  docHash := HGET($docHash,con)
  [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)]
       where fn(x,op) ==
    [form,sig,pred,origin,where?,comments,:.] := x
    tail :=
      pred => [pred]
      nil
    newSig := asySignature(sig,nil)
    [newSig,nil,:tail]

asyMakeOperationAlist(con,proplist, key) ==
  oplist :=
    u := LASSOC('domExports,proplist) =>
      kind := 'domain
      u
    u := LASSOC('catExports,proplist) =>
      kind := 'category
      u
    key = 'domain =>
      kind := 'domain
      u := NIL
    return nil
  ht := MAKE_-HASH_-TABLE()
  ancestorAlist := nil
  for ['Declare,id,form,r] in oplist repeat
    id = "%%" =>
      opOf form = con => nil
      y := asyAncestors form
      if opOf(y)~=con then ancestorAlist := [ [y,:true],:ancestorAlist]
    idForm   :=
      form is ['Apply,'_-_>,source,target] => [id,:asyArgs source]
  ----------> Constants change <--------------
      id
    pred :=
      LASSOC('condition,r) is p => hackToRemoveAnd p
      nil
    sig := asySignature(asytranForm(form,[idForm],nil),nil)
    entry :=
      --id ~= "%%" and IDENTP idForm => [[sig],nil,nil,'ASCONST]
      id ~= "%%" and IDENTP idForm =>
          pred => [[sig],nil,asyPredTran pred,'ASCONST]
          [[sig],nil,true,'ASCONST]
      pred => [sig,nil,asyPredTran pred]
      [sig]
    HPUT(ht,id,[entry,:HGET(ht,id)])
  opalist := [[op,:REMDUP HGET(ht,op)] for op in HKEYS ht]
  HPUT($opHash,con,[ancestorAlist,nil,:opalist])

hackToRemoveAnd p ==
---remove this as soon as .asy files do not contain forms (And pred) forms
  p is ['And,q,:r] =>
    r => ['AND,q,:r]
    q
  p

asyAncestors x ==
  x is ['Apply,:r] => asyAncestorList r
  x is [op,y,:.] and MEMQ(op, '(PretendTo RestrictTo)) => asyAncestors y
  atom x =>
    x = '_% => '_$
    MEMQ(x, $niladics)       => [x]
    GETDATABASE(x ,'NILADIC) => [x]
    x
  asyAncestorList x

asyAncestorList x == [asyAncestors y for y in x]
--============================================================================
--       Build Operation Alist from sig
--============================================================================

--format of operations as returned from koOps
--    <sig pred pakOriginOrNil TifPakExposedOrNil>
--    <sig pred origin         exposed?>

--abb,kind,file,sourcefile,coSig,dbLineNumber,constructorArgs,libfile
--((sig  where(NIL or #)  condition(T or pred)  ELTorSubsumed) ...
--expanded lists are: sig, predicate, origin, exposeFlag, comments

--============================================================================
--       Building Hash Tables for Operations/Constructors
--============================================================================
asytran fn ==
--put operations into table format for browser:
--    <sig pred origin         exposed? comments>
  inStream := OPEN fn
  sayBrightly ['"   Reading ",fn]
  u := VMREAD inStream
  $niladics := mkNiladics u
  for x in $niladics repeat PUT(x,'NILADIC,true)
  for d in u repeat
    ['Declare,name,:.] := d
    name = "%%" => 'skip       --skip over top-level properties
    $docHashLocal: local := MAKE_-HASH_-TABLE()
    asytranDeclaration(d,'(top),nil,false)
    if null name then hohohoho()
    HPUT($docHash,name,$docHashLocal)
  CLOSE inStream
  'done

mkNiladics u ==
  [name for x in u | x is ['Declare,name,y,:.] and y isnt ['Apply,'_-_>,:.]]

asytranDeclaration(dform,levels,predlist,local?) ==
  ['Declare,id,form,r] := dform
  id = 'failed => id
  KAR dform ~= 'Declare => systemError '"asytranDeclaration"
  if levels = '(top) then
    if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true)
  comments := LASSOC('documentation,r) or '""
  idForm   :=
    levels is ['top,:.] =>
      form is ['Apply,'_-_>,source,target] => [id,:asyArgs source]
      id
  ----------> Constants change <--------------
    id
  newsig  := asytranForm(form,[idForm,:levels],local?)
  key :=
    levels is ['top,:.] =>
      MEMQ(id,'(%% Category Type)) => 'constant
      asyLooksLikeCatForm? form => 'category
      form is ['Apply, '_-_>,.,u] =>
        if u is ['Apply, construc,:.] then u:= construc
        GETDATABASE(opOf u,'CONSTRUCTORKIND) = 'domain  => 'function
        asyLooksLikeCatForm? u => 'category
        'domain
      'domain
    first levels
  typeCode := LASSOC('symeTypeCode,r)
  record := [idForm,newsig,asyMkpred predlist,key,true,comments,typeCode,:$asyFile]
  if not local? then
    ht :=
      levels = '(top) => $conHash
      $docHashLocal
    HPUT(ht,id,[record,:HGET(ht,id)])
  if levels = '(top) then asyMakeOperationAlist(id,r, key)
  ['Declare,id,newsig,r]

asyLooksLikeCatForm? x ==
--TTT don't see a Third in my version ....
  x is ['Define, ['Declare, ., ['Apply, 'Third,:.],:.],:.] or
   x is ['Define, ['Declare, ., 'Category ],:.]

asyIsCatForm form ==
  form is ['Apply,:r] =>
    r is ['_-_>,.,a] => asyIsCatForm a
    r is ['Third,'Type,:.] => true
    false
  false

asyArgs source ==
  args :=
    source is [op,:u] and asyComma? op => u
    [source]
  [asyArg x for x in args]

asyArg x ==
  x is ['Declare,id,:.] => id
  x

asyMkpred predlist ==
  null predlist => nil
  predlist is [p] => p
  ['AND,:predlist]

asytranForm(form,levels,local?) ==
  u := asytranForm1(form,levels,local?)
  sayBrightly ['"form = ",form,'" "]
  null u =>
    sayBrightly ['"hahah"]
  u

asytranForm1(form,levels,local?) ==
  form is ['With,left,cat] =>
--  left ~= nil       => error '"WITH cannot take a left argument yet"
    asytranCategory(form,levels,nil,local?)
  form is ['Apply,:.]   => asytranApply(form,levels,local?)
  form is ['Declare,:.] => asytranDeclaration(form,levels,nil,local?)
  form is ['Comma,:r]  => ['Comma,:[asytranForm(x,levels,local?) for x in r]]
--form is ['_-_>,:s] => asytranMapping(s,levels,local?)
  form is [op,a,b] and MEMQ(a,'(PretendTo RestrictTo)) =>
    asytranForm1(a,levels,local?)
  form is ['LitInteger,s] =>
        READ_-FROM_-STRING(s)
  form is ['Define,:.]  =>
    form is ['Define,['Declare,.,x,:.],rest] =>
--TTT i don't know about this one but looks ok
      x = 'Category => asytranForm1(rest,levels, local?)
      asytranForm1(x,levels,local?)
    error '"DEFINE forms are not handled yet"
  if form = '_% then $hasPerCent := true
  IDENTP form =>
    form = "%" => "$"
    GETL(form,'NILADIC) => [form]
    form
  [asytranForm(x,levels,local?) for x in form]

asytranApply(['Apply,name,:arglist],levels,local?) ==
  MEMQ(name,'(Record Union)) =>
    [name,:[asytranApplySpecial(x, levels, local?) for x in arglist]]
  null arglist => [name]
  name is [ 'RestrictTo, :.] =>
    asytranApply(['Apply, CAR CDR name,:arglist], levels, local?)
  name is [ 'Qualify, :.] =>
    asytranApply(['Apply, CAR CDR name,:arglist], levels, local?)
  name is 'string => asytranLiteral CAR arglist
  name is 'integer => asytranLiteral CAR arglist
  name is 'float => asytranLiteral CAR arglist
  name = 'Enumeration =>
    ["Enumeration",:[asytranEnumItem arg for arg in arglist]]
  [:argl,lastArg] := arglist
  [name,:[asytranFormSpecial(arg,levels,true) for arg in argl],
          asytranFormSpecial(lastArg,levels,false)]

asytranLiteral(lit) ==
  CAR CDR lit

asytranEnumItem arg ==
  arg is ['Declare, name, :.] => name
  error '"Bad Enumeration entry"

asytranApplySpecial(x, levels, local?) ==
  x is ['Declare, name, typ, :.] => [":",name,asytranForm(typ, levels, local?)]
  asytranForm(x, levels, local?)

asytranFormSpecial(x, levels, local?) ==  --> this throws away variable name (revise later)
  x is ['Declare, name, typ, :.] => asytranForm(typ, levels, local?)
  asytranForm(x, levels, local?)

asytranCategory(form,levels,predlist,local?) ==
  cat :=
    form is ['With,left,right] =>
      right is ['Blank,:.] => ['Sequence]
      right
    form
  left :=
    form is ['With,left,right] =>
      left is ['Blank,:.] => nil
      left
    nil
  $hasPerCent: local := nil
  items :=
    cat is ['Sequence,:s] => s
    [cat]
  catTable := MAKE_-HASH_-TABLE()
  catList  := nil
  for x in items | x repeat
    if null x then systemError()
    dform := asytranCategoryItem(x,levels,predlist,local?)
    null dform => nil
    dform is ['Declare,id,record,r] =>
      HPUT(catTable,id,[asyWrap(record,predlist),:HGET(catTable,id)])
    catList := [asyWrap(dform,predlist),:catList]
  keys := listSort(function GLESSEQP,HKEYS catTable)
  right1 := NREVERSE catList
  right2 := [[key,:HGET(catTable,key)] for key in keys]
  right :=
    right2 => [:right1,['Exports,:right2]]
    right1
  res :=
    left => [left,:right]
    right
  res is [x] and x is ['IF,:.] => x
  ['With,:res]

asyWrap(record,predlist) ==
  predlist => ['IF,MKPF(predlist,'AND),record]
  record

asytranCategoryItem(x,levels,predlist,local?) ==
  x is ['If,predicate,item,:r] =>
    IFCAR r => error '"ELSE expressions not allowed yet in conditionals"
    pred :=
      predicate is ['Test,r] => r
      predicate
    asytranCategory(item,levels,[pred,:predlist],local?)
  MEMQ(KAR x,'(Default Foreign)) => nil
  x is ['Declare,:.] => asytranDeclaration(x,levels,predlist,local?)
  x

--============================================================================
--          Extending Constructor Datatable
--============================================================================
--FORMAT of $constructorDataTable entry:
--abb kind libFile sourceFile coSig constructorArgs
--alist is ((kind . domain) (libFile . MATRIX) (sourceFile . "matrix")
--         (coSig NIL T) (dbLineNumber . 29187) (constructorArgs R)
--  (modemap . (
--    (|Matrix| |#1|)
--      (Join (MatrixCategory #1 (Vector #1) (Vector #1))
--        (CATEGORY domain
--          (SIGNATURE diagonalMatrix ($ (Vector #1)))
--          (IF (has #1 (Field))
--            (SIGNATURE inverse ((Union $ "failed") $)) noBranch)))
--      (Ring))
--    (T Matrix))   )
extendConstructorDataTable() ==
--  tb := $constructorDataTable
  for x in listSort(function GLESSEQP,HKEYS $conHash) repeat
--     if LASSOC(x,tb) then tb := DELLASOS(x,tb)
     record := HGET($conHash,x)
     [form,sig,predlist,origin,exposure,comments,typeCode,:filename] := first record
     abb := asyAbbreviation(x,#(rest sig))
     kind := 'domain
     --Note: this "first" assumes that there is ONLY one sig per name
     cosig := [nil,:asyCosig sig]
     args  := asyConstructorArgs sig
     tb :=
       [[x,abb,
          ['kind,:kind],
            ['cosig,:cosig],
              ['libfile,filename],
                ['sourceFile,STRINGIMAGE filename],
                  ['constructorArgs,:args]],:tb]
  listSort(function GLESSEQP,ASSOCLEFT tb)

asyConstructorArgs sig ==
  sig is ['With,:.] => nil
  sig is ['_-_>,source,target] =>
    source is [op,:argl] and asyComma? op => [asyConstructorArg x for x in argl]
    [asyConstructorArg source]

asyConstructorArg x ==
  x is ['Declare,name,t,:.] => name
  x

asyCosig sig ==    --can be a type or could be a signature
  atom sig or sig is ['With,:.] => nil
  sig is ['_-_>,source,target] =>
    source is [op,:argl] and asyComma? op => [asyCosigType x for x in argl]
    [asyCosigType source]
  error false

asyCosigType u ==
  u is [name,t] =>
    t is [fn,:.] =>
      asyComma? fn => fn
      fn = 'With  => 'T
      nil
    t = 'Type => 'T
    error '"Unknown atomic type"
  error false

asyAbbreviation(id,n) ==  chk(id,main) where   --> n = number of arguments
  main ==
    a := createAbbreviation id => a
    name := PNAME id
--  #name < 8 => INTERN UPCASE name
    parts := asySplit(name,MAXINDEX name)
    newname := "STRCONC"/[asyShorten x for x in parts]
    #newname < 8 => INTERN newname
    tryname := SUBSTRING(name,0,7)
    not createAbbreviation tryname => INTERN UPCASE tryname
    nil
  chk(conname,abb) ==
    (xx := asyGetAbbrevFromComments conname) => xx
    con := abbreviation? abb =>
      conname = con => abb
      conname
    abb

asyGetAbbrevFromComments con ==
  docHash := HGET($docHash,con)
  u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash
           | rec := HGET(docHash,op)] where fn(x,op) ==
    [form,sig,pred,origin,where?,comments,:.] := x
    ----------> Constants change <--------------
    if IDENTP sig then sig := [sig]
    [asySignature(sig,nil),trimComments comments]
  [form,sig,pred,origin,where?,comments] := first HGET($conHash,con)
  --above "first" assumes only one entry
  x := asyExtractAbbreviation comments
  x => intern x
  NIL

asyExtractAbbreviation str ==
        not (k:= STRPOS('"Abbrev: ",str,0,nil)) => NIL
        str := SUBSTRING(str, k+8, nil)
        k := STRPOS($stringNewline, str,0,nil)
        k => SUBSTRING(str, 0, k)
        str

asyShorten x ==
  y := createAbbreviation x
    or LASSOC(x,
        '(("Small" . "SM") ("Single" ."S") ("Half" . "H")("Point" . "PT")
            ("Floating" . "F") ("System" . "SYS") ("Number" . "N")
             ("Inventor" . "IV")
              ("Finite" . "F") ("Double" . "D") ("Builtin" . "BI"))) => y
  UPCASE x

asySplit(name,end) ==
  end < 1 => [name]
  k := 0
  for i in 1..end while LOWER_-CASE_-P name.i repeat k := i
  k := k + 1
  [SUBSTRING(name,0,k),:asySplit(SUBSTRING(name,k,nil),end-k)]

createAbbreviation s ==
  if STRINGP s then s := INTERN s
  a := constructor? s
  a ~= s => a
  nil

--============================================================================
--       extending getConstructorModemap Property
--============================================================================
--Note: modemap property is built when getConstructorModemap is called

asyConstructorModemap con ==
  HGET($conHash,con) isnt [record,:.] => nil   --not there
  [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := record
  $kind: local := kind
  --NOTE: sig has the form (-> source target) or simply (target)
  $constructorArgs: local := KDR form
  signature := asySignature(sig,false)
  formals := ['_$,:TAKE(#$constructorArgs,$FormalMapVariableList)]
  mm := [[[con,:$constructorArgs],:signature],['T,con]]
  SUBLISLIS(formals,['_%,:$constructorArgs],mm)

asySignature(sig,names?) ==
  sig is ['Join,:.] => [asySig(sig,nil)]
  sig is ['With,:.] => [asySig(sig,nil)]
  sig is ['_-_>,source,target] =>
    target :=
      names? => ['dummy,target]
      target
    source is [op,:argl] and asyComma? op =>
      [asySigTarget(target,names?),:[asySig(x,names?) for x in argl]]
    [asySigTarget(target,names?),asySig(source,names?)]
  ----------> The following is a hack for constants which are category names<--
  sig is ['Third,:.] => [asySig(sig,nil)]
  ----------> Constants change <--------------
  asySig(sig,nil)

asySigTarget(u,name?) == asySig1(u,name?,true)

asySig(u,name?) == asySig1(u,name?,false)

asySig1(u,name?,target?) ==
  x :=
    name? and u is [name,t] => t
    u
  x is [fn,:r] =>
    fn = 'Join => asyTypeJoin r       ---------> jump out to newer code 4/94
    MEMQ(fn, '(RestrictTo PretendTo)) => asySig(first r,name?)
    asyComma? fn =>
      u := [asySig(x,name?) for x in r]
      target? =>
        null u => '(Void)
        -- this implies a multiple value return, not currently supported
        -- in the interpreter
        ['Multi,:u]
      u
    fn = 'With  => asyCATEGORY r
    fn = 'Third =>
      r is [b] =>
        b is ['With,:s]  => asyCATEGORY s
        b is ['Blank,:.] => asyCATEGORY nil
      error x
    fn = 'Apply and r is ['_-_>,:s] => asyMapping(s,name?)
    fn = '_-_> => asyMapping(r,name?)
    fn = 'Declare and r is [name,typ,:.] =>
        asySig1(typ, name?, target?)
    x is '(_%) => '(_$)
    [fn,:[asySig(x,name?) for x in r]]
--x = 'Type => '(Type)
  x = '_% => '_$
  x

asyMapping([a,b],name?) ==
  newa := asySig(a,name?)
  b    := asySig(b,name?)
  args :=
    a is [op,:r] and asyComma? op => newa
    [a]
  ['Mapping,b,:args]

--============================================================================
--       code for asySignatures of the form (Join,:...)
--============================================================================
asyType x ==
  x is [fn,:r] =>
    fn = 'Join => asyTypeJoin r
    MEMQ(fn, '(RestrictTo PretendTo)) => asyType first r
    asyComma? fn =>
      u := [asyType x for x in r]
      u
    fn = 'With  => asyCATEGORY r
    fn = '_-_> => asyTypeMapping r
    fn = 'Apply => r
--  fn = 'Declare and r is [name,typ,:.] => typ
    x is '(_%) => '(_$)
    x
--x = 'Type => '(Type)
  x = '_% => '_$
  x

asyTypeJoin r ==
  $conStack : local := nil
  $opStack  : local := nil
  $predlist : local := nil
  for x in r repeat asyTypeJoinPart(x,$predlist)
  catpart :=
    $opStack => ['CATEGORY,$kind,:asyTypeJoinStack REVERSE $opStack]
    nil
  conpart := asyTypeJoinStack REVERSE $conStack
  conpart =>
    catpart     => ['Join,:conpart,catpart]
    CDR conpart => ['Join,:conpart]
    conpart
  catpart

asyTypeJoinPart(x,$predlist) ==
  x is ['Join,:y] => for z in y repeat asyTypeJoinPart(z, $predlist)
  x is ['With,:y] => for p in y repeat asyTypeJoinPartWith p
  asyTypeJoinPartWith x

asyTypeJoinPartWith x ==
  x is ['Exports,:y] => for p in y repeat asyTypeJoinPartExport p
  x is ['Exports,:.] => systemError 'exports
  x is ['Comma]  => nil
  x is ['Export,:y]  => nil
  x is ['IF,:r] => asyTypeJoinPartIf r
  x is ['Sequence,:x] => for y in x repeat asyTypeJoinItem y
  asyTypeJoinItem x

asyTypeJoinPartIf [pred,value] ==
  predlist := [asyTypeJoinPartPred pred,:$predlist]
  asyTypeJoinPart(value,predlist)

asyTypeJoinPartPred x ==
  x is ['Test, y] => asyTypeUnit y
  asyTypeUnit x

asyTypeJoinItem x ==
  result := asyTypeUnit x
  isLowerCaseLetter (PNAME opOf result).0 =>
    $opStack := [[['ATTRIBUTE,result],:$predlist],:$opStack]
  $conStack := [[result,:$predlist],:$conStack]

asyTypeMapping([a,b]) ==
  a := asyTypeUnit a
  b := asyTypeUnit b
  args :=
    a is [op,:r] and asyComma? op => r
    [a]
  ['Mapping,b,:args]

asyTypeUnit x ==
  x is [fn,:r] =>
    fn = 'Join => systemError 'Join ----->asyTypeJoin r
    MEMQ(fn, '(RestrictTo PretendTo)) => asyTypeUnit first r
    asyComma? fn =>
      u := [asyTypeUnit x for x in r]
      u
    fn = 'With  => asyCATEGORY r
    fn = '_-_> => asyTypeMapping r
    fn = 'Apply => asyTypeUnitList r
    fn = 'Declare and r is [name,typ,:.] => asyTypeUnitDeclare(name,typ)
    x is '(_%) => '(_$)
    [fn,:asyTypeUnitList r]
  GETL(x,'NILADIC) => [x]
--x = 'Type => '(Type)
  x = '_% => '_$
  x

asyTypeUnitList x == [asyTypeUnit y for y in x]

asyTypeUnitDeclare(op,typ) ==
  typ is ['Apply, :r] => asyCatSignature(op,r)
  asyTypeUnit typ
--============================================================================
--               Translator for ['With,:.]
--============================================================================
asyCATEGORY x ==
  if x is [join,:y] and join is ['Apply,:s] then
    exports := y
    joins :=
      s is ['Join,:r] => [asyJoinPart u for u in r]
      [asyJoinPart s]
  else if x is [id,:y] and IDENTP id then
    joins := [[id]]
    exports := y
  else
    joins   := nil
    exports := x
  cats       := exports
  operations := nil
  if exports is [:r,['Exports,:ops]] then
    cats := r
    operations := ops
  exportPart :=
    ['CATEGORY,'domain,:"APPEND"/[asyCatItem y for y in operations]]
  cats := "append"/[asyCattran c for c in cats]
  joins or cats =>
    ['Join,:joins,:cats, exportPart]
  exportPart

simpCattran x ==
  u := asyCattran x
  u is [y] => y
  ['Join,:u]

asyCattran x ==
  x is ['With,:r] => "append"/[asyCattran1 x for x in r]
  x is ['IF,:.]   => "append"/[asyCattranConstructors(x,nil)]
  [x]

asyCattran1 x ==
  x is ['Exports,:y] => "append"/[asyCattranOp u for u in y]
  x is ['IF,:.]      => "append"/[asyCattranConstructors(x,nil)]
  systemError nil

asyCattranOp [op,:items] ==
  "append"/[asyCattranOp1(op,item,nil) for item in items]

asyCattranOp1(op, item, predlist) ==
  item is ['IF, p, x] =>
    pred := asyPredTran
      p is ['Test,t] => t
      p
--    x is ['IF,:.] => "append"/[asyCattranOp1('IF, x, [pred,:predlist])]
--  This line used to call asyCattranOp1 with too few arguments.  Following
--  fix suggested by RDJ.
    x is ['IF,:.] => "append"/[asyCattranOp1(op,y,[pred,:predlist]) for y in x]
    [['IF, asySimpPred(pred,predlist), asyCattranSig(op,x), 'noBranch]]
  [asyCattranSig(op,item)]

asyPredTran p == asyPredTran1 asyJoinPart p

asyPredTran1 p ==
  p is ['Has,x,y] => ['has,x, simpCattran y]
  p is ['Test, q] => asyPredTran1 q
  p is [op,:r] and MEMQ(op,'(AND OR NOT)) =>
    [op,:[asyPredTran1 q for q in r]]
  p

asyCattranConstructors(item, predlist) ==
  item is ['IF, p, x] =>
    pred := asyPredTran
      p is ['Test,t] => t
      p
    x is ['IF,:.] => "append"/[asyCattranConstructors(x, [pred,:predlist])]
    form := ['ATTRIBUTE, asyJoinPart x]
    [['IF, asySimpPred(pred,predlist), form, 'noBranch]]
  systemError()

asySimpPred(p, predlist) ==
  while predlist is [q,:predlist] repeat p := quickAnd(q,p)
  p

asyCattranSig(op,y) ==
  y isnt ["->",source,t] =>
-- following makes constants into nullary functions
     ['SIGNATURE, op, [asyTypeUnit y]]
  s :=
    source is ['Comma,:s] => [asyTypeUnit z for z in s]
    [asyTypeUnit source]
  t := asyTypeUnit t
  null t => ['SIGNATURE,op,s]
  ['SIGNATURE,op,[t,:s]]

asyJoinPart x ==
  IDENTP x => [x]
  asytranForm(x,nil,true)

asyCatItem item ==
  atom item  => [item]
  item is ['IF,.,.] => [item]
  [op,:sigs] := item
  [asyCatSignature(op,sig) for sig in sigs | sig]

asyCatSignature(op,sig) ==
  sig is ['_-_>,source,target] =>
     ['SIGNATURE,op, [asyTypeItem target,:asyUnTuple source]]
  ----------> Constants change <--------------
-- following line converts constants into nullary functions
  ['SIGNATURE,op,[asyTypeItem sig]]

asyUnTuple x ==
  x is [op,:u] and asyComma? op => [asyTypeItem y for y in u]
  [asyTypeItem x]

asyTypeItem x ==
  atom x =>
    x = '_%         => '_$
    x
  x is ['_-_>,a,b] =>
      ['Mapping,b,:asyUnTuple a]
  x is ['Apply,:r] =>
    r is ['_-_>,a,b] =>
      ['Mapping,b,:asyUnTuple a]
    r is ['Record,:parts] =>
      ['Record,:[[":",a,b] for ['Declare,a,b,:.] in parts]]
    r is ['Segment,:parts] =>
      ['Segment,:[asyTypeItem x for x in parts]]
    asytranApply(x,nil,true)
  x is ['Declare,.,t,:.] => asyTypeItem t
  x is ['Comma,:args] =>
    -- this implies a multiple value return, not currently supported
    -- in the interpreter
    args => ['Multi,:[asyTypeItem y for y in args]]
    ['Void]
  [asyTypeItem y for y in x]

--============================================================================
--               Utilities
--============================================================================
asyComma? op == MEMQ(op,'(Comma Multi))


hput(table,name,value) ==
  if null name then systemError()
  HPUT(table,name,value)

--============================================================================
--               category parts
--============================================================================

-- this constructs operation information from a category.
-- NB: This is categoryParts, but with the kind supplied by
-- an arguments
asCategoryParts(kind,conform,category,:options) == main where
  main ==
    cons? := IFCAR options  --means to include constructors as well
    $attrlist: local := nil
    $oplist  : local := nil
    $conslist: local := nil
    conname := opOf conform
    for x in exportsOf(category) repeat build(x,true)
    $attrlist := listSort(function GLESSEQP,$attrlist)
    $oplist   := listSort(function GLESSEQP,$oplist)
    res := [$attrlist,:$oplist]
    if cons? then res := [listSort(function GLESSEQP,$conslist),:res]
    if kind = 'category then
      tvl := TAKE(#rest conform,$TriangleVariableList)
      res := SUBLISLIS($FormalMapVariableList,tvl,res)
    res
  build(item,pred) ==
    item is ['SIGNATURE,op,sig,:.] => $oplist   := [[opOf op,sig,:pred],:$oplist]
    --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero)
    item is ['ATTRIBUTE,attr] =>
      constructor? opOf attr =>
        $conslist := [[attr,:pred],:$conslist]
        nil
      opOf attr = 'nothing => 'skip
      $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist]
    item is ['TYPE,op,type] =>
        $oplist := [[op,[type],:pred],:$oplist]
    item is ['IF,pred1,s1,s2] =>
      build(s1,quickAnd(pred,pred1))
      s2 => build(s2,quickAnd(pred,['NOT,pred1]))
    item is ['PROGN,:r] => for x in r repeat build(x,pred)
    item in '(noBranch) => 'ok
    null item => 'ok
    systemError '"build error"
  exportsOf(target) ==
    target is ['CATEGORY,.,:r] => r
    target is ['Join,:r,f] =>
      for x in r repeat $conslist := [[x,:true],:$conslist]
      exportsOf f
    $conslist := [[target,:true],:$conslist]
    nil

--============================================================================
--               Dead Code (for a very odd value of 'dead')
--============================================================================
asyTypeJoinPartExport x ==
  [op,:items] := x
  for y in items repeat
    y isnt ["->",source,t] =>
--       sig := ['TYPE, op, asyTypeUnit y]
-- converts constants to nullary functions (this code isn't dead)
       sig := ['SIGNATURE, op, [asyTypeUnit y]]
       $opStack := [[sig,:$predlist],:$opStack]
    s :=
      source is ['Comma,:s] => [asyTypeUnit z for z in s]
      [asyTypeUnit source]
    t := asyTypeUnit t
    sig :=
      null t => ['SIGNATURE,op,s]
      ['SIGNATURE,op,[t,:s]]
    $opStack := [[sig,:$predlist],:$opStack]

--============================================================================
--               Code to create opDead Code
--============================================================================
asyTypeJoinStack r ==
  al := [[[x while r is [[x, :q],:s] and p = q and (r := s; true)],:p]
           while r is [[.,:p],:.]]
  result := "append"/[fn for [y,:p] in al] where fn ==
    p => [['IF,asyTypeMakePred p,:y]]
    y
  result

asyTypeMakePred [p,:u] ==
  while u is [q,:u] repeat p := quickAnd(q,p)
  p
\end{boot}


\begin{aldor}
--)abbrev domain MM mm
#pile
#include "axiom"
mm(z:Integer, h:Integer->Integer): Exports == Implementation where
  Exports ==> IntegralDomain with
    if h(h(z))=h(z) then
      IntegralDomain
    if h(h(z))~=h(z) then
      fail: () -> Integer
  Implementation ==> Integer add
    if h(h(z))~=h(z) then
      fail():Integer == 0
\end{aldor}

\begin{axiom}
mask(mask(1))=mask(1)
I1 := mm(1,mask)
x1:I1 := 1
mask(mask(2))=mask(2)
I2 := mm(2,mask)
x2:I2 := fail()
\end{axiom}

axiom
)set output tex off
 
axiom
)set output algebra on

First, fix a problem with as.boot. Unknown function BOOT::|hahah|

boot
)package "BOOT"
--global hash tables for new compiler $docHash := MAKE_-HASH_-TABLE() $conHash := MAKE_-HASH_-TABLE() $opHash := MAKE_-HASH_-TABLE() $asyPrint := false
asList() == OBEY '"rm -f temp.text" OBEY '"ls as/*.asy > temp.text" instream := OPEN '"temp.text" lines := [READLINE instream while not EOFP instream] CLOSE instream lines
astran asyFile == --global hash tables for new compiler $docHash := MAKE_-HASH_-TABLE() $conHash := MAKE_-HASH_-TABLE() $constantHash := MAKE_-HASH_-TABLE() $niladics : local := nil $asyFile: local := asyFile $asFilename: local := STRCONC(PATHNAME_-NAME asyFile,'".as") asytran asyFile conlist := [x for x in HKEYS $conHash | HGET($conHash,x) isnt [.,.,"function",:.]] $mmAlist : local := [[con,:asyConstructorModemap con] for con in conlist] $docAlist : local := [[con,:REMDUP asyDocumentation con] for con in conlist] $parentsHash : local := MAKE_-HASH_-TABLE() --$childrenHash: local := MAKE_-HASH_-TABLE() for con in conlist repeat parents := asyParents con HPUT($parentsHash,con,asyParents con) -- for [parent,:pred] in parents repeat -- parentOp := opOf parent -- HPUT($childrenHash,parentOp,insert([con,:pred],HGET($childrenHash,parentOp))) $newConlist := union(conlist, $newConlist) [[x,:asMakeAlist x] for x in HKEYS $conHash]
asyParents(conform) == acc := nil con:= opOf conform --formals := TAKE(#formalParams,$TriangleVariableList) modemap := LASSOC(con,$mmAlist) $constructorCategory :local := asySubstMapping CADAR modemap for x in folks $constructorCategory repeat -- x := SUBLISLIS(formalParams,formals,x) -- x := SUBLISLIS(IFCDR conform,formalParams,x) acc := [:explodeIfs x,:acc] NREVERSE acc
asySubstMapping u == u is [op,:r] => op = "->" => [s, t] := r args := s is [op,:u] and asyComma? op => [asySubstMapping y for y in u] [asySubstMapping s] ['Mapping, asySubstMapping t, :args] [asySubstMapping x for x in u] u
asyMkSignature(con,sig) == -- atom sig => ['TYPE,con,sig] -- following line converts constants into nullary functions atom sig => ['SIGNATURE,con,[sig]] ['SIGNATURE,con,sig]
asMakeAlist con == record := HGET($conHash,con) [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record --TTT in case we put the wrong thing in for niladic catgrs --if ATOM(form) and kind='category then form:=[form] if ATOM(form) then form:=[form] kind = 'function => asMakeAlistForFunction con abb := asyAbbreviation(con,#(KDR sig)) if null KDR form then PUT(opOf form,'NILADIC,'T) modemap := asySubstMapping LASSOC(con,$mmAlist) $constructorCategory :local := CADAR modemap parents := mySort HGET($parentsHash,con) --children:= mySort HGET($childrenHash,con) alists := HGET($opHash,con) opAlist := SUBLISLIS($FormalMapVariableList,KDR form,CDDR alists) ancestorAlist:= SUBLISLIS($FormalMapVariableList,KDR form,CAR alists) catAttrs := [[x,:true] for x in getAttributesFromCATEGORY $constructorCategory] attributeAlist := REMDUP [:CADR alists,:catAttrs] documentation := SUBLISLIS($FormalMapVariableList,KDR form,LASSOC(con,$docAlist)) filestring := STRCONC(PATHNAME_-NAME STRINGIMAGE filename,'".as") constantPart := HGET($constantHash,con) and [['constant,:true]] niladicPart := MEMQ(con,$niladics) and [['NILADIC,:true]] falist := TAKE(#KDR form,$FormalMapVariableList) constructorCategory := kind = 'category => talist := TAKE(#KDR form, $TriangleVariableList) SUBLISLIS(talist, falist, $constructorCategory) SUBLISLIS(falist,KDR form,$constructorCategory) if constructorCategory='Category then kind := 'category exportAlist := asGetExports(kind, form, constructorCategory) constructorModemap := SUBLISLIS(falist,KDR form,modemap) --TTT fix a niladic category constructormodemap (remove the joins) if kind = 'category then SETF(CADAR(constructorModemap),['Category]) res := [['constructorForm,:form],:constantPart,:niladicPart, ['constructorKind,:kind], ['constructorModemap,:constructorModemap], ['abbreviation,:abb], ['constructorCategory,:constructorCategory], ['parents,:parents], ['attributes,:attributeAlist], ['ancestors,:ancestorAlist], -- ['children,:children], ['sourceFile,:filestring], ['operationAlist,:zeroOneConversion opAlist], ['modemaps,:asGetModemaps(exportAlist,form,kind,modemap)], ['sourcefile,:$asFilename], ['typeCode,:typeCode], ['documentation,:documentation]] if $asyPrint then asyDisplay(con,res) res
asGetExports(kind, conform, catform) == u := asCategoryParts(kind, conform, catform, true) or return nil -- ensure that signatures are lists [[op, sigpred] for [op,sig,:pred] in CDDR u] where sigpred == pred := pred = "T" => nil pred [sig, nil, :pred]
asMakeAlistForFunction fn == record := HGET($conHash,fn) [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := first record modemap := LASSOC(fn,$mmAlist) newsig := asySignature(sig,nil) opAlist := [[fn,[newsig,nil,:predlist]]] res := [['modemaps,:asGetModemaps(opAlist,fn,'function,modemap)], ['typeCode,:typeCode]] if $asyPrint then asyDisplay(fn,res) res
getAttributesFromCATEGORY catform == catform is ['CATEGORY,.,:r] => [y for x in r | x is ['ATTRIBUTE,y]] catform is ['Join,:m,x] => getAttributesFromCATEGORY x nil
displayDatabase x == main where main == for y in '(CONSTRUCTORFORM CONSTRUCTORKIND _ CONSTRUCTORMODEMAP _ ABBREVIATION _ CONSTRUCTORCATEGORY _ PARENTS _ ANCESTORS _ SOURCEFILE _ OPERATIONALIST _ MODEMAPS _ SOURCEFILE _ DOCUMENTATION) repeat fn(x,y) fn(x,y) == sayBrightly ['"----------------- ",y,'" --------------------"] pp GETDATABASE(x,y)
-- For some reason Dick has modified as.boot to convert the -- identifier |0| or |1| to an integer in the list of operations. -- This is WRONG, all existing code assumes that operation names -- are always identifiers not numbers. -- This function breaks the ability of the interpreter to find -- |0| or |1| as exports of new compiler domains. -- Unless someone has a strong reason for keeping the change, -- this function should be no-opped, i.e. -- zeroOneConversion opAlist == opAlist -- If this change is made, then we are able to find asharp constants again. -- bmt Mar 26, 1994 and executed by rss
zeroOneConversion opAlist == opAlist -- for u in opAlist repeat -- [op,:.] := u -- DIGITP (PNAME op).0 => RPLACA(u, string2Integer PNAME op) -- opAlist
asyDisplay(con,alist) == banner := '"==============================" sayBrightly [banner,'" ",con,'" ",banner] for [prop,:value] in alist repeat sayBrightlyNT [prop,'": "] pp value
asGetModemaps(opAlist,oform,kind,modemap) == acc:= nil rpvl:= MEMQ(kind, '(category function)) => rest $PatternVariableList -- *1 is special for $ $PatternVariableList form := [opOf oform,:[y for x in KDR oform for y in rpvl]] dc := MEMQ(kind, '(category function)) => "*1" form pred1 := kind = 'category => [["*1",form]] nil signature := CDAR modemap domainList := [[a,m] for a in rest form for m in rest signature | asIsCategoryForm m] catPredList:= kind = 'function => [["isFreeFunction","*1",opOf form]] [['ofCategory,:u] for u in [:pred1,:domainList]] -- for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat -- the code seems to oscillate between generating $FormalMapVariableList -- and generating $TriangleVariableList for [op,:itemlist] in SUBLISLIS(rpvl, $FormalMapVariableList,opAlist) repeat for [sig0, pred] in itemlist repeat sig := SUBST(dc,"$",sig0) pred:= SUBST(dc,"$",pred) sig := SUBLISLIS(rpvl,KDR oform,sig) pred:= SUBLISLIS(rpvl,KDR oform,pred) pred := pred or 'T ----------> Constants change <-------------- if IDENTP sig0 then sig := [sig] pred := MKPF([pred,'(isAsConstant)],'AND) pred' := MKPF([pred,:catPredList],'AND) mm := [[dc,:sig],[pred']] acc := [[op,:interactiveModemapForm mm],:acc] NREVERSE acc
asIsCategoryForm m == m = 'BasicType or GETDATABASE(opOf m,'CONSTRUCTORKIND) = 'category
asyDocumentation con == docHash := HGET($docHash,con) u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)] where fn(x,op) == [form,sig,pred,origin,where?,comments,:.] := x ----------> Constants change <-------------- if IDENTP sig then sig := [sig] [asySignature(sig,nil),trimComments comments] [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) --above "first" assumes only one entry comments := trimComments asyExtractDescription comments [:u,['constructor,[nil,comments]]]
asyExtractDescription str == k := STRPOS('"Description:",str,0,nil) => asyExtractDescription SUBSTRING(str,k + 12,nil) k := STRPOS('"Author:",str,0,nil) => asyExtractDescription SUBSTRING(str,0,k) str
trimComments str == null str or str = '"" => '"" m := MAXINDEX str str := SUBSTRING(str,0,m) trimString str
asyExportAlist con == --format of 'operationAlist property of LISPLIBS (as returned from koOps): -- <sig slotNumberOrNil optPred optELT> -- <sig sig' predOrT "Subsumed"> --!!! asyFile NEED: need to know if function is implemented by domain!!! docHash := HGET($docHash,con) [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)] where fn(x,op) == [form,sig,pred,origin,where?,comments,:.] := x tail := pred => [pred] nil newSig := asySignature(sig,nil) [newSig,nil,:tail]
asyMakeOperationAlist(con,proplist, key) == oplist := u := LASSOC('domExports,proplist) => kind := 'domain u u := LASSOC('catExports,proplist) => kind := 'category u key = 'domain => kind := 'domain u := NIL return nil ht := MAKE_-HASH_-TABLE() ancestorAlist := nil for ['Declare,id,form,r] in oplist repeat id = "%%" => opOf form = con => nil y := asyAncestors form if opOf(y)~=con then ancestorAlist := [ [y,:true],:ancestorAlist] idForm := form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] ----------> Constants change <-------------- id pred := LASSOC('condition,r) is p => hackToRemoveAnd p nil sig := asySignature(asytranForm(form,[idForm],nil),nil) entry := --id ~= "%%" and IDENTP idForm => [[sig],nil,nil,'ASCONST] id ~= "%%" and IDENTP idForm => pred => [[sig],nil,asyPredTran pred,'ASCONST] [[sig],nil,true,'ASCONST] pred => [sig,nil,asyPredTran pred] [sig] HPUT(ht,id,[entry,:HGET(ht,id)]) opalist := [[op,:REMDUP HGET(ht,op)] for op in HKEYS ht] HPUT($opHash,con,[ancestorAlist,nil,:opalist])
hackToRemoveAnd p == ---remove this as soon as .asy files do not contain forms (And pred) forms p is ['And,q,:r] => r => ['AND,q,:r] q p
asyAncestors x == x is ['Apply,:r] => asyAncestorList r x is [op,y,:.] and MEMQ(op, '(PretendTo RestrictTo)) => asyAncestors y atom x => x = '_% => '_$ MEMQ(x, $niladics) => [x] GETDATABASE(x ,'NILADIC) => [x] x asyAncestorList x
asyAncestorList x == [asyAncestors y for y in x] --============================================================================ -- Build Operation Alist from sig --============================================================================
--format of operations as returned from koOps -- <sig pred pakOriginOrNil TifPakExposedOrNil> -- <sig pred origin exposed?>
--abb,kind,file,sourcefile,coSig,dbLineNumber,constructorArgs,libfile --((sig where(NIL or #) condition(T or pred) ELTorSubsumed) ... --expanded lists are: sig, predicate, origin, exposeFlag, comments
--============================================================================ -- Building Hash Tables for Operations/Constructors --============================================================================ asytran fn == --put operations into table format for browser: -- <sig pred origin exposed? comments> inStream := OPEN fn sayBrightly ['" Reading ",fn] u := VMREAD inStream $niladics := mkNiladics u for x in $niladics repeat PUT(x,'NILADIC,true) for d in u repeat ['Declare,name,:.] := d name = "%%" => 'skip --skip over top-level properties $docHashLocal: local := MAKE_-HASH_-TABLE() asytranDeclaration(d,'(top),nil,false) if null name then hohohoho() HPUT($docHash,name,$docHashLocal) CLOSE inStream 'done
mkNiladics u == [name for x in u | x is ['Declare,name,y,:.] and y isnt ['Apply,'_-_>,:.]]
asytranDeclaration(dform,levels,predlist,local?) == ['Declare,id,form,r] := dform id = 'failed => id KAR dform ~= 'Declare => systemError '"asytranDeclaration" if levels = '(top) then if form isnt ['Apply,"->",:.] then HPUT($constantHash,id,true) comments := LASSOC('documentation,r) or '"" idForm := levels is ['top,:.] => form is ['Apply,'_-_>,source,target] => [id,:asyArgs source] id ----------> Constants change <-------------- id newsig := asytranForm(form,[idForm,:levels],local?) key := levels is ['top,:.] => MEMQ(id,'(%% Category Type)) => 'constant asyLooksLikeCatForm? form => 'category form is ['Apply, '_-_>,.,u] => if u is ['Apply, construc,:.] then u:= construc GETDATABASE(opOf u,'CONSTRUCTORKIND) = 'domain => 'function asyLooksLikeCatForm? u => 'category 'domain 'domain first levels typeCode := LASSOC('symeTypeCode,r) record := [idForm,newsig,asyMkpred predlist,key,true,comments,typeCode,:$asyFile] if not local? then ht := levels = '(top) => $conHash $docHashLocal HPUT(ht,id,[record,:HGET(ht,id)]) if levels = '(top) then asyMakeOperationAlist(id,r, key) ['Declare,id,newsig,r]
asyLooksLikeCatForm? x == --TTT don't see a Third in my version .... x is ['Define, ['Declare, ., ['Apply, 'Third,:.],:.],:.] or x is ['Define, ['Declare, ., 'Category ],:.]
asyIsCatForm form == form is ['Apply,:r] => r is ['_-_>,.,a] => asyIsCatForm a r is ['Third,'Type,:.] => true false false
asyArgs source == args := source is [op,:u] and asyComma? op => u [source] [asyArg x for x in args]
asyArg x == x is ['Declare,id,:.] => id x
asyMkpred predlist == null predlist => nil predlist is [p] => p ['AND,:predlist]
asytranForm(form,levels,local?) == u := asytranForm1(form,levels,local?) sayBrightly ['"form = ",form,'" "] null u => sayBrightly ['"hahah"] u
asytranForm1(form,levels,local?) == form is ['With,left,cat] => -- left ~= nil => error '"WITH cannot take a left argument yet" asytranCategory(form,levels,nil,local?) form is ['Apply,:.] => asytranApply(form,levels,local?) form is ['Declare,:.] => asytranDeclaration(form,levels,nil,local?) form is ['Comma,:r] => ['Comma,:[asytranForm(x,levels,local?) for x in r]] --form is ['_-_>,:s] => asytranMapping(s,levels,local?) form is [op,a,b] and MEMQ(a,'(PretendTo RestrictTo)) => asytranForm1(a,levels,local?) form is ['LitInteger,s] => READ_-FROM_-STRING(s) form is ['Define,:.] => form is ['Define,['Declare,.,x,:.],rest] => --TTT i don't know about this one but looks ok x = 'Category => asytranForm1(rest,levels, local?) asytranForm1(x,levels,local?) error '"DEFINE forms are not handled yet" if form = '_% then $hasPerCent := true IDENTP form => form = "%" => "$" GETL(form,'NILADIC) => [form] form [asytranForm(x,levels,local?) for x in form]
asytranApply(['Apply,name,:arglist],levels,local?) == MEMQ(name,'(Record Union)) => [name,:[asytranApplySpecial(x, levels, local?) for x in arglist]] null arglist => [name] name is [ 'RestrictTo, :.] => asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) name is [ 'Qualify, :.] => asytranApply(['Apply, CAR CDR name,:arglist], levels, local?) name is 'string => asytranLiteral CAR arglist name is 'integer => asytranLiteral CAR arglist name is 'float => asytranLiteral CAR arglist name = 'Enumeration => ["Enumeration",:[asytranEnumItem arg for arg in arglist]] [:argl,lastArg] := arglist [name,:[asytranFormSpecial(arg,levels,true) for arg in argl], asytranFormSpecial(lastArg,levels,false)]
asytranLiteral(lit) == CAR CDR lit
asytranEnumItem arg == arg is ['Declare, name, :.] => name error '"Bad Enumeration entry"
asytranApplySpecial(x, levels, local?) == x is ['Declare, name, typ, :.] => [":",name,asytranForm(typ, levels, local?)] asytranForm(x, levels, local?)
asytranFormSpecial(x, levels, local?) == --> this throws away variable name (revise later) x is ['Declare, name, typ, :.] => asytranForm(typ, levels, local?) asytranForm(x, levels, local?)
asytranCategory(form,levels,predlist,local?) == cat := form is ['With,left,right] => right is ['Blank,:.] => ['Sequence] right form left := form is ['With,left,right] => left is ['Blank,:.] => nil left nil $hasPerCent: local := nil items := cat is ['Sequence,:s] => s [cat] catTable := MAKE_-HASH_-TABLE() catList := nil for x in items | x repeat if null x then systemError() dform := asytranCategoryItem(x,levels,predlist,local?) null dform => nil dform is ['Declare,id,record,r] => HPUT(catTable,id,[asyWrap(record,predlist),:HGET(catTable,id)]) catList := [asyWrap(dform,predlist),:catList] keys := listSort(function GLESSEQP,HKEYS catTable) right1 := NREVERSE catList right2 := [[key,:HGET(catTable,key)] for key in keys] right := right2 => [:right1,['Exports,:right2]] right1 res := left => [left,:right] right res is [x] and x is ['IF,:.] => x ['With,:res]
asyWrap(record,predlist) == predlist => ['IF,MKPF(predlist,'AND),record] record
asytranCategoryItem(x,levels,predlist,local?) == x is ['If,predicate,item,:r] => IFCAR r => error '"ELSE expressions not allowed yet in conditionals" pred := predicate is ['Test,r] => r predicate asytranCategory(item,levels,[pred,:predlist],local?) MEMQ(KAR x,'(Default Foreign)) => nil x is ['Declare,:.] => asytranDeclaration(x,levels,predlist,local?) x
--============================================================================ -- Extending Constructor Datatable --============================================================================ --FORMAT of $constructorDataTable entry: --abb kind libFile sourceFile coSig constructorArgs --alist is ((kind . domain) (libFile . MATRIX) (sourceFile . "matrix") -- (coSig NIL T) (dbLineNumber . 29187) (constructorArgs R) -- (modemap . ( -- (|Matrix| |#1|) -- (Join (MatrixCategory #1 (Vector #1) (Vector #1)) -- (CATEGORY domain -- (SIGNATURE diagonalMatrix ($ (Vector #1))) -- (IF (has #1 (Field)) -- (SIGNATURE inverse ((Union $ "failed") $)) noBranch))) -- (Ring)) -- (T Matrix)) ) extendConstructorDataTable() == -- tb := $constructorDataTable for x in listSort(function GLESSEQP,HKEYS $conHash) repeat -- if LASSOC(x,tb) then tb := DELLASOS(x,tb) record := HGET($conHash,x) [form,sig,predlist,origin,exposure,comments,typeCode,:filename] := first record abb := asyAbbreviation(x,#(rest sig)) kind := 'domain --Note: this "first" assumes that there is ONLY one sig per name cosig := [nil,:asyCosig sig] args := asyConstructorArgs sig tb := [[x,abb, ['kind,:kind], ['cosig,:cosig], ['libfile,filename], ['sourceFile,STRINGIMAGE filename], ['constructorArgs,:args]],:tb] listSort(function GLESSEQP,ASSOCLEFT tb)
asyConstructorArgs sig == sig is ['With,:.] => nil sig is ['_-_>,source,target] => source is [op,:argl] and asyComma? op => [asyConstructorArg x for x in argl] [asyConstructorArg source]
asyConstructorArg x == x is ['Declare,name,t,:.] => name x
asyCosig sig == --can be a type or could be a signature atom sig or sig is ['With,:.] => nil sig is ['_-_>,source,target] => source is [op,:argl] and asyComma? op => [asyCosigType x for x in argl] [asyCosigType source] error false
asyCosigType u == u is [name,t] => t is [fn,:.] => asyComma? fn => fn fn = 'With => 'T nil t = 'Type => 'T error '"Unknown atomic type" error false
asyAbbreviation(id,n) == chk(id,main) where --> n = number of arguments main == a := createAbbreviation id => a name := PNAME id -- #name < 8 => INTERN UPCASE name parts := asySplit(name,MAXINDEX name) newname := "STRCONC"/[asyShorten x for x in parts] #newname < 8 => INTERN newname tryname := SUBSTRING(name,0,7) not createAbbreviation tryname => INTERN UPCASE tryname nil chk(conname,abb) == (xx := asyGetAbbrevFromComments conname) => xx con := abbreviation? abb => conname = con => abb conname abb
asyGetAbbrevFromComments con == docHash := HGET($docHash,con) u := [[op,:[fn(x,op) for x in rec]] for op in HKEYS docHash | rec := HGET(docHash,op)] where fn(x,op) == [form,sig,pred,origin,where?,comments,:.] := x ----------> Constants change <-------------- if IDENTP sig then sig := [sig] [asySignature(sig,nil),trimComments comments] [form,sig,pred,origin,where?,comments] := first HGET($conHash,con) --above "first" assumes only one entry x := asyExtractAbbreviation comments x => intern x NIL
asyExtractAbbreviation str == not (k:= STRPOS('"Abbrev: ",str,0,nil)) => NIL str := SUBSTRING(str, k+8, nil) k := STRPOS($stringNewline, str,0,nil) k => SUBSTRING(str, 0, k) str
asyShorten x == y := createAbbreviation x or LASSOC(x, '(("Small" . "SM") ("Single" ."S") ("Half" . "H")("Point" . "PT") ("Floating" . "F") ("System" . "SYS") ("Number" . "N") ("Inventor" . "IV") ("Finite" . "F") ("Double" . "D") ("Builtin" . "BI"))) => y UPCASE x
asySplit(name,end) == end < 1 => [name] k := 0 for i in 1..end while LOWER_-CASE_-P name.i repeat k := i k := k + 1 [SUBSTRING(name,0,k),:asySplit(SUBSTRING(name,k,nil),end-k)]
createAbbreviation s == if STRINGP s then s := INTERN s a := constructor? s a ~= s => a nil
--============================================================================ -- extending getConstructorModemap Property --============================================================================ --Note: modemap property is built when getConstructorModemap is called
asyConstructorModemap con == HGET($conHash,con) isnt [record,:.] => nil --not there [form,sig,predlist,kind,exposure,comments,typeCode,:filename] := record $kind: local := kind --NOTE: sig has the form (-> source target) or simply (target) $constructorArgs: local := KDR form signature := asySignature(sig,false) formals := ['_$,:TAKE(#$constructorArgs,$FormalMapVariableList)] mm := [[[con,:$constructorArgs],:signature],['T,con]] SUBLISLIS(formals,['_%,:$constructorArgs],mm)
asySignature(sig,names?) == sig is ['Join,:.] => [asySig(sig,nil)] sig is ['With,:.] => [asySig(sig,nil)] sig is ['_-_>,source,target] => target := names? => ['dummy,target] target source is [op,:argl] and asyComma? op => [asySigTarget(target,names?),:[asySig(x,names?) for x in argl]] [asySigTarget(target,names?),asySig(source,names?)] ----------> The following is a hack for constants which are category names<-- sig is ['Third,:.] => [asySig(sig,nil)] ----------> Constants change <-------------- asySig(sig,nil)
asySigTarget(u,name?) == asySig1(u,name?,true)
asySig(u,name?) == asySig1(u,name?,false)
asySig1(u,name?,target?) == x := name? and u is [name,t] => t u x is [fn,:r] => fn = 'Join => asyTypeJoin r ---------> jump out to newer code 4/94 MEMQ(fn, '(RestrictTo PretendTo)) => asySig(first r,name?) asyComma? fn => u := [asySig(x,name?) for x in r] target? => null u => '(Void) -- this implies a multiple value return, not currently supported -- in the interpreter ['Multi,:u] u fn = 'With => asyCATEGORY r fn = 'Third => r is [b] => b is ['With,:s] => asyCATEGORY s b is ['Blank,:.] => asyCATEGORY nil error x fn = 'Apply and r is ['_-_>,:s] => asyMapping(s,name?) fn = '_-_> => asyMapping(r,name?) fn = 'Declare and r is [name,typ,:.] => asySig1(typ, name?, target?) x is '(_%) => '(_$) [fn,:[asySig(x,name?) for x in r]] --x = 'Type => '(Type) x = '_% => '_$ x
asyMapping([a,b],name?) == newa := asySig(a,name?) b := asySig(b,name?) args := a is [op,:r] and asyComma? op => newa [a] ['Mapping,b,:args]
--============================================================================ -- code for asySignatures of the form (Join,:...) --============================================================================ asyType x == x is [fn,:r] => fn = 'Join => asyTypeJoin r MEMQ(fn, '(RestrictTo PretendTo)) => asyType first r asyComma? fn => u := [asyType x for x in r] u fn = 'With => asyCATEGORY r fn = '_-_> => asyTypeMapping r fn = 'Apply => r -- fn = 'Declare and r is [name,typ,:.] => typ x is '(_%) => '(_$) x --x = 'Type => '(Type) x = '_% => '_$ x
asyTypeJoin r == $conStack : local := nil $opStack : local := nil $predlist : local := nil for x in r repeat asyTypeJoinPart(x,$predlist) catpart := $opStack => ['CATEGORY,$kind,:asyTypeJoinStack REVERSE $opStack] nil conpart := asyTypeJoinStack REVERSE $conStack conpart => catpart => ['Join,:conpart,catpart] CDR conpart => ['Join,:conpart] conpart catpart
asyTypeJoinPart(x,$predlist) == x is ['Join,:y] => for z in y repeat asyTypeJoinPart(z, $predlist) x is ['With,:y] => for p in y repeat asyTypeJoinPartWith p asyTypeJoinPartWith x
asyTypeJoinPartWith x == x is ['Exports,:y] => for p in y repeat asyTypeJoinPartExport p x is ['Exports,:.] => systemError 'exports x is ['Comma] => nil x is ['Export,:y] => nil x is ['IF,:r] => asyTypeJoinPartIf r x is ['Sequence,:x] => for y in x repeat asyTypeJoinItem y asyTypeJoinItem x
asyTypeJoinPartIf [pred,value] == predlist := [asyTypeJoinPartPred pred,:$predlist] asyTypeJoinPart(value,predlist)
asyTypeJoinPartPred x == x is ['Test, y] => asyTypeUnit y asyTypeUnit x
asyTypeJoinItem x == result := asyTypeUnit x isLowerCaseLetter (PNAME opOf result).0 => $opStack := [[['ATTRIBUTE,result],:$predlist],:$opStack] $conStack := [[result,:$predlist],:$conStack]
asyTypeMapping([a,b]) == a := asyTypeUnit a b := asyTypeUnit b args := a is [op,:r] and asyComma? op => r [a] ['Mapping,b,:args]
asyTypeUnit x == x is [fn,:r] => fn = 'Join => systemError 'Join ----->asyTypeJoin r MEMQ(fn, '(RestrictTo PretendTo)) => asyTypeUnit first r asyComma? fn => u := [asyTypeUnit x for x in r] u fn = 'With => asyCATEGORY r fn = '_-_> => asyTypeMapping r fn = 'Apply => asyTypeUnitList r fn = 'Declare and r is [name,typ,:.] => asyTypeUnitDeclare(name,typ) x is '(_%) => '(_$) [fn,:asyTypeUnitList r] GETL(x,'NILADIC) => [x] --x = 'Type => '(Type) x = '_% => '_$ x
asyTypeUnitList x == [asyTypeUnit y for y in x]
asyTypeUnitDeclare(op,typ) == typ is ['Apply, :r] => asyCatSignature(op,r) asyTypeUnit typ --============================================================================ -- Translator for ['With,:.] --============================================================================ asyCATEGORY x == if x is [join,:y] and join is ['Apply,:s] then exports := y joins := s is ['Join,:r] => [asyJoinPart u for u in r] [asyJoinPart s] else if x is [id,:y] and IDENTP id then joins := [[id]] exports := y else joins := nil exports := x cats := exports operations := nil if exports is [:r,['Exports,:ops]] then cats := r operations := ops exportPart := ['CATEGORY,'domain,:"APPEND"/[asyCatItem y for y in operations]] cats := "append"/[asyCattran c for c in cats] joins or cats => ['Join,:joins,:cats, exportPart] exportPart
simpCattran x == u := asyCattran x u is [y] => y ['Join,:u]
asyCattran x == x is ['With,:r] => "append"/[asyCattran1 x for x in r] x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] [x]
asyCattran1 x == x is ['Exports,:y] => "append"/[asyCattranOp u for u in y] x is ['IF,:.] => "append"/[asyCattranConstructors(x,nil)] systemError nil
asyCattranOp [op,:items] == "append"/[asyCattranOp1(op,item,nil) for item in items]
asyCattranOp1(op, item, predlist) == item is ['IF, p, x] => pred := asyPredTran p is ['Test,t] => t p -- x is ['IF,:.] => "append"/[asyCattranOp1('IF, x, [pred,:predlist])] -- This line used to call asyCattranOp1 with too few arguments. Following -- fix suggested by RDJ. x is ['IF,:.] => "append"/[asyCattranOp1(op,y,[pred,:predlist]) for y in x] [['IF, asySimpPred(pred,predlist), asyCattranSig(op,x), 'noBranch]] [asyCattranSig(op,item)]
asyPredTran p == asyPredTran1 asyJoinPart p
asyPredTran1 p == p is ['Has,x,y] => ['has,x, simpCattran y] p is ['Test, q] => asyPredTran1 q p is [op,:r] and MEMQ(op,'(AND OR NOT)) => [op,:[asyPredTran1 q for q in r]] p
asyCattranConstructors(item, predlist) == item is ['IF, p, x] => pred := asyPredTran p is ['Test,t] => t p x is ['IF,:.] => "append"/[asyCattranConstructors(x, [pred,:predlist])] form := ['ATTRIBUTE, asyJoinPart x] [['IF, asySimpPred(pred,predlist), form, 'noBranch]] systemError()
asySimpPred(p, predlist) == while predlist is [q,:predlist] repeat p := quickAnd(q,p) p
asyCattranSig(op,y) == y isnt ["->",source,t] => -- following makes constants into nullary functions ['SIGNATURE, op, [asyTypeUnit y]] s := source is ['Comma,:s] => [asyTypeUnit z for z in s] [asyTypeUnit source] t := asyTypeUnit t null t => ['SIGNATURE,op,s] ['SIGNATURE,op,[t,:s]]
asyJoinPart x == IDENTP x => [x] asytranForm(x,nil,true)
asyCatItem item == atom item => [item] item is ['IF,.,.] => [item] [op,:sigs] := item [asyCatSignature(op,sig) for sig in sigs | sig]
asyCatSignature(op,sig) == sig is ['_-_>,source,target] => ['SIGNATURE,op, [asyTypeItem target,:asyUnTuple source]] ----------> Constants change <-------------- -- following line converts constants into nullary functions ['SIGNATURE,op,[asyTypeItem sig]]
asyUnTuple x == x is [op,:u] and asyComma? op => [asyTypeItem y for y in u] [asyTypeItem x]
asyTypeItem x == atom x => x = '_% => '_$ x x is ['_-_>,a,b] => ['Mapping,b,:asyUnTuple a] x is ['Apply,:r] => r is ['_-_>,a,b] => ['Mapping,b,:asyUnTuple a] r is ['Record,:parts] => ['Record,:[[":",a,b] for ['Declare,a,b,:.] in parts]] r is ['Segment,:parts] => ['Segment,:[asyTypeItem x for x in parts]] asytranApply(x,nil,true) x is ['Declare,.,t,:.] => asyTypeItem t x is ['Comma,:args] => -- this implies a multiple value return, not currently supported -- in the interpreter args => ['Multi,:[asyTypeItem y for y in args]] ['Void] [asyTypeItem y for y in x]
--============================================================================ -- Utilities --============================================================================ asyComma? op == MEMQ(op,'(Comma Multi))
hput(table,name,value) == if null name then systemError() HPUT(table,name,value)
--============================================================================ -- category parts --============================================================================
-- this constructs operation information from a category. -- NB: This is categoryParts, but with the kind supplied by -- an arguments asCategoryParts(kind,conform,category,:options) == main where main == cons? := IFCAR options --means to include constructors as well $attrlist: local := nil $oplist : local := nil $conslist: local := nil conname := opOf conform for x in exportsOf(category) repeat build(x,true) $attrlist := listSort(function GLESSEQP,$attrlist) $oplist := listSort(function GLESSEQP,$oplist) res := [$attrlist,:$oplist] if cons? then res := [listSort(function GLESSEQP,$conslist),:res] if kind = 'category then tvl := TAKE(#rest conform,$TriangleVariableList) res := SUBLISLIS($FormalMapVariableList,tvl,res) res build(item,pred) == item is ['SIGNATURE,op,sig,:.] => $oplist := [[opOf op,sig,:pred],:$oplist] --note: opOf is needed!!! Bug in compiler puts in (One) and (Zero) item is ['ATTRIBUTE,attr] => constructor? opOf attr => $conslist := [[attr,:pred],:$conslist] nil opOf attr = 'nothing => 'skip $attrlist := [[opOf attr,IFCDR attr,:pred],:$attrlist] item is ['TYPE,op,type] => $oplist := [[op,[type],:pred],:$oplist] item is ['IF,pred1,s1,s2] => build(s1,quickAnd(pred,pred1)) s2 => build(s2,quickAnd(pred,['NOT,pred1])) item is ['PROGN,:r] => for x in r repeat build(x,pred) item in '(noBranch) => 'ok null item => 'ok systemError '"build error" exportsOf(target) == target is ['CATEGORY,.,:r] => r target is ['Join,:r,f] => for x in r repeat $conslist := [[x,:true],:$conslist] exportsOf f $conslist := [[target,:true],:$conslist] nil
--============================================================================ -- Dead Code (for a very odd value of 'dead') --============================================================================ asyTypeJoinPartExport x == [op,:items] := x for y in items repeat y isnt ["->",source,t] => -- sig := ['TYPE, op, asyTypeUnit y] -- converts constants to nullary functions (this code isn't dead) sig := ['SIGNATURE, op, [asyTypeUnit y]] $opStack := [[sig,:$predlist],:$opStack] s := source is ['Comma,:s] => [asyTypeUnit z for z in s] [asyTypeUnit source] t := asyTypeUnit t sig := null t => ['SIGNATURE,op,s] ['SIGNATURE,op,[t,:s]] $opStack := [[sig,:$predlist],:$opStack]
--============================================================================ -- Code to create opDead Code --============================================================================ asyTypeJoinStack r == al := [[[x while r is [[x, :q],:s] and p = q and (r := s; true)],:p] while r is [[.,:p],:.]] result := "append"/[fn for [y,:p] in al] where fn == p => [['IF,asyTypeMakePred p,:y]] y result
asyTypeMakePred [p,:u] == while u is [q,:u] repeat p := quickAnd(q,p) p
boot
 
   >> System error:
   invalid number of arguments: 1
>> System error: failed to find the TRUENAME of 4385072929859895067-25px002.clisp: No such file or directory

aldor
--)abbrev domain MM mm
#pile
#include "axiom"
mm(z:Integer, h:Integer->Integer): Exports == Implementation where
  Exports ==> IntegralDomain with
    if h(h(z))=h(z) then
      IntegralDomain
    if h(h(z))~=h(z) then
      fail: () -> Integer
  Implementation ==> Integer add
    if h(h(z))~=h(z) then
      fail():Integer == 0
aldor
   Compiling FriCAS source code from file 
      /var/lib/zope2.10/instance/axiom-wiki/var/LatexWiki/5106525683332903717-25px003.as
      using AXIOM-XL compiler and options 
-O -Fasy -Fao -Flsp -laxiom -Mno-ALDOR_W_WillObsolete -DAxiom -Y $AXIOM/algebra -I $AXIOM/algebra
      Use the system command )set compiler args to change these 
      options.
#1 (Warning) Could not use archive file `libaxiom.al'.
#2 (Warning) Could not use archive file `libaxiom.al'.
"/usr/local/aldor/linux/1.1.0/include/axiom.as", line 4: 
import from AxiomLib;
............^
[L4 C13] #3 (Error) No meaning for identifier `AxiomLib'.
"/usr/local/aldor/linux/1.1.0/include/axiom.as", line 15: import { true: %, false: % } from Boolean; ..................................^ [L15 C35] #4 (Error) No meaning for identifier `Boolean'.
"/usr/local/aldor/linux/1.1.0/include/axiom.as", line 17: string: Literal -> %; ........................^.......^ [L17 C25] #5 (Error) No meaning for identifier `Literal'. [L17 C33] #6 (Error) There are no suitable meanings for the operator `->'.
"/usr/local/aldor/linux/1.1.0/include/axiom.as", line 18: } from String; .......^ [L18 C8] #8 (Error) No meaning for identifier `String'.
"/var/lib/zope2.10/instance/axiom-wiki/var/LatexWiki/5106525683332903717-25px003.as", line 4: mm(z:Integer, h:Integer->Integer): Exports == Implementation where .....^.................^ [L4 C6] #9 (Error) No meaning for identifier `Integer'. [L4 C24] #10 (Error) There are no suitable meanings for the operator `->'.
"/var/lib/zope2.10/instance/axiom-wiki/var/LatexWiki/5106525683332903717-25px003.as", line 9: fail: () -> Integer ..................^ [L9 C19] #12 (Error) (After Macro Expansion) No meaning for identifier `Integer'. Expanded expression was: Integer [L9 C19] #13 (Fatal Error) (After Macro Expansion) Too many errors (use `-M emax=n' or `-M no-emax' to change the limit). Expanded expression was: ()
The )library system command was not called after compilation.

axiom
mask(mask(1))=mask(1)
(1) 1= 1
Type: Equation(PositiveInteger?)
axiom
I1 := mm(1,mask)
There are no library operations named mm Use HyperDoc Browse or issue )what op mm to learn if there is any operation containing " mm " in its name.
Cannot find a definition or applicable library operation named mm with argument type(s) PositiveInteger Variable(mask)
Perhaps you should use "@" to indicate the required return type, or "$" to specify which version of the function you need. x1:I1 := 1
(2) 1
Type: PositiveInteger?
axiom
mask(mask(2))=mask(2)
(3) 7= 3
Type: Equation(PositiveInteger?)
axiom
I2 := mm(2,mask)
There are no library operations named mm Use HyperDoc Browse or issue )what op mm to learn if there is any operation containing " mm " in its name.
Cannot find a definition or applicable library operation named mm with argument type(s) PositiveInteger Variable(mask)
Perhaps you should use "@" to indicate the required return type, or "$" to specify which version of the function you need. x2:I2 := fail()
There are no library operations named fail Use HyperDoc Browse or issue )what op fail to learn if there is any operation containing " fail " in its name.
Cannot find a no-argument definition or library operation named fail .