Return to parse.sml CVS log

Up to [Research Unix] / researchv10no / cmd / sml / src / parse

Annotation of researchv10no/cmd/sml/src/parse/parse.sml, revision 1.1

1.1     ! root        1: (* parse.sml *)
        !             2: 
        !             3: structure Parse : PARSE =
        !             4: struct
        !             5: 
        !             6: structure BareAbsyn = BareAbsyn
        !             7: 
        !             8: exception Eof
        !             9: 
        !            10: fun interdec (lex as {nextToken, prompt, advance}: Lex.lexer ) =
        !            11: let 
        !            12: 
        !            13:   open ErrorMsg Symbol PrintUtil Lex
        !            14:   open Token
        !            15:   open Access Basics BasicTypes TypesUtil Absyn
        !            16:   open Env
        !            17:   open EnvAccess
        !            18:   open ModUtil
        !            19:   open SigMatch
        !            20:   open FirstSets
        !            21:   open Misc
        !            22: 
        !            23:   infix -->
        !            24: 
        !            25: (* constants *)
        !            26: 
        !            27: val maxTypSpecs = 100  (*maximum number of type specs in a signature *)
        !            28: val maxStrSpecs = 100  (*maximum number of structure specs in a signature *)
        !            29: 
        !            30: (* utility functions *)
        !            31: 
        !            32: fun at tok = if !nextToken = tok then (advance(); true) else false
        !            33: 
        !            34: fun checkToken tok =
        !            35:     if at(tok)
        !            36:     then ()
        !            37:     else complain("expected "^Token.tokenName tok^
        !            38:                            ", found "^Token.tokenName(!nextToken))
        !            39: 
        !            40: fun getSymbol () = case !nextToken of
        !            41:                     Token.ID s => (advance(); s)
        !            42:                    | Token.ASTERISK => (advance(); ASTERISKsym)
        !            43:                   | Token.EQUAL => (advance(); EQUALsym)
        !            44:                   | Token.TYVAR s => (advance(); s)
        !            45:                   | Token.IDDOT s => (advance(); s)
        !            46:                   | tok => ErrorMsg.impossible("getSymbol: " ^ 
        !            47:                                             Token.tokenName tok)
        !            48: fun expop () =
        !            49:     case !nextToken
        !            50:       of EQUAL => lookFIX(EQUALsym)
        !            51:        | ASTERISK => lookFIX(ASTERISKsym)
        !            52:        | ID s => lookFIX(s)
        !            53:        | _ => NONfix
        !            54: 
        !            55: fun patop () =
        !            56:     case !nextToken
        !            57:       of ASTERISK => lookFIX (ASTERISKsym)
        !            58:        | ID s => lookFIX(s)
        !            59:        | _ => NONfix
        !            60: 
        !            61: fun ident() =
        !            62:     case !nextToken
        !            63:       of ID s => (advance();s)
        !            64:        | ASTERISK => (advance();ASTERISKsym)
        !            65:        | EQUAL => (advance();EQUALsym)
        !            66:        | tok => (complain("expected identifier, found " ^ tokenName tok);
        !            67:                 bogusID)
        !            68: 
        !            69: fun nonfix_ident() =
        !            70:        if (case !nextToken of
        !            71:              ID s => lookFIX(s)=NONfix
        !            72:            | ASTERISK => lookFIX(ASTERISKsym)=NONfix
        !            73:            | _ => false)
        !            74:         then getSymbol()
        !            75:         else (complain("expected nonfix-identifier, found "
        !            76:                          ^ tokenName(!nextToken));
        !            77:                 bogusID)
        !            78:     
        !            79: fun opid() =
        !            80:     case !nextToken
        !            81:       of ID s  => nonfix_ident()
        !            82:        | ASTERISK => nonfix_ident()
        !            83:        | OP    => (advance(); 
        !            84:                    case !nextToken
        !            85:                     of ID s => getSymbol()
        !            86:                      | ASTERISK => getSymbol()
        !            87:                      | EQUAL => getSymbol()
        !            88:                      | tok => (complain ("op not followed by identifier, found "
        !            89:                                        ^ tokenName tok); bogusID))
        !            90:        | tok => (complain("expected identifier or OP, found " ^ tokenName tok);
        !            91:                 bogusID)
        !            92: 
        !            93: fun getSTR id = lookSTR id
        !            94:                 handle Unbound => 
        !            95:                    (complain("unbound structure name: " ^ name id);
        !            96:                     bogusSTR)
        !            97: 
        !            98: fun getEXN id = lookCON(id) handle Unbound => unboundEXN id
        !            99: 
        !           100: fun rightAssoc(elem:(unit->'a), tok:token, cons:('a*'b->'b), single:('a->'b))
        !           101:     : 'b =
        !           102:     let fun ra() = 
        !           103:             let val e1 = elem()
        !           104:             in if at(tok) then cons(e1,ra()) else single e1
        !           105:             end
        !           106:     in  ra()
        !           107:     end;
        !           108: 
        !           109: fun leftAssoc(elem, tok, cons, single) =
        !           110:     let fun la e = if at tok then la(cons(e,elem())) else single e
        !           111:      in la(elem())
        !           112:     end
        !           113: 
        !           114: fun precedence(elem,g,checkop) =
        !           115:      let fun parse(f, bp, e) =
        !           116:            case checkop()
        !           117:             of INfix(lbp,rbp) =>
        !           118:                if lbp > bp
        !           119:                 then let val id = getSymbol()
        !           120:                          val rhs = parse ((fn x=>g(id,e,x)),rbp,elem())
        !           121:                       in parse(f,bp,rhs)
        !           122:                      end
        !           123:                 else f e
        !           124:              | _ => f e
        !           125:       in parse((fn x=>x), ~100, elem())
        !           126:      end
        !           127: 
        !           128: fun andList(elem) =
        !           129:     let val e1 = elem()
        !           130:      in (if at(AND) then e1 :: andList(elem) else [e1])
        !           131:     end
        !           132: 
        !           133: fun andListProtect(elem) = andList (fn () => protect(protectScope,elem))
        !           134: 
        !           135: (* parsing functions *)
        !           136: 
        !           137: (* qualified id interpretation *)
        !           138: 
        !           139: fun symPath() =
        !           140:     case !nextToken
        !           141:       of IDDOT s => getSymbol() :: symPath()
        !           142:        | ID s => [getSymbol()]
        !           143:        | ASTERISK => [getSymbol()]
        !           144:        | EQUAL => [getSymbol()]
        !           145:        | _ => (complain "incomplete qualified identifier"; [bogusID])
        !           146: 
        !           147: fun qid(lookLast) = lookPath(symPath(),lookLast)
        !           148: 
        !           149: (* record labels *)
        !           150: 
        !           151: fun selector() =
        !           152:     let fun sel1 id = 
        !           153:            let val v = namedLvar id
        !           154:                val tyref = ref UNDEFty
        !           155:                val v1 = VALvar{name=[id],access=LVAR(v),typ=tyref}
        !           156:                val v2 = VALvar{name=[id],access=PATH[v],typ=tyref}
        !           157:             in FNexp[RULE(RECORDpat{fields=[(id,VARpat v1)],
        !           158:                                     flex=true,
        !           159:                                     typ=ref UNDEFty, pats=ref nil},
        !           160:                           VARexp(ref v2))]
        !           161:            end
        !           162:      in case !nextToken
        !           163:          of ID _ => sel1(ident())
        !           164:           | INT i => let val s = makestring i
        !           165:                       in if i < 1
        !           166:                          then complain ("nonpositive integer label in selector,\
        !           167:                                         \ found " ^ s)
        !           168:                          else ();
        !           169:                          sel1(Symbol.symbol(s))
        !           170:                      end
        !           171:                      before advance()
        !           172:           | _ => (complain "illegal selector function"; bogusExp)
        !           173:     end
        !           174: 
        !           175: fun labels(parseOne, separator, dotsOK, abbrev) =
        !           176:     if (case !nextToken
        !           177:           of ID _ => true
        !           178:           | INT _ => true
        !           179:           | DOTDOTDOT => true
        !           180:           | _ => false)
        !           181:     then let fun lablist () = 
        !           182:                 case !nextToken
        !           183:                   of ID _ => field(ident(),abbrev)
        !           184:                    | INT i => let val s = makestring i
        !           185:                               in advance();
        !           186:                                  if i < 1
        !           187:                                  then complain ("nonpositive integer label, \
        !           188:                                                 \found " ^ s)
        !           189:                                  else ();
        !           190:                                  field(Symbol.symbol(s),
        !           191:                                          (fn id =>
        !           192:                                            condemn("numeric label abbreviations allowed only in patterns: " ^
        !           193:                                                    Symbol.name id)))
        !           194:                               end
        !           195:                    | DOTDOTDOT => nil
        !           196:                    | tok => (complain("expected label, found " ^
        !           197:                                        tokenName tok); nil)
        !           198:             and field(id,abbrev) =
        !           199:                 (id,
        !           200:                  if at(separator) then parseOne()
        !           201:                    else if !nextToken = COMMA orelse
        !           202:                            !nextToken = COLON orelse
        !           203:                            !nextToken = AS orelse
        !           204:                            !nextToken = RBRACE then abbrev(id)
        !           205:                    else condemn("expected " ^ Token.tokenName separator ^
        !           206:                                 " after label, found " ^
        !           207:                                 tokenName(!nextToken)),
        !           208:                  ref 0)
        !           209:                 :: (if at(COMMA) then lablist() else nil)
        !           210:             val l = lablist()
        !           211:             val dots = at(DOTDOTDOT)
        !           212:             val sl = sort3 l
        !           213:          in if length l > length sl
        !           214:             then complain "duplicate label in record"
        !           215:             else ();
        !           216:             if dots andalso not dotsOK
        !           217:                then complain "use of ... outside pattern" else ();
        !           218:             checkToken(RBRACE);
        !           219:             (l,sl,dots)
        !           220:         end
        !           221:     else (checkToken(RBRACE); (nil,nil,false))
        !           222: 
        !           223: exception Clausal of symbol * pat   (* for returning clausal patterns from pat *)
        !           224: 
        !           225: 
        !           226: (* types *)
        !           227: 
        !           228: fun noAbbrev(_) = 
        !           229:     (complain "expected colon after label in record type, found comma";
        !           230:      UNDEFty)      
        !           231: fun ty() =
        !           232:     rightAssoc(ty1,ARROW,
        !           233:               (fn (t,ts) => CONty(arrowTycon, [t,ts])),
        !           234:               (fn t => t))
        !           235: and ty1() = 
        !           236:     case rightAssoc(ty2,ASTERISK,op::,single)
        !           237:       of [t] => t
        !           238:        | l => tupleTy l
        !           239: and ty2() =
        !           240:     (* incorporates tyapp and aty nonterminals *)
        !           241:     let        fun qid_s(t) =
        !           242:            case !nextToken
        !           243:              of ID _ =>
        !           244:                   qid_s(CONty(!lookArTYC(getSymbol(),1), [t]))
        !           245:               | IDDOT _ =>
        !           246:                   qid_s(CONty(!lookPathArTYC(symPath(),1), [t]))
        !           247:               | _ => t
        !           248:      in qid_s(case !nextToken
        !           249:               of LPAREN =>
        !           250:                    let val t1 = (advance(); ty())
        !           251:                     in if at(RPAREN)
        !           252:                        then t1
        !           253:                        else if at(COMMA)
        !           254:                        then let val tys = t1 :: ty_pc()
        !           255:                                 val arity = length tys
        !           256:                              in checkToken(RPAREN);
        !           257:                                 case !nextToken
        !           258:                                  of ID s =>
        !           259:                                      CONty(!lookArTYC(ident(),arity),
        !           260:                                            tys)
        !           261:                                   | IDDOT s => 
        !           262:                                      CONty(!lookPathArTYC(symPath(),arity),
        !           263:                                            tys)
        !           264:                                   | tok => condemn("expected type \
        !           265:                                            \constructor, found "
        !           266:                                            ^ tokenName tok)
        !           267:                             end
        !           268:                        else (complain("expected RPAREN or COMMA in type\
        !           269:                                \args, found " ^ tokenName(!nextToken));
        !           270:                              t1)
        !           271:                    end
        !           272:                | ID s  => CONty(!lookArTYC(ident(),0),[])
        !           273:                | IDDOT s => CONty(!lookPathArTYC(symPath(),0),[])
        !           274:                | Token.TYVAR s => VARty(lookTyvar(getSymbol()))
        !           275:                | LBRACE =>
        !           276:                    (advance();
        !           277:                     let val (l,sl,_) = labels(ty,COLON,false, noAbbrev)
        !           278:                      in recordTy(map (fn (id,ty,_) => (id, ty)) sl)
        !           279:                     end)
        !           280:                | tok => condemn("expected a type expression, found token "
        !           281:                                 ^ tokenName tok))
        !           282:     end
        !           283: and ty_pc() = rightAssoc(ty,COMMA,op::,single)
        !           284: 
        !           285: 
        !           286: fun markexp f x = if !System.Control.Debug.debugging
        !           287:                 then let val one = (!ErrorMsg.fileName,!ErrorMsg.lineNum)
        !           288:                      val e = f x
        !           289:                      val two = (!ErrorMsg.fileName,!ErrorMsg.lineNum)
        !           290:                   in case e
        !           291:                        of MARKexp _ => e
        !           292:                         | e' => if one=two then MARKexp(e',one,one)
        !           293:                                            else MARKexp(e',one,two)
        !           294:                  end
        !           295:                else f x
        !           296: 
        !           297: fun markdec f x =  if !System.Control.Debug.debugging
        !           298:                 then let val one = (!ErrorMsg.fileName,!ErrorMsg.lineNum)
        !           299:                      val e = f x
        !           300:                      val two = (!ErrorMsg.fileName,!ErrorMsg.lineNum)
        !           301:                   in case e
        !           302:                        of MARKdec _ => e
        !           303:                         | e' => if one=two then MARKdec(e',one,one)
        !           304:                                            else MARKdec(e',one,two)
        !           305:                  end
        !           306:                else f x
        !           307: 
        !           308: 
        !           309: (* expressions -- including local declarations *)
        !           310: 
        !           311: fun exp (stamps: Stampset.stampsets) =
        !           312:     case !nextToken
        !           313:      of FN => (advance(); FNexp(match(stamps)))
        !           314:       | CASE => CASEexp((advance(); exp(stamps)),
        !           315:                        (checkToken(OF); match(stamps)))
        !           316:       | WHILE => WHILEexp((advance(); exp(stamps)),
        !           317:                          (checkToken(DO); markexp exp stamps))
        !           318:       | IF => IFexp((advance(); exp(stamps)), (checkToken(THEN); markexp exp stamps),
        !           319:                            (checkToken(ELSE); markexp exp stamps))
        !           320:       | RAISE => RAISEexp(advance(); exp(stamps))
        !           321:       | _ => let val e = exp1(stamps)
        !           322:               in if !nextToken = HANDLE
        !           323:                 then (advance(); HANDLEexp(e,HANDLER(FNexp(match(stamps)))))
        !           324:                 else e
        !           325:              end
        !           326: 
        !           327: and match (stamps) = rightAssoc((fn () => rule stamps),BAR,op::,single)
        !           328: 
        !           329: and rule (stamps) = 
        !           330:      let val bl = ref nil : (symbol * var) list ref
        !           331:       in protect(protectScope,
        !           332:            (fn () => RULE(pat(bl,true)
        !           333:                           handle Clausal(id,_) => 
        !           334:                             condemn("undefined op in pattern: "^name id),
        !           335:                           (checkToken(DARROW);
        !           336:                            if !nextToken=EQUAL then advance() else ();
        !           337: (* Capitalization convention
        !           338:                            app checkBinding (!bl);
        !           339: *)
        !           340:                            bindVARs(!bl); markexp exp stamps))))
        !           341:      end
        !           342: 
        !           343: and exp_ps (stamps) = rightAssoc((fn () => exp stamps),SEMICOLON,op::,single)
        !           344: 
        !           345: and exp1 (stamps) = leftAssoc((fn () => markexp exp2 stamps),
        !           346:                              ORELSE,ORELSEexp,(fn x=>x))
        !           347: 
        !           348: and exp2 (stamps) = leftAssoc((fn () => markexp exp3 stamps),
        !           349:                              ANDALSO,ANDALSOexp,(fn x=>x))
        !           350: 
        !           351:  (* N.B. above markexp's will cause too much marking, but this is harmless*) 
        !           352: 
        !           353: and exp3(stamps) =
        !           354:     let val e = precedence((fn () => markexp exp5 stamps), 
        !           355:                (fn(id,a,b)=>APPexp(markexp lookID(id), 
        !           356:                                    markexp TUPLEexp[a,b])), expop)
        !           357:      in if at(COLON) then CONSTRAINTexp(e,ty()) else e
        !           358:     end
        !           359: 
        !           360: and exp5 (stamps) =
        !           361:      let fun loop e =
        !           362:             if firstAexp lookFIX (!nextToken)
        !           363:             then loop(markexp APPexp(e,markexp aexp stamps))
        !           364:             else e
        !           365:       in loop(markexp aexp stamps)
        !           366:      end
        !           367: 
        !           368: (* note that IF WHILE CASE RAISE FN  are matched below, but
        !           369:    are not in firstAexp.  This is intentional *)
        !           370: 
        !           371: and aexp (stamps) =
        !           372:      case !nextToken
        !           373:        of ID _  => lookID(nonfix_ident())
        !           374:         | OP    => lookID(opid())
        !           375:        | IDDOT s  => qid(lookIDinStr)
        !           376:         | INT i         => INTexp(i) before advance()
        !           377:         | REAL s => REALexp(s) before advance()
        !           378:         | STRING s => STRINGexp(s) before advance()
        !           379:        | HASH => (advance(); selector())
        !           380:         | LBRACE => (advance(); exp_brace(stamps))
        !           381:         | LPAREN => (advance(); exp_paren(stamps))
        !           382:         | LBRACKET => (advance(); exp_bracket(stamps))
        !           383:         | LET   => 
        !           384:            protect(protectScope,
        !           385:                    (fn()=>(advance();
        !           386:                           (LETexp(ldecs([],stamps),
        !           387:                                   (checkToken(IN); SEQexp(exp_ps(stamps)))))
        !           388:                           before checkToken(END))))
        !           389:         | FN =>   exp(stamps)
        !           390:         | CASE => exp(stamps)
        !           391:         | WHILE => exp(stamps)
        !           392:         | IF => exp(stamps)
        !           393:        | RAISE => exp(stamps)
        !           394:         | tok   => (complain ("atomic expression expected, found " ^
        !           395:                               tokenName tok);
        !           396:                    bogusExp)
        !           397: 
        !           398: and exp_brace (stamps) =
        !           399:     let val (l,sl,_) =
        !           400:            labels((fn () => exp stamps),EQUAL,false,
        !           401:                   (fn x => (complain "illegal record-name element abbreviation";
        !           402:                             bogusExp)))
        !           403:        fun assign (i,(_,_,r)::tl) = (r:=i; assign(i+1,tl))
        !           404:          | assign (n,nil) = ()
        !           405:      in assign(0,sl);
        !           406:        RECORDexp(map (fn (id,e,ref n) => (LABEL{name=id,number=n},e)) l)
        !           407:     end
        !           408: 
        !           409: and exp_paren (stamps) =
        !           410:      if at(RPAREN)
        !           411:         then unitExp (* TUPLEexp(nil) *)
        !           412:         else let val e = exp(stamps)
        !           413:               in case !nextToken
        !           414:                   of RPAREN => (advance(); e)
        !           415:                    | COMMA =>
        !           416:                       (advance();
        !           417:                        TUPLEexp(e::exp_pc(stamps)) before checkToken(RPAREN))
        !           418:                    | SEMICOLON =>
        !           419:                       (advance();
        !           420:                        SEQexp(e::exp_ps(stamps)) before checkToken(RPAREN))
        !           421:                    | tok => (complain ("expected comma, right paren, or\
        !           422:                             \ semicolon, found " ^ tokenName tok); e)
        !           423:              end
        !           424: 
        !           425: and exp_bracket (stamps) =
        !           426:      if at(RBRACKET)
        !           427:         then LISTexp(nil)
        !           428:         else LISTexp(exp(stamps) ::
        !           429:               if !nextToken = RBRACKET
        !           430:                 then (advance(); nil)
        !           431:                         else (checkToken(COMMA);
        !           432:                               exp_pc(stamps) before checkToken(RBRACKET)))
        !           433: 
        !           434: and exp_pc (stamps) = rightAssoc((fn () => exp stamps),COMMA,op::,single)
        !           435: 
        !           436: and pat (bl: (symbol * var) list ref, full: bool) =
        !           437:     (* full false means parse atomic pattern *)
        !           438:    let fun restrictLAYEREDpat(x as (VARpat _, _)) = LAYEREDpat x
        !           439:          | restrictLAYEREDpat(y,z) =
        !           440:              (complain "pattern to left of AS must be a variable"; z)
        !           441: 
        !           442:        fun pat0 () = rightAssoc(pat1,AS,restrictLAYEREDpat,(fn x=>x))
        !           443: 
        !           444:        and pat1 () = 
        !           445:           let val e = precedence(
        !           446:                         pat2, 
        !           447:                         (fn(id,a,b)=>
        !           448:                            APPpat(lookCON id, TUPLEpat[a,b])
        !           449:                            handle Unbound => 
        !           450:                              raise Clausal(id, TUPLEpat[a,b])),
        !           451:                         patop)
        !           452:            in if at(COLON) then CONSTRAINTpat(e,ty()) else e
        !           453:           end
        !           454: 
        !           455:        and pat2 () =
        !           456:           let fun useCon(dcon as DATACON{const,name,...}) =
        !           457:                    case (const,firstApat lookFIX (!nextToken))
        !           458:                      of (true,false) => CONpat(dcon)
        !           459:                       | (false,true) => APPpat(dcon,apat())
        !           460:                       | (_,x) => (complain("improper use of constructor "^
        !           461:                                      Symbol.name(name)^" in pattern");
        !           462:                                   (if x then (apat(); ()) else ());
        !           463:                                   WILDpat)
        !           464:               fun simpleId(id) =
        !           465:                   useCon(lookCON id)
        !           466:                   handle Unbound => 
        !           467:                     if firstApat lookFIX (!nextToken)
        !           468:                       then raise Clausal(id, apat())
        !           469:                       else VARpat(newVAR(bl,id))
        !           470:            in case !nextToken
        !           471:                 of ID s => (if lookFIX(s) = NONfix
        !           472:                            then ()
        !           473:                            else complain("pattern starts with infix: "
        !           474:                                         ^ name(s));
        !           475:                           simpleId(getSymbol()))
        !           476:                  | OP => simpleId(opid())
        !           477:                  | IDDOT s => useCon(qid lookCONinStr)
        !           478:                  | _ => apat()
        !           479:           end
        !           480: 
        !           481:        and pat_id(id) = 
        !           482:           (case lookCON id
        !           483:             of dcon as DATACON{const=true,...} => CONpat(dcon)
        !           484:              | _ => (complain("nonconstant data constructor: " ^ name(id));
        !           485:                      WILDpat))
        !           486:           handle Unbound => VARpat(newVAR(bl,id))
        !           487: 
        !           488:        and apat() = 
        !           489:           case !nextToken
        !           490:             of OP      => pat_id(opid())
        !           491:              | ID s    => pat_id(nonfix_ident())
        !           492:              | IDDOT s   => CONpat(qid(lookCONinStr))
        !           493:              | INT i   => INTpat(i) before advance()
        !           494:              | REAL s  => REALpat(s) before advance()
        !           495:              | STRING s => STRINGpat(s) before advance()
        !           496:              | WILD    => (advance(); WILDpat)
        !           497:              | LPAREN =>  (advance(); pat_paren())
        !           498:              | LBRACKET => (advance(); pat_bracket())
        !           499:              | LBRACE =>  (advance(); pat_brace())
        !           500:              | tok => (complain("expected an atomic pattern, found " 
        !           501:                                 ^ tokenName tok); WILDpat)
        !           502: 
        !           503:        and pat_paren () =
        !           504:            if at(RPAREN)
        !           505:               then unitPat
        !           506:               else let val p = pat0()
        !           507:                     in case !nextToken of
        !           508:                            RPAREN => (advance(); p)
        !           509:                          | COMMA =>
        !           510:                             (advance();
        !           511:                              TUPLEpat(p::pat_pc()) before checkToken(RPAREN))
        !           512:                          | tok => (complain ("expected right paren or comma\
        !           513:                                   \ (in pattern), found " ^ tokenName tok);
        !           514:                                  p)
        !           515:                    end
        !           516: 
        !           517:        and pat_bracket () =
        !           518:           LISTpat(if at(RBRACKET)
        !           519:                     then nil
        !           520:                     else pat_pc() before checkToken(RBRACKET))
        !           521: 
        !           522: (* bug:  we allow  {a,b,c} to stand for {a=a,b=b,c=c} but we don't
        !           523:     allow {a as zzz} to stand for {a=a as zzz}
        !           524: *)
        !           525: 
        !           526:        and pat_id_as id =
        !           527:            let val e = pat_id id
        !           528:                 val e' = if at(COLON) then CONSTRAINTpat(e,ty()) else e
        !           529:             in if at(AS) then LAYEREDpat(e',pat0()) else e'
        !           530:            end
        !           531: 
        !           532:        and pat_brace () =
        !           533:           let val (_,sl,dots) = labels(pat0,EQUAL,true,pat_id_as)
        !           534:            in RECORDpat{
        !           535:                 fields = map (fn(id,pat,_) => (id,pat)) sl,
        !           536:                 flex = dots,
        !           537:                 typ = ref UNDEFty,
        !           538:                 pats = ref nil}
        !           539:           end
        !           540: 
        !           541:        and pat_pc() = rightAssoc(pat0,COMMA,op::,single)
        !           542: 
        !           543:     in if full then pat0() else apat()
        !           544:    end
        !           545: 
        !           546: (* variable bindings *)
        !           547: 
        !           548: and recdec x = VALRECdec(rvb_pa x)
        !           549: and valdec x = VALdec(vb_pa x)
        !           550: and vb x = markdec (if at(REC) then recdec else valdec) x    
        !           551: 
        !           552: and vb_pa (stamps) =
        !           553:     let val bl = ref nil : (symbol * var) list ref
        !           554:        fun vb () = 
        !           555:            protect(protectTyvars(NONE),
        !           556:              (fn () =>
        !           557:                let val pat = pat(bl,true)
        !           558:                              handle Clausal(id,_) =>
        !           559:                                condemn("undefined op in pattern: "^name id)
        !           560:                    and exp = (checkToken(EQUAL); exp(stamps))
        !           561:                    and tvs = currentTyvars()
        !           562:                 in case (pat,exp)
        !           563:                      of (CONSTRAINTpat(VARpat(VALvar{name as [n],typ,...}), ty),
        !           564:                           VARexp(ref(VALvar{access as INLINE _,...})))
        !           565:                           => let val _::rest = !bl
        !           566:                                  val w = VALvar{name=name,typ=typ,access=access}
        !           567:                               in bl := (n,w) :: rest;
        !           568:                                  VB{pat=CONSTRAINTpat(VARpat w, ty),
        !           569:                                     exp=exp,tyvars=tvs}
        !           570:                              end
        !           571: 
        !           572:                       | (VARpat(VALvar{name as [n],typ,...}),
        !           573:                           VARexp(ref(VALvar{access as INLINE _,...})))
        !           574:                           => let val _::rest = !bl
        !           575:                                  val w = VALvar{name=name,typ=typ,access=access}
        !           576:                               in bl := (n,w) :: rest;
        !           577:                                  VB{pat=VARpat w, exp=exp, tyvars=tvs}
        !           578:                              end
        !           579:                       | _ => VB{pat=pat,exp=exp,tyvars=tvs}
        !           580:                end))
        !           581:      in andListProtect(vb)
        !           582:        before bindVARs(!bl)
        !           583:     end
        !           584: 
        !           585: and rvb_pa (stamps) = 
        !           586:     let val bl = ref nil : (symbol * var) list ref
        !           587:        fun rvb () =  protect(protectTyvars(NONE),
        !           588:              (fn () =>  (* record bug *)
        !           589:                let val var=newVAR(bl,opid())
        !           590:                    and resultty=constraint_op()
        !           591:                    and e = (checkToken(EQUAL); exp stamps)
        !           592:                    and tvs=currentTyvars()
        !           593:                 in case e of FNexp _ => ()
        !           594:                       | MARKexp(FNexp _,_,_) => ()
        !           595:                       | _ => complain "fn expression required in val rec declaration";
        !           596:                    RVB{var = var, resultty = resultty, exp = e, tyvars = tvs}
        !           597:                end))
        !           598:      in protect(protectPatchList, (fn()=>
        !           599:          protect(protectScope, (fn()=>
        !           600:            (openRec(); andListProtect(rvb)) ))
        !           601:          before bindVARs(!bl) ))
        !           602:     end
        !           603: 
        !           604: and fb_pa (stamps) = 
        !           605:     let val bl = ref nil : (symbol * var) list ref
        !           606:        fun fb () = protect(protectTyvars(NONE),
        !           607:          (fn () =>
        !           608:             let val funSymbol: symbol option ref = ref NONE
        !           609:                 val clauses=rightAssoc((fn () => clause funSymbol stamps),
        !           610:                                        BAR,op::,single)
        !           611:                 val CLAUSE{pats=p1,...}::_ = clauses
        !           612:                 val len = length p1
        !           613:              in if exists (fn CLAUSE{pats,...} => length pats <> len) clauses
        !           614:                  then complain "not all clauses have the same number of patterns"
        !           615:                  else ();
        !           616:                 FB{var = let val SOME id = !funSymbol in newVAR(bl,id) end,
        !           617:                    clauses = clauses,
        !           618:                    tyvars = currentTyvars()} 
        !           619:             end))
        !           620:      in protect(protectPatchList, fn()=>
        !           621:          protect(protectScope, fn()=>
        !           622:            (openRec(); markdec (FUNdec o andListProtect) fb))
        !           623:          before bindVARs(!bl))
        !           624:     end
        !           625: 
        !           626: and clause funsym stamps = 
        !           627:     let val bl = ref nil : (symbol * var) list ref
        !           628:         fun pat_p () = if firstApat lookFIX (!nextToken)
        !           629:                         then (pat(bl,false)  (* atomic pattern *)
        !           630:                               handle Clausal(id,_) =>
        !           631:                                 condemn("undefined op in pattern: "^name id))
        !           632:                              :: pat_p ()
        !           633:                         else nil
        !           634:      in (pat(bl,true); condemn("no defined function in clausal lhs"))
        !           635:        handle Clausal(id,pat1) =>
        !           636:           (case !funsym
        !           637:             of NONE => funsym := SOME id
        !           638:              | SOME f => if Symbol.eq(id,f) then ()
        !           639:                            else complain "identifiers in clauses don't match";
        !           640:           let val pats = pat1::pat_p()
        !           641:               val resultty = constraint_op()
        !           642:               val exp = protect(protectScope,
        !           643:                           (fn()=>(checkToken(EQUAL);
        !           644:                                   if !nextToken=DARROW then advance() else (); 
        !           645:                                   bindVARs(!bl); markexp exp stamps)))
        !           646:            in CLAUSE{pats=pats, resultty=resultty, exp=exp}
        !           647:           end)
        !           648:     end
        !           649: 
        !           650: and constraint () = (checkToken(COLON); ty())
        !           651: 
        !           652: and constraint_op() =
        !           653:     if at(COLON)
        !           654:     then SOME(ty())
        !           655:     else NONE
        !           656: 
        !           657: and tb(notwith,path,stamps: Stampset.stampsets) = 
        !           658:     let        fun tb1() =
        !           659:            let fun equalargs([],[]) = true
        !           660:                  | equalargs(tv::rest,VARty(tv')::rest') =
        !           661:                      tv = tv' andalso equalargs(rest,rest')
        !           662:                  | equalargs _ = false
        !           663:                val args = tyvars()
        !           664:                val name = ident()
        !           665:                val _ = checkToken(EQUAL)
        !           666:                val typ = protect(protectTyvars(SOME args), ty)
        !           667:                val _ = TypesUtil.bindTyvars args;
        !           668:                val binding =
        !           669:                      case typ
        !           670:                        of CONty(tycref as ref(TYCON{stamp,arity,eq,path=path',kind}),
        !           671:                                 args') =>
        !           672:                             if Stampset.tycFixed(stamp) andalso equalargs(args,args')
        !           673:                             then case kind
        !           674:                                    of UNDEFtyc _ =>
        !           675:                                        (tycref :=
        !           676:                                          TYCON{stamp=stamp,arity=arity,eq=eq,
        !           677:                                                path=path',
        !           678:                                                kind=UNDEFtyc(SOME(name::path))};
        !           679:                                         tycref)
        !           680:                                     | _ => ref(TYCON{stamp=stamp,arity=arity,eq=eq,
        !           681:                                                      path=name::path,kind=kind})
        !           682:                             else ref(mkDEFtyc(name::path,
        !           683:                                               TYFUN{arity=length args, body=typ},
        !           684:                                               if notwith 
        !           685:                                               then if isEqType typ then YES else NO
        !           686:                                               else MAYBE,
        !           687:                                               stamps))
        !           688:                         | _ => ref(mkDEFtyc(name::path,
        !           689:                                             TYFUN{arity=length args, body=typ},
        !           690:                                             if notwith 
        !           691:                                             then if isEqType typ then YES else NO
        !           692:                                             else MAYBE,
        !           693:                                             stamps))
        !           694:             in bindTYC(name,binding);
        !           695:                TB{tyc=binding,def=typ}
        !           696:            end
        !           697:      in TYPEdec(andList(tb1))
        !           698:     end
        !           699: 
        !           700: and tyvars() =
        !           701:     case !nextToken
        !           702:       of Token.TYVAR s => [mkTyvar(mkUBOUND(s))] before advance()
        !           703:        | LPAREN =>
        !           704:            (advance();
        !           705:             tyvar_pc() before
        !           706:             checkToken(RPAREN))
        !           707:        | _ => nil
        !           708: 
        !           709: and tyvar_pc() = rightAssoc(tyvar,COMMA,op::,single)
        !           710: 
        !           711: and tyvar() = mkTyvar(mkUBOUND(
        !           712:               case !nextToken
        !           713:                of Token.TYVAR s => (advance(); s)
        !           714:                 | tok => (complain ("expected type variable, found "
        !           715:                                    ^ tokenName tok); bogusID)))
        !           716: 
        !           717: and db(path,stamps) =
        !           718:     let val (datatycs,withtycs) =
        !           719:                protect(protectDb(), (fn()=>
        !           720:                  (andList(db1(ty,path,stamps)),
        !           721:                   if at(WITHTYPE)
        !           722:                   then let val TYPEdec x = tb(false,path,stamps) in x end
        !           723:                   else nil)))
        !           724:        val checkeq = defineEqTycon (fn x => x)
        !           725:      in app (fn (ref tyc) => checkeq tyc) datatycs;
        !           726:        app (fn TB{tyc,...} => checkeq(!tyc)) withtycs;
        !           727:        DATATYPEdec{datatycs=datatycs,withtycs=withtycs}
        !           728:     end
        !           729: 
        !           730: and db1(parsety,path,stamps) () =
        !           731:     let val args = tyvars()
        !           732:        val name = ident()
        !           733:        val arity = length args
        !           734:        val rangeType = CONty(!lookArTYC(name,arity), map VARty args)
        !           735:        fun constr() =
        !           736:            let val sym = (if at OP
        !           737:                           then warn "unnecessary op in datatype declaration"
        !           738:                           else ();
        !           739:                           ident())
        !           740:                val const = not(at(OF))
        !           741:                val typ = if const then rangeType
        !           742:                                else CONty(arrowTycon, [parsety(), rangeType])
        !           743:             in (sym,const,typ)
        !           744:             end
        !           745:      in protect(protectTyvars(SOME args),
        !           746:         (fn()=>
        !           747:           let val dcl = (checkToken(EQUAL); rightAssoc(constr,BAR,op::,single))
        !           748:               val sdcl = sort3 dcl
        !           749:               val sign = ConRep.boxed(sdcl)
        !           750:                fun binddcons ((sym,const,typ)::restdcl,rep::restsign) =
        !           751:                   let val dcon =
        !           752:                       DATACON{name = sym, const = const, rep = rep, sign = sign,
        !           753:                               typ = if arity > 0
        !           754:                                     then ref(POLYty
        !           755:                                           {sign=mkPolySign arity,
        !           756:                                            tyfun=TYFUN{arity=arity,body=typ}})
        !           757:                                     else ref typ}
        !           758:                    in bindCON(sym, dcon);
        !           759:                       dcon :: binddcons(restdcl,restsign)
        !           760:                   end
        !           761:                 | binddcons ([],[]) = []
        !           762:                 | binddcons _ = impossible "Parse.db1.fn.binddcons"
        !           763:             in if length sdcl < length dcl
        !           764:                    then complain "duplicate constructor name" else ();
        !           765:                TypesUtil.bindTyvars args;
        !           766:                let val tycref = ref(mkDATAtyc(name::path,arity,
        !           767:                                               binddcons(sdcl,sign),MAYBE,stamps))
        !           768:                 in bindTYC(name,tycref);
        !           769:                    tycref
        !           770:                end
        !           771:            end))
        !           772:     end
        !           773: 
        !           774: and ab(path,stamps) =
        !           775:     let val mAbstype = openScope()
        !           776:        val DATATYPEdec{datatycs,withtycs} = db(path,stamps)
        !           777:        val withtycons = map (fn TB{tyc,...} => tyc) withtycs
        !           778:        val abstycs = makeAbstract(datatycs,withtycons)
        !           779:        val mWith = (openScope(); current())
        !           780:        val body = (checkToken(WITH); ldecs(path,stamps))
        !           781:        fun bind tyc = bindTYC(tycName(!tyc), tyc)
        !           782:      in checkToken(END);
        !           783:        splice(mAbstype,mWith);
        !           784:        app bind datatycs (* abstycs *);
        !           785:        app bind withtycons;
        !           786:        ABSTYPEdec{abstycs=datatycs,withtycs=withtycs,body=body}
        !           787:     end
        !           788: 
        !           789: and eb() = EXCEPTIONdec(andList(eb1))
        !           790: 
        !           791: and eb1() =
        !           792:     let val name = ident()
        !           793: (* Capitalization convention
        !           794:        val _ = if looksLikeExn name then ()
        !           795:                else warn "Exception name should be capitalized"
        !           796: *)
        !           797:      in case !nextToken
        !           798:          of OF =>
        !           799:              (advance();
        !           800:               let val etype = ty()
        !           801:                   val exn = DATACON{name = name,
        !           802:                                     const = false,
        !           803:                                     typ = ref(etype --> exnTy),
        !           804:                                     rep = VARIABLE(LVAR(namedLvar(name))),
        !           805:                                     sign = []}
        !           806:                in bindCON(name,exn);
        !           807:                   EBgen{exn=exn,etype=SOME etype}
        !           808:               end)
        !           809:           | EQUAL =>
        !           810:               (advance();
        !           811:                let val edef as DATACON{const,typ,rep,sign,...} = 
        !           812:                        case !nextToken
        !           813:                          of IDDOT s => qid lookEXNinStr
        !           814:                           | ID s => getEXN(getSymbol())
        !           815:                           | tok =>
        !           816:                             (complain("expected exception name, found token"
        !           817:                                       ^ tokenName tok);
        !           818:                              unboundEXN(bogusID))
        !           819:                    val exn = DATACON{name=name,const=const,typ=ref(!typ),sign=sign,
        !           820:                                      rep=VARIABLE(LVAR(namedLvar(name)))}
        !           821:                 in bindCON(name,exn);
        !           822:                    EBdef{exn=exn,edef=edef}
        !           823:                end)
        !           824:           | _ =>
        !           825:               let val exn = DATACON{name = name,
        !           826:                                     const = true,
        !           827:                                     typ = ref exnTy,
        !           828:                                     rep = VARIABLE(LVAR(namedLvar(name))),
        !           829:                                     sign = []}
        !           830:                in bindCON(name,exn);
        !           831:                   EBgen{exn=exn,etype=NONE}
        !           832:               end
        !           833:     end
        !           834: 
        !           835: 
        !           836: and ebx() = EXCEPTIONdec(andList(eb1x))
        !           837: 
        !           838: and eb1x() =
        !           839:     let val name = ident()
        !           840:        val etype = constraint_op()
        !           841:        val (const,typ) = case etype
        !           842:                              of NONE => (true,exnTy)
        !           843:                               | SOME t => if isUnitTy(t)
        !           844:                                           then (true,exnTy)
        !           845:                                           else (false,t-->exnTy)
        !           846:        val edef = if at(EQUAL)
        !           847:                   then SOME(case !nextToken
        !           848:                               of IDDOT _ => qid lookEXNinStr
        !           849:                                | ID s => getEXN(getSymbol())
        !           850:                                | _ => unboundEXN(bogusExnID) )
        !           851:                   else NONE
        !           852:         val exn = case edef
        !           853:                    of NONE => 
        !           854:                         DATACON{name=name, const=const, typ=ref typ,
        !           855:                                 rep=VARIABLE(LVAR(namedLvar(name))),
        !           856:                                 sign=[]}
        !           857:                     | SOME(DATACON{name=n,const,typ,rep,sign}) =>
        !           858:                            DATACON{name=name,const=const,typ=ref(!typ),rep=rep,
        !           859:                                    sign=sign}  (* changes only name *)
        !           860:      in bindCON(name, exn);
        !           861:        case edef
        !           862:          of NONE => EBgen{exn=exn,etype=etype}
        !           863:           | SOME exn' => EBdef{exn=exn,edef=exn'}
        !           864:     end
        !           865: 
        !           866: and ldec(path,stamps) =
        !           867:       case !nextToken
        !           868:        of VAL =>
        !           869:              (advance(); vb(stamps))
        !           870:          | FUN =>
        !           871:              (advance(); fb_pa(stamps))
        !           872:          | TYPE =>
        !           873:              (advance(); tb(true,path,stamps))
        !           874:          | DATATYPE =>
        !           875:              (advance(); db(path,stamps))
        !           876:          | ABSTYPE =>
        !           877:              (advance(); ab(path,stamps))
        !           878:         | EXCEPTION =>
        !           879:              (advance(); eb())
        !           880:          | Token.LOCAL =>
        !           881:             let val envLocal = openScope()
        !           882:                 val ld1 = (advance(); ldecs([],stamps))
        !           883:                 val envIn = (checkToken(IN); openScope(); current())
        !           884:                 val ld2 = ldecs(path,stamps)
        !           885:              in checkToken(END);
        !           886:                 splice(envLocal,envIn);
        !           887:                 markdec LOCALdec(ld1,ld2)
        !           888:             end
        !           889:         | Token.OPEN =>  (* confusion with Env.OPEN when Env not constrained *)
        !           890:              let val strs = (advance(); qid_p())
        !           891:               in app openStructureVar strs;
        !           892:                  markdec OPENdec strs
        !           893:              end
        !           894:          | INFIX =>
        !           895:              let val prec = case (advance(); optprec()) of SOME n=>n|NONE=>0
        !           896:               in app (fn i => bindFIX(i,FIXvar{name=i,binding=infixleft prec})) (ops());
        !           897:                  SEQdec(nil)
        !           898:              end
        !           899:          | INFIXR =>
        !           900:              let val prec = case (advance(); optprec()) of SOME n=>n|NONE=>0
        !           901:               in app (fn i => bindFIX(i,FIXvar{name=i,binding=infixright prec})) (ops());
        !           902:                  SEQdec(nil)
        !           903:              end
        !           904:          | NONFIX =>
        !           905:              (advance();
        !           906:               app (fn i => bindFIX(i,FIXvar{name=i,binding=NONfix})) (ops()); SEQdec(nil))
        !           907:         | OVERLOAD =>
        !           908:              let val id = (advance(); ident())
        !           909:                  val scheme = (checkToken(COLON);
        !           910:                    protect(protectScope, (fn () =>  (* localize tyvars *)
        !           911:                      protect(protectTyvars(NONE), (fn () =>
        !           912:                        let val body = ty()  (* generalize type variables *)
        !           913:                            val tvs = currentTyvars()
        !           914:                         in TypesUtil.bindTyvars tvs;
        !           915:                            TYFUN{arity=length(tvs),body=body}
        !           916:                        end)))))
        !           917:                  fun option() =
        !           918:                      let val VARexp(ref (v as VALvar{typ,...})) = exp(stamps)
        !           919:                       in {indicator = TypesUtil.matchScheme(scheme,!typ),
        !           920:                           variant = v}
        !           921:                      end
        !           922:                  val l = (checkToken(AS); andList(option))
        !           923:               in bindVAR(id,OVLDvar{name=id,options=ref l,scheme=scheme});
        !           924:                  SEQdec nil
        !           925:              end
        !           926:          | tok => (complain ("expected a declaration, found " ^
        !           927:                            tokenName tok); vb(stamps))
        !           928: 
        !           929: and ldecs(path_stamps) =
        !           930:   let fun ldecs() =
        !           931:       if firstLdec(!nextToken)
        !           932:         then ldec(path_stamps) :: (at(SEMICOLON); ldecs())
        !           933:         else []
        !           934:    in case ldecs() of [dec] => dec | seq => SEQdec seq
        !           935:   end
        !           936: 
        !           937: and optprec() = case !nextToken of INT i => (advance();SOME(i)) | _ => NONE
        !           938: 
        !           939: and qid_p(): structureVar list =  (* error if no identifier's ? *)
        !           940:     case !nextToken
        !           941:       of ID s => getSTR(ident()) :: qid_p()
        !           942:        | IDDOT _ => qid(lookSTRinStr)::qid_p()
        !           943:        | _ => nil
        !           944: 
        !           945: and ops() =
        !           946:   let fun ops1() =
        !           947:         case !nextToken
        !           948:           of ID s => (s) :: (advance(); ops1())
        !           949:           | EQUAL => (EQUALsym) :: (advance(); ops1())
        !           950:           | ASTERISK => (ASTERISKsym) :: (advance(); ops1())
        !           951:            | _ => nil
        !           952:    in case ops1()
        !           953:        of [] => (complain("operator or identifier expected, found "
        !           954:                  ^ tokenName (!nextToken)); [])
        !           955:          | l => l
        !           956:   end
        !           957: 
        !           958: 
        !           959: (* signatures *)
        !           960: 
        !           961: fun addzeros(0,l) = l
        !           962:   | addzeros(n,l) = addzeros(n-1,0::l)
        !           963: 
        !           964: fun sigbody(depth: int, stamps: Stampset.stampsets) : Structure = 
        !           965:     let val tComps = array(maxTypSpecs,NULLtyc)
        !           966:        and tCount = ref 0
        !           967:        fun tNext x = (update(tComps,!tCount,x);
        !           968:                       INDtyc(!tCount before inc tCount))
        !           969:        val sComps = array(maxStrSpecs,NULLstr)
        !           970:        and sCount = ref 2  (* slots 0,1 reserved for parent, fct param (if any) *)
        !           971:        fun sNext x = (update(sComps,!sCount,x);
        !           972:                       INDstr(!sCount before inc sCount))
        !           973:        val tempenv = REL{t=tComps,s=sComps}
        !           974:        fun pairs (nil : spath list list) : (spath*spath) list = nil
        !           975:          | pairs ((a::b::r) :: s) = (a,b) :: pairs((b::r) :: s)
        !           976:          | pairs ( _ :: s ) = pairs s
        !           977:        val strSharing : spath list list ref = ref nil
        !           978:        val typeSharing : spath list list ref = ref nil
        !           979: 
        !           980:         val slot = ref 0
        !           981:        fun nextSlot() = (!slot before inc slot)
        !           982: 
        !           983:        val table = newTable()
        !           984:        val tables = ref [table]
        !           985: 
        !           986:        (* includeSig used to implement include specs *)
        !           987: 
        !           988:        fun includeSig({strStamps=strStamps0, tycStamps=tycStamps0}: Stampset.stampsets,
        !           989:                       STRstr{kind=SIGkind{bindings,stamps={strStamps,tycStamps},...},
        !           990:                              env=REL{s=senv,t=tenv},...}) =
        !           991:            let val transStrStamp = Stampset.join(strStamps0,strStamps)
        !           992:                val transTycStamp = Stampset.join(tycStamps0,tycStamps)
        !           993:                val sOffset = !sCount - 2 (* offset for structure indices *)
        !           994:                val tOffset = !tCount     (* offset for tycon indices *)
        !           995: 
        !           996:                (* adjustPath(depth: int, path: int list) *)
        !           997:                fun adjustPath(0,[i]) = [i+tOffset]
        !           998:                  | adjustPath(0,i::r) = (i+sOffset) :: r
        !           999:                  | adjustPath(0,[]) = impossible "sigBody.includeSig.adjustPath"
        !          1000:                  | adjustPath(d,0::(r as _::_)) = 0 :: adjustPath(d-1,r)
        !          1001:                  | adjustPath(d,p) = p
        !          1002: 
        !          1003:                fun adjustType(depth,ty) =
        !          1004:                    let fun adjust(CONty(ref(RELtyc(p)),args)) =
        !          1005:                              CONty(ref(RELtyc(adjustPath(depth,p))), map adjust args)
        !          1006:                          | adjust(CONty(reftyc,args)) =
        !          1007:                              CONty(reftyc, map adjust args)
        !          1008:                          | adjust(POLYty{sign,tyfun=TYFUN{arity,body}}) =
        !          1009:                              POLYty{sign=sign,
        !          1010:                                     tyfun=TYFUN{arity=arity,body=adjust body}}
        !          1011:                          | adjust ty = ty
        !          1012:                     in adjust ty
        !          1013:                    end
        !          1014: 
        !          1015:                fun transTBinding depth binding =
        !          1016:                    case binding
        !          1017:                     of VARbind(VALvar{name,typ,access}) =>
        !          1018:                          VARbind(VALvar{name=name,access=access,
        !          1019:                                         typ=ref(adjustType(depth,!typ))})
        !          1020:                      | CONbind(DATACON{name,typ,const,rep,sign}) =>
        !          1021:                          CONbind(DATACON{name=name, const=const, sign=sign, rep=rep,
        !          1022:                                          typ=ref(adjustType(depth,!typ))})
        !          1023:                      | _ => binding
        !          1024: 
        !          1025:                fun transLBinding table binding =
        !          1026:                    case binding
        !          1027:                     of VARbind(VALvar{name=[n],typ,access}) =>
        !          1028:                          IntStrMap.map table (NameSpace.varKey n)
        !          1029:                      | CONbind(DATACON{name,typ,const,rep,sign}) =>
        !          1030:                          IntStrMap.map table (NameSpace.conKey name)
        !          1031:                      | _ => binding
        !          1032: 
        !          1033:                fun newTyc(tyc as TYCON{stamp,kind,...}) =
        !          1034:                    if Stampset.tycFixed(stamp)
        !          1035:                    then tyc
        !          1036:                    else (case kind
        !          1037:                           of ABStyc => setTycStamp(transTycStamp(stamp),tyc)
        !          1038:                            | DATAtyc _ => setTycStamp(transTycStamp(stamp),tyc)
        !          1039:                            | _ => tyc)
        !          1040:                  | newTyc _ = impossible "Parse.includeSig.newTyc"
        !          1041: 
        !          1042:                fun newEnv(depth,REL{s,t}) =
        !          1043:                     REL{s=mapSubstrs(newStr depth,s), t=ArrayExt.map(newTyc,t,0)}
        !          1044:                  | newEnv _ = impossible "Parse.includeSig.newEnv"
        !          1045: 
        !          1046:                and newStr depth (str as STRstr{stamp,sign,table,env,
        !          1047:                                                kind=SIGkind{stamps,share,bindings}}) =
        !          1048:                    if Stampset.strFixed(stamp)
        !          1049:                    then str
        !          1050:                    else let val newenv as REL{s,t} = newEnv(depth+1,env)
        !          1051:                             val newtable =
        !          1052:                                 IntStrMap.transform (transTBinding depth) table
        !          1053:                             val new =
        !          1054:                                 STRstr{stamp=transStrStamp(stamp),
        !          1055:                                        table=newtable,
        !          1056:                                        kind=SIGkind{stamps=stamps,share=share,
        !          1057:                                                     bindings=map
        !          1058:                                                              (transLBinding newtable)
        !          1059:                                                              bindings},
        !          1060:                                              env=newenv, sign=sign}
        !          1061:                          in ArrayExt.app(ModUtil.resetParent new, s, 2);
        !          1062:                             new
        !          1063:                         end
        !          1064:                  | newStr _ (INDstr i) = impossible("sigbody.newStr INDstr "^
        !          1065:                                                   makestring i)
        !          1066:                  | newStr _ (SHRstr _) = impossible "sigbody.newStr SHRstr"
        !          1067:                  | newStr _ (NULLstr) = impossible "sigbody.newStr NULLstr"
        !          1068:                  | newStr _ _ = impossible "sigbody.newStr STRkind"
        !          1069: 
        !          1070:                fun adjustBinding binding =
        !          1071:                    case binding
        !          1072:                     of VARbind(VALvar{name=[n],typ,...}) =>
        !          1073:                          bindVAR(n,VALvar{name=[n],typ=ref(adjustType(0,!typ)),
        !          1074:                                           access=SLOT(nextSlot())})
        !          1075:                      | CONbind(DATACON{name,typ,const,rep as VARIABLE(SLOT _),sign}) =>
        !          1076:                          bindCON(name,DATACON{name=name,
        !          1077:                                               const=const,
        !          1078:                                               sign=sign,
        !          1079:                                               typ=ref(adjustType(0,!typ)),
        !          1080:                                               rep=VARIABLE(SLOT(nextSlot()))})
        !          1081:                      | CONbind(DATACON{name,typ,const,rep,sign}) =>
        !          1082:                          bindCON(name,DATACON{name=name,
        !          1083:                                               const=const,
        !          1084:                                               sign=sign,
        !          1085:                                               typ=ref(adjustType(0,!typ)),
        !          1086:                                               rep=rep})
        !          1087:                      | TYCbind(ref(INDtyc i)) =>
        !          1088:                          let val tyc = tenv sub i
        !          1089:                              val name = tycName tyc
        !          1090:                           in bindTYC(name,ref(tNext(newTyc(tyc))))
        !          1091:                          end
        !          1092:                      | STRbind(STRvar{name as [n],binding=INDstr i,...}) =>
        !          1093:                          bindSTR(n,STRvar{name=name,
        !          1094:                                           binding=sNext(newStr 1 (senv sub i)),
        !          1095:                                           access=SLOT(nextSlot())})
        !          1096:                      | FIXbind(fixvar as FIXvar{name,...}) =>
        !          1097:                          bindFIX(name,fixvar)
        !          1098:                      | _ => impossible "sigBody.adjustBinding"
        !          1099: 
        !          1100:             in map adjustBinding bindings
        !          1101:            end (* includeSig *)
        !          1102:          | includeSig _ = impossible "Parse.includeSig - bad arg"
        !          1103: 
        !          1104:         (* the following four functions help implement the open spec.
        !          1105:           lookPathSTRinSig looks like it belongs in EnvAccess *)
        !          1106: 
        !          1107:        fun lookPathSTRinSig (spath as first::rest) : Structure * int list =
        !          1108:            let fun complainUnbound() =
        !          1109:                    (complain "unbound structure in signature";
        !          1110:                     print "  name: "; printSequence "." printSym spath;
        !          1111:                     newline();
        !          1112:                     raise Syntax)
        !          1113:                (* second arg of get is expected to be a signature *)
        !          1114:                fun get([id],STRstr{table,env as REL{s,...},...}) = 
        !          1115:                     (case lookSTRinTable(table,id)
        !          1116:                           handle UnboundTable => complainUnbound()
        !          1117:                       of STRvar{binding=INDstr i,...} => (s sub i, [i])
        !          1118:                        | STRvar{binding=SHRstr(p as i::r),...} =>
        !          1119:                            (getEpath(r,s sub i), p) (* not possible? *)
        !          1120:                        | _ => impossible "lookPathSTRinSig.get")
        !          1121:                  | get(id::rest,STRstr{table,env=REL{s,...},...}) =
        !          1122:                      let val STRvar{binding=INDstr k,...} =
        !          1123:                                lookSTRinTable(table,id)
        !          1124:                                handle UnboundTable => complainUnbound()
        !          1125:                          val (str,p) = get(rest, s sub k)
        !          1126:                       in (str, k::p)
        !          1127:                      end
        !          1128:                  | get([],str) = (str,[])
        !          1129:                  | get(p,NULLstr) =
        !          1130:                     impossible "sigbody.lookPathSTRinSig.get - NULLstr"
        !          1131:                  | get(p,INDstr _) =
        !          1132:                     impossible "sigbody.lookPathSTRinSig.get - INDstr"
        !          1133:                  | get(p,SHRstr _) =
        !          1134:                     impossible "sigbody.lookPathSTRinSig.get - SHRstr"
        !          1135:                  | get _ = impossible "sigbody.lookPathSTRinSig.get - bad args"
        !          1136:                fun lookInStr(str) =
        !          1137:                      (case rest
        !          1138:                         of [] => str
        !          1139:                          | _ => 
        !          1140:                            let val STRvar{binding,...} =
        !          1141:                                    lookPathinStr(str, [], spath, lookSTRinStr)
        !          1142:                             in binding
        !          1143:                            end,
        !          1144:                       [1])
        !          1145:                val leadStr = lookSTR0 first
        !          1146:                              handle Unbound => complainUnbound()
        !          1147:             in case leadStr
        !          1148:                  of (STRvar{binding=INDstr i,...},{path as h::r,strenv=REL{s,...}}) =>
        !          1149:                        if h < 0 (* indicates signature component *)
        !          1150:                        then let val (str,p) = get(rest, s sub i)
        !          1151:                              in (str,path@(i::p))
        !          1152:                             end
        !          1153:                        else lookInStr(s sub i)
        !          1154:                   | (STRvar{binding=SHRstr(i::r),...},{strenv=REL{s,...},...}) =>
        !          1155:                        lookInStr(getEpath(r, s sub i))
        !          1156:                   | (STRvar{binding as STRstr _,...},_) => lookInStr binding
        !          1157:                   | _ => impossible "sigbody.lookPathSTRinSig - leadStr"
        !          1158:            end
        !          1159:          | lookPathSTRinSig _ = impossible "sigbody.lookPathSTRinSig - bad arg"
        !          1160: 
        !          1161:        fun openStrIds(): spath list =
        !          1162:            case !nextToken
        !          1163:              of ID _ => [ident()] :: openStrIds()
        !          1164:               | IDDOT _ => symPath()::openStrIds()
        !          1165:               | _ => nil
        !          1166: 
        !          1167:        fun openStrInSig(p:spath) =
        !          1168:            case lookPathSTRinSig p
        !          1169:             of (STRstr{table,env,...},p) => openOld({path=p,strenv=env},table)
        !          1170:              | _ => impossible "openStrInSig -- bad arg"
        !          1171: 
        !          1172:         fun mergeTables tables =
        !          1173:            let val bottom::rest = rev tables
        !          1174:             in revfold
        !          1175:                  (fn (table,acc) => (IntStrMap.app (IntStrMap.add acc) table; acc))
        !          1176:                  rest bottom
        !          1177:            end
        !          1178: 
        !          1179:        fun spec_s() =
        !          1180:             if firstSpec(!nextToken)
        !          1181:                 then (spec() @ (at(SEMICOLON); spec_s()))
        !          1182:                 else nil
        !          1183: 
        !          1184:        and spec() =
        !          1185:            case !nextToken
        !          1186:              of STRUCTURE => (advance(); strspec())
        !          1187:               | DATATYPE => (advance(); dtyspec())
        !          1188:               | TYPE => (advance(); tyspec NO)
        !          1189:               | EQTYPE => (advance(); tyspec YES)
        !          1190:               | VAL => (advance(); valspec())
        !          1191:               | EXCEPTION => (advance(); exnspec())
        !          1192:               | INFIX => (advance(); infixspec(infixleft))
        !          1193:               | INFIXR => (advance(); infixspec(infixright))
        !          1194:               | NONFIX => 
        !          1195:                   (advance();
        !          1196:                    app (fn i => bindFIX(i,FIXvar{name=i,binding=NONfix})) (ops());
        !          1197:                    nil)
        !          1198:               | SHARING => (advance(); sharespec())
        !          1199:               | INCLUDE => (advance(); includespec())
        !          1200:               | Token.LOCAL => (advance(); localspec())
        !          1201:               | Token.OPEN => (advance(); openspec())
        !          1202:               | tok => condemn("expected a spec (component of signature)\
        !          1203:                        \ found " ^ tokenName tok)
        !          1204: 
        !          1205: 
        !          1206:        and localspec() =
        !          1207:            (spec_s(); checkToken(IN); spec_s() before checkToken(END))
        !          1208: 
        !          1209:        and openspec() =
        !          1210:              let val strpaths = openStrIds()
        !          1211:                  val newtable = newTable()
        !          1212:               in case strpaths
        !          1213:                   of [] => complain "no structure ids in open spec"
        !          1214:                    | _ => 
        !          1215:                       (app openStrInSig strpaths;
        !          1216:                        openNew({path=[~depth],strenv=tempenv},newtable);
        !          1217:                        tables := newtable :: !tables);
        !          1218:                  [] (* no bindings returned *)
        !          1219:              end
        !          1220: 
        !          1221:        and includespec() =
        !          1222:            let val name = ident()
        !          1223:                val SIGvar{binding,...} = lookSIG name
        !          1224:             in includeSig(stamps,binding)
        !          1225:            end
        !          1226: 
        !          1227:        and strspec() = 
        !          1228:            rightAssoc(strspec1,AND,op :: , single)
        !          1229: 
        !          1230:        and strspec1() =
        !          1231:            let val name = ident()
        !          1232:                val _ = checkToken(COLON)
        !          1233:                val sgn =
        !          1234:                  case !nextToken
        !          1235:                    of ID s =>
        !          1236:                          let val name = s before advance()
        !          1237:                              val SIGvar{binding,...} = lookSIG(name)
        !          1238:                           in ModUtil.shiftSigStamps(stamps,binding)  
        !          1239:                          end
        !          1240:                     | Token.SIG =>
        !          1241:                         (advance();
        !          1242:                          sigbody(depth+1,stamps)
        !          1243:                          before checkToken(END))
        !          1244:                     | tok => condemn("expected a signature or signature-identifier, \
        !          1245:                                      \found: "^tokenName tok)
        !          1246:             in bindSTR(name,STRvar{name=[name],access=SLOT(nextSlot()),
        !          1247:                                    binding=sNext(sgn)})
        !          1248:            end
        !          1249: 
        !          1250:        and dtyspec() =
        !          1251:            let val dtycs =
        !          1252:                 (protect(protectDb(), fn() =>
        !          1253:                      map (fn (r as ref tyc) => 
        !          1254:                            (r := tNext tyc; (TYCbind r, tyc)))
        !          1255:                        (rightAssoc(db1(ty,[],stamps),AND,op ::,single))))
        !          1256:                val tycbinds = map (fn (x,_) => x) dtycs
        !          1257:                val tycons = map (fn (_,y) => y) dtycs
        !          1258:                fun collectdcons(tyc::rest,dcbinds) =
        !          1259:                     let val TYCON{kind=DATAtyc(dcons),...} = tyc
        !          1260:                         fun binddcons(DATACON{name,...}::rest',dcbs) =
        !          1261:                              binddcons(rest',
        !          1262:                               (let val (b,_) = Env.look(NameSpace.conKey(name))
        !          1263:                                 in b::dcbs
        !          1264:                                end
        !          1265:                                handle Unbound => dcbs))
        !          1266:                           | binddcons([],dcbs) = dcbs
        !          1267:                      in collectdcons(rest,binddcons(dcons,dcbinds))
        !          1268:                     end
        !          1269:                  | collectdcons([],dcbinds) = dcbinds
        !          1270:             in app (defineEqTycon (tyconInContext tempenv)) tycons;
        !          1271:                tycbinds @ collectdcons(tycons,[])
        !          1272:            end
        !          1273: 
        !          1274:        and tyspec eq = 
        !          1275:            rightAssoc(tyspec1 eq, AND, op ::, single)
        !          1276: 
        !          1277:        and tyspec1 eq () =
        !          1278:            let val arity = length(tyvars())
        !          1279:                val name = ident()
        !          1280:                val tycref = ref(tNext(mkABStyc([name],arity,eq,stamps)))
        !          1281:             in bindTYC(name, tycref)
        !          1282:            end
        !          1283: 
        !          1284:        and valspec() =     
        !          1285:            rightAssoc(valspec1,AND,op ::,single)
        !          1286: 
        !          1287:        and valspec1() =
        !          1288:            let val name = 
        !          1289:                    (if at OP
        !          1290:                     then warn "unnecessary op in val specification"
        !          1291:                     else ();
        !          1292:                     case !nextToken
        !          1293:                      of ID s => getSymbol()
        !          1294:                       | ASTERISK => getSymbol()
        !          1295:                       | EQUAL => getSymbol()
        !          1296:                       | tok =>
        !          1297:                          (complain("val spec: expected identifier, found "
        !          1298:                           ^ tokenName tok); bogusID))
        !          1299:                val _ = checkToken(COLON)
        !          1300:                val typ =
        !          1301:                    protect(protectScope, (fn () =>
        !          1302:                      (* localize type variables *)
        !          1303:                      protect(protectTyvars(NONE), (fn () =>
        !          1304:                        let val body = ty()
        !          1305:                            val tvs = currentTyvars()
        !          1306:                         in case tvs
        !          1307:                              of [] => body
        !          1308:                               | _ =>
        !          1309:                                 let val sign = TypesUtil.bindTyvars1 tvs
        !          1310:                                  in POLYty
        !          1311:                                      {sign = sign,
        !          1312:                                       tyfun = TYFUN{arity = length tvs, 
        !          1313:                                                     body = body}}
        !          1314:                                 end
        !          1315:                        end))))
        !          1316:             in bindVAR(name,VALvar{name=[name],typ=ref typ,access=SLOT(nextSlot())})
        !          1317:            end
        !          1318: 
        !          1319:        and exnspec() = 
        !          1320:            rightAssoc(exnspec1,AND,op ::,single)
        !          1321: 
        !          1322:        and exnspec1() =
        !          1323:            let val name = ident()
        !          1324:                val (const,typ) =
        !          1325:                    if at(OF) then
        !          1326:                      (false,
        !          1327:                       protect(protectScope, (fn () =>
        !          1328:                         (* localize type variables *)
        !          1329:                         protect(protectTyvars(NONE), (fn () =>
        !          1330:                           let val body = ty()
        !          1331:                               val tvs = currentTyvars()
        !          1332:                            in case length tvs
        !          1333:                                 of 0 => body --> exnTy
        !          1334:                                  | n => 
        !          1335:                                    (TypesUtil.bindTyvars tvs;
        !          1336:                                     POLYty
        !          1337:                                      {sign = mkPolySign n,
        !          1338:                                       tyfun = TYFUN{arity = n,
        !          1339:                                                     body = body --> exnTy}})
        !          1340:                           end)))))
        !          1341:                    else (true,exnTy)
        !          1342:             in bindCON(name, DATACON{name=name, const=const, typ= ref typ,
        !          1343:                                      rep=VARIABLE(SLOT(nextSlot())),
        !          1344:                                      sign=[]})
        !          1345:            end
        !          1346: 
        !          1347:        and infixspec(mkinfix) =
        !          1348:            let val prec = case optprec() of SOME n=>n|NONE=>0
        !          1349:             in app (fn i => bindFIX(i,FIXvar{name=i,binding=mkinfix prec}))
        !          1350:                    (ops());
        !          1351:                nil
        !          1352:            end
        !          1353: 
        !          1354:        and sharespec() =
        !          1355:            (rightAssoc(sharespec1,AND,discard,discard); nil)
        !          1356: 
        !          1357:        and sharespec1() =
        !          1358:            case !nextToken
        !          1359:              of TYPE => (advance(); typeSharing := patheqn() :: !typeSharing)
        !          1360:               | ID s => strSharing := patheqn() :: !strSharing
        !          1361:               | IDDOT _ => strSharing := patheqn() :: !strSharing
        !          1362:               | tok => condemn("unexpected token after \"sharing\": "
        !          1363:                                ^tokenName tok)
        !          1364: 
        !          1365:        and patheqn() : spath list =
        !          1366:            rightAssoc(symPath,EQUAL,op ::,single)
        !          1367: 
        !          1368:         val stamp = Stampset.newStamp(#strStamps stamps)
        !          1369:        val _ = openStr()
        !          1370:        val _ = openNew({path=[~depth],strenv=tempenv},table)
        !          1371:        val savedlookArTYC = !lookArTYC
        !          1372:        val savedlookPathArTYC = !lookPathArTYC
        !          1373:        val bindings = protect(
        !          1374:                 ((fn () => (lookArTYC := lookArTYCinSig depth;
        !          1375:                             lookPathArTYC :=
        !          1376:                               lookPathArTYCinSig depth)),
        !          1377:                  (fn () => (lookArTYC := savedlookArTYC;
        !          1378:                             lookPathArTYC := savedlookPathArTYC))),
        !          1379:                 spec_s)
        !          1380:        val _ = closeStr()
        !          1381:        val table = mergeTables(!tables)
        !          1382:        val senv = ArrayExt.copy(sComps,!sCount)
        !          1383:        val env = REL{s=senv, t=ArrayExt.copy(tComps,!tCount)}
        !          1384:        val sShare = pairs(!strSharing)
        !          1385:        val tShare = pairs(!typeSharing)
        !          1386:        val shareSpec =
        !          1387:              if null sShare andalso null tShare
        !          1388:              then {s=[],t=[]}
        !          1389:              else Sharing.doSharing(table,env,stamps,{s=sShare,t=tShare})
        !          1390:        val result =
        !          1391:              STRstr{stamp=stamp,
        !          1392:                     sign=Stampset.newStamp(Stampset.sigStamps),
        !          1393:                     table=table,
        !          1394:                     env=env,
        !          1395:                     kind=SIGkind{share=shareSpec,
        !          1396:                                  bindings=bindings,
        !          1397:                                  stamps=stamps}}
        !          1398:      in ArrayExt.app((ModUtil.setParent result),senv,2);
        !          1399:        result
        !          1400:     end (* fun sigbody *)
        !          1401: 
        !          1402: fun sign () : Structure =
        !          1403:     case !nextToken
        !          1404:       of ID s =>
        !          1405:            let val name = s before advance()
        !          1406:                val SIGvar{binding,...} = lookSIG(name)
        !          1407:             in binding
        !          1408:            end
        !          1409:        | Token.SIG =>
        !          1410:           (advance();
        !          1411:            sigbody(1,Stampset.newStampsets())
        !          1412:            before checkToken(END))
        !          1413:        | tok => condemn("expected a signature or signature-identifier, \
        !          1414:                        \found: "^tokenName tok)
        !          1415: 
        !          1416: fun sigconstraint () =
        !          1417:     (checkToken(COLON);
        !          1418:      sign())
        !          1419: 
        !          1420: fun sigconstraint_op () =
        !          1421:     if !nextToken = COLON
        !          1422:     then (advance(); SOME(sign()))
        !          1423:     else NONE
        !          1424: 
        !          1425: (* signature bindings *)
        !          1426: 
        !          1427: fun sigb() = 
        !          1428:     let fun sigb1() =
        !          1429:            let val name = ident()
        !          1430:             in checkToken(EQUAL);
        !          1431:                let val sigvar = SIGvar{name=name,binding=sign()}
        !          1432:                 in bindSIG(name, sigvar);
        !          1433:                    sigvar
        !          1434:                end
        !          1435:            end
        !          1436:      in rightAssoc(sigb1,AND,op ::,single)
        !          1437:     end
        !          1438: 
        !          1439: (* structure expressions *)
        !          1440: 
        !          1441: fun str(abs: bool, constraint: Structure option, path: spath,
        !          1442:        stamps: Stampset.stampsets, param: Structure)
        !          1443:        : strexp * Structure * thinning =
        !          1444:     case !nextToken
        !          1445:       of IDDOT _ =>
        !          1446:           let val strVar as STRvar{binding,...} = qid(lookSTRinStr)
        !          1447:            in case constraint
        !          1448:                 of NONE => (VARstr strVar, binding, NONE)
        !          1449:                  | SOME sgn =>
        !          1450:                      let val (str,thin) =
        !          1451:                            SigMatch.match(abs,path,stamps,sgn,binding,param)
        !          1452:                       in (VARstr strVar, str, thin)
        !          1453:                      end
        !          1454:           end
        !          1455:        | Token.STRUCT => 
        !          1456:           (advance();
        !          1457:            let val _ = openStr()
        !          1458:                val body = sdecs(path,stamps)
        !          1459:             in (case constraint
        !          1460:                   of NONE =>
        !          1461:                       let val (thin,table) = BuildMod.buildStrTable ()
        !          1462:                        in (STRUCTstr{body=body,locations=thin},
        !          1463:                            mkSTR(path,table,DIR,stamps),
        !          1464:                            NONE)
        !          1465:                       end
        !          1466:                    | SOME sgn => 
        !          1467:                       let val (str,thin) =
        !          1468:                                 SigMatch.realize(abs,path,stamps,
        !          1469:                                    Stampset.newStamp(#strStamps stamps),
        !          1470:                                    sgn,param)
        !          1471:                        in closeStr();
        !          1472:                           (STRUCTstr{body=body,locations=thin}, str, NONE)
        !          1473:                       end)
        !          1474:                before checkToken(END)
        !          1475:            end)
        !          1476:        | ID s => 
        !          1477:           let val id = getSymbol()
        !          1478:            in if at(LPAREN)  (* functor application *)
        !          1479:               then let val fctVar as FCTvar{binding=fct,...} = lookFCT id
        !          1480:                        val (argexp,argstr) =
        !          1481:                              (* parse arg without using parameter sig *)
        !          1482:                             (if !nextToken = RPAREN
        !          1483:                              then (STRUCTstr{body=[],locations=[]},nullStr)
        !          1484:                              else if firstSdec(!nextToken)
        !          1485:                              then let val _ = openStr()
        !          1486:                                       val body = sdecs([anonParamName],stamps)
        !          1487:                                       val (thin,table) = BuildMod.buildStrTable ()
        !          1488:                                    in (STRUCTstr{body=body,locations=thin},
        !          1489:                                        mkSTR([anonParamName],table,
        !          1490:                                              DIR,stamps))
        !          1491:                                   end
        !          1492:                              else let val FUNCTOR{paramName,...} = fct
        !          1493:                                       val (strexp,str,_) =
        !          1494:                                             str(false,NONE,[paramName],stamps,NULLstr)
        !          1495:                                    in (strexp,str)
        !          1496:                                   end)
        !          1497:                             before checkToken(RPAREN)
        !          1498:                        val (result,thin1) = 
        !          1499:                              Functor.applyFunctor(fct,argstr,path,stamps)
        !          1500:                        val strexp = APPstr{oper=fctVar,
        !          1501:                                            argexp=argexp,
        !          1502:                                            argthin=thin1}
        !          1503:                     in case constraint
        !          1504:                          of NONE => (strexp,result,NONE)
        !          1505:                           | SOME sgn =>
        !          1506:                               let val (thinned,thin2) =
        !          1507:                                       SigMatch.match(abs,path,stamps,sgn,result,param)
        !          1508:                                in (strexp,thinned,thin2)
        !          1509:                               end
        !          1510:                    end
        !          1511:               else let val strVar as STRvar{binding,...} = getSTR id
        !          1512:                     in case constraint
        !          1513:                         of NONE => (VARstr strVar, binding, NONE)
        !          1514:                          | SOME sgn =>
        !          1515:                             let val (str,thin) =
        !          1516:                                     SigMatch.match(abs,path,stamps,sgn,binding,param)
        !          1517:                              in (VARstr strVar, str, thin)
        !          1518:                             end
        !          1519:                    end
        !          1520:           end
        !          1521:        | LET => protect(protectScope,
        !          1522:                    (fn()=>(advance();
        !          1523:                            let val locals = sdecs(path,stamps)
        !          1524:                                val _ = checkToken(IN)
        !          1525:                                val (bodyexp,bodystr,thin) =
        !          1526:                                      str(abs,constraint,path,stamps,param)
        !          1527:                                val _ = checkToken(END)
        !          1528:                             in (LETstr(SEQdec(locals),bodyexp),bodystr,thin)
        !          1529:                            end)))
        !          1530:        | tok => condemn("expected a structure-expression, found " ^
        !          1531:                         tokenName tok)
        !          1532: 
        !          1533: and sdecs(args as (path: spath, stamps: Stampset.stampsets))
        !          1534:          : dec list =
        !          1535:     let fun sdec() : dec =
        !          1536:            if at(STRUCTURE)
        !          1537:              then markdec STRdec(strb(false,path,stamps))
        !          1538:            else if at(ABSTRACTION)
        !          1539:              then markdec ABSdec(strb(true,path,stamps))
        !          1540:            else if at(SIGNATURE)   (* monster structure hack *)
        !          1541:              then (warn "signature found inside structure";
        !          1542:                    SIGdec(sigb()))
        !          1543:            else if at(Token.FUNCTOR)   (* monster structure hack *)
        !          1544:              then (warn "functor found inside structure";
        !          1545:                    markdec FCTdec(fctb()))
        !          1546:            else if at Token.LOCAL
        !          1547:              then let val envLocal = openScope()
        !          1548:                       val ld1 = sdecs args
        !          1549:                       val envIn = (checkToken(IN); openScope(); current())
        !          1550:                       val ld2 = sdecs args
        !          1551:                    in checkToken(END);
        !          1552:                       splice(envLocal,envIn);
        !          1553:                       markdec LOCALdec(SEQdec ld1,SEQdec ld2)
        !          1554:                   end
        !          1555:            else let val dec = ldec(path,stamps)
        !          1556:                  in Typecheck.decType(dec);
        !          1557:                     dec
        !          1558:                 end
        !          1559:      in if firstSdec(!nextToken)
        !          1560:        then sdec() :: (at(SEMICOLON); sdecs(args))
        !          1561:        else nil
        !          1562:     end
        !          1563: 
        !          1564: (* structure bindings *)
        !          1565: 
        !          1566: and strb(abstract:bool,path:spath,stamps:Stampset.stampsets) =
        !          1567:     let fun strb1() =
        !          1568:        let val name = ident()
        !          1569:            val constraint = 
        !          1570:                  if abstract
        !          1571:                  then SOME(sigconstraint())
        !          1572:                  else sigconstraint_op()
        !          1573:            val _ = checkToken(EQUAL) 
        !          1574:            val (strexp,str,thin) =
        !          1575:                  str(abstract,constraint,name::path,stamps,NULLstr)
        !          1576:            val strVar = STRvar{access=LVAR(namedLvar(name)),
        !          1577:                                name=[name],
        !          1578:                                binding=str}
        !          1579:         in (name, strVar,
        !          1580:             STRB{strvar=strVar, def=strexp, constraint=constraint, thin=thin})
        !          1581:        end
        !          1582:      in map (fn (name,strVar,strSyn) => (bindSTR(name,strVar); strSyn))
        !          1583:            (rightAssoc(strb1, AND, op ::, single))
        !          1584:     end
        !          1585: 
        !          1586: 
        !          1587: (* functor bindings *)
        !          1588: 
        !          1589: and fctb() =
        !          1590:     map (fn (name,fctVar,fctSyn) => (bindFCT(name,fctVar); fctSyn))
        !          1591:        (rightAssoc(fctb1, AND, op ::, single))
        !          1592: 
        !          1593: and fctb1() =
        !          1594:     let val name = ident()
        !          1595:        val mEntry = openScope()
        !          1596:        val (pname,paccess,param,spreadParams) =
        !          1597:             (checkToken(LPAREN);
        !          1598:              (case !nextToken
        !          1599:                of RPAREN => (anonParamName,LVAR(namedLvar(anonParamName)),nullSig,
        !          1600:                              false)
        !          1601:                 | ID s => let val tenv = array(0, NULLtyc)
        !          1602:                               val senv = array(2, NULLstr)
        !          1603:                               val _ = openNew({path=[~1], strenv=REL{t=tenv,s=senv}},
        !          1604:                                               newTable())
        !          1605:                               val name = ident()
        !          1606:                               val access = LVAR(namedLvar(name))
        !          1607:                               val _ = checkToken(COLON)
        !          1608:                               val param = sign()
        !          1609:                            in update(senv,1,param);
        !          1610:                               bindSTR(name,STRvar{name=[name],
        !          1611:                                                   access=access,
        !          1612:                                                   binding=INDstr(1)});
        !          1613:                               (name,access,param,false)
        !          1614:                           end
        !          1615:                 | tok => if firstSpec(tok)
        !          1616:                          then let val plvar = namedLvar(anonParamName)
        !          1617:                                   val param as STRstr{env,table,...} =
        !          1618:                                         sigbody(2,Stampset.newStampsets())
        !          1619:                                in openOld({path=[~1,1],strenv=env},table);
        !          1620:                                   (anonParamName,LVAR(plvar),param,true)
        !          1621:                               end
        !          1622:                          else condemn ("expected functor parameter spec, found "
        !          1623:                                       ^tokenName tok))
        !          1624:              before checkToken(RPAREN))
        !          1625:        val resSign = 
        !          1626:            if !nextToken = COLON
        !          1627:            then (advance(); SOME(sign()))
        !          1628:            else NONE
        !          1629:        val _ = if spreadParams
        !          1630:                then let val STRstr{table,env,...} = param
        !          1631:                         and LVAR plvar = paccess
        !          1632:                      in resetEnv(mEntry);
        !          1633:                         openOld({path=[plvar],strenv=env},table)
        !          1634:                     end
        !          1635:                else ()
        !          1636:         val _ = checkToken(EQUAL)
        !          1637:        val bodystamps = Stampset.newStampsets()
        !          1638:         val (bodyexp,bodystr,thin) = str(false,resSign,[],bodystamps,param)
        !          1639:         val openBody =
        !          1640:            case bodystr
        !          1641:              of STRstr{stamp=bodystamp,env=DIR,...} =>
        !          1642:                   Stampset.member(bodystamp,(#strStamps bodystamps))
        !          1643:               | _ => false
        !          1644:        val paramVis = 
        !          1645:            case resSign
        !          1646:              of SOME _ => true
        !          1647:               | NONE => openBody
        !          1648:        val body = 
        !          1649:            if openBody
        !          1650:            then Functor.abstractBody(bodystr,param,bodystamps,
        !          1651:                   Stampset.newStamp(Stampset.sigStamps))
        !          1652:            else bodystr
        !          1653:        val paramvar = STRvar{name = [pname], access = paccess, binding = param}
        !          1654:        val fctv = FCTvar{name=name, 
        !          1655:                          access=LVAR(namedLvar(name)),
        !          1656:                          binding=FUNCTOR{paramName=pname,
        !          1657:                                          param=param,
        !          1658:                                          body=body,
        !          1659:                                          paramVis=paramVis,
        !          1660:                                          stamps=bodystamps}}
        !          1661:        val fb = FCTB{fctvar=fctv, param=paramvar, def=bodyexp, thin=thin,
        !          1662:                      constraint=resSign}
        !          1663:      in resetEnv(mEntry);
        !          1664:        (name,fctv,fb)
        !          1665:     end
        !          1666: 
        !          1667: 
        !          1668: (* top level declarations *)
        !          1669: 
        !          1670: fun importdec()=
        !          1671:     let fun loop() = 
        !          1672:             (case !nextToken of 
        !          1673:                SEMICOLON => []
        !          1674:              | STRING s  => (advance(); s :: loop())
        !          1675:              | _ => condemn("string constant (file name) expected, found " ^
        !          1676:                             tokenName (!nextToken))
        !          1677:             )
        !          1678:         val files = loop()
        !          1679:      in case files of
        !          1680:           [] => condemn("string constant (file name) expected, found " ^
        !          1681:                             tokenName (!nextToken))
        !          1682:         | _  => files
        !          1683:     end
        !          1684: 
        !          1685: val globalStamps = Stampset.globalStamps
        !          1686: val itsym = Symbol.symbol "it"
        !          1687: 
        !          1688: fun inner_interdec() =
        !          1689:        (prompt := !System.Control.secondaryPrompt;
        !          1690:          case !nextToken
        !          1691:           of SIGNATURE => (advance(); SIGdec(sigb()))
        !          1692:            | Token.FUNCTOR => (advance(); markdec FCTdec(fctb()))
        !          1693:            | STRUCTURE =>
        !          1694:                (advance(); markdec STRdec(strb(false,[],globalStamps)))
        !          1695:            | ABSTRACTION =>
        !          1696:                (advance(); markdec STRdec(strb(true,[],globalStamps)))
        !          1697:             | IMPORT=>(advance(); IMPORTdec(importdec()))
        !          1698:            | EOF => raise Eof
        !          1699:            | tok => let val dec =
        !          1700:                             if firstLdec(!nextToken)
        !          1701:                             then ldec([],Stampset.globalStamps)
        !          1702:                             else if firstExp lookFIX (!nextToken)
        !          1703:                             then (markdec (fn() => VALdec[VB
        !          1704:                                  (protect(protectTyvars(NONE),(fn() =>
        !          1705:                                    {exp=exp(Stampset.globalStamps),
        !          1706:                                     pat=let val v = newVAR(ref nil,itsym)
        !          1707:                                          in bindVAR(itsym,v);
        !          1708:                                             VARpat v
        !          1709:                                         end,
        !          1710:                                     tyvars=currentTyvars()})))]) ())
        !          1711:                             else condemn("declaration or expression expected, found " ^
        !          1712:                                           tokenName tok)
        !          1713:                      in Typecheck.decType(dec); dec
        !          1714:                     end)
        !          1715: 
        !          1716: in inner_interdec()
        !          1717: end (* fun interdec *)
        !          1718: 
        !          1719: end (* structure Parse *)

This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.