style/SchemeParser.cxx

   1 // Copyright (c) 1996 James Clark
   2 // See the file copying.txt for copying permission.
   3
   4 #include "stylelib.h"
   5 #include "SchemeParser.h"
   6 #include "InterpreterMessages.h"
   7 #include "Pattern.h"
   8 #include "MacroFlowObj.h"
   9 #include "macros.h"
  10 #include <stdlib.h>
  11 #include "LangObj.h"
  12 #include "VM.h"
  13 #include "ELObjMessageArg.h"
  14 #include "DssslSpecEventHandler.h"
  15
  16 #ifdef DSSSL_NAMESPACE
  17 namespace DSSSL_NAMESPACE {
  18 #endif
  19
  20 const Char defaultChar = 0xfffd;
  21
  22 SchemeParser::SchemeParser(Interpreter &interp,
  23                            Owner<InputSource> &in)
  24 : interp_(&interp),
  25   defMode_(interp.initialProcessingMode()),
  26   dsssl2_(interp.dsssl2()),
  27   lang_(0)
  28 {
  29   in_.swap(in);
  30   {
  31     StringC tem(Interpreter::makeStringC("ISO/IEC 10036/RA//Glyphs"));
  32     afiiPublicId_ = interp_->storePublicId(tem.data(), tem.size(), Location());
  33   }
  34 }
  35
  36 void SchemeParser::parseStandardChars()
  37 {
  38   for (;;) {
  39     Token tok;
  40     if (!getToken(allowIdentifier|allowEndOfEntity, tok)
  41          || tok == tokenEndOfEntity)
  42       break;
  43
  44     StringC name(currentToken_);
  45
  46     if (!getToken(allowOtherExpr, tok) || tok != tokenNumber) {
  47       message(InterpreterMessages::badDeclaration);
  48       break;
  49     }
  50
  51     int i;
  52     for (i = 0; i < name.size(); i++)
  53       if (interp_->lexCategory(name[i]) != Interpreter::lexLetter
  54           && ((i == 0) ||
  55               (interp_->lexCategory(name[i]) != Interpreter::lexDigit
  56                && name[i] != '-' && name[i] != '.')))
  57         break;
  58     if (i < name.size() || name.size() == 1) {
  59       message(InterpreterMessages::invalidCharName,
  60               StringMessageArg(name));
  61       continue;
  62     }
  63
  64     for (i = 0; i < currentToken_.size(); i++)
  65       if (interp_->lexCategory(currentToken_[i]) != Interpreter::lexDigit)
  66         break;
  67
  68     if (i < currentToken_.size()) {
  69       message(InterpreterMessages::invalidCharNumber,
  70               StringMessageArg(currentToken_));
  71       continue;
  72     }
  73
  74     interp_->addStandardChar(name, currentToken_);
  75   }
  76 }
  77
  78 void SchemeParser::parseNameChars()
  79 {
  80   for (;;) {
  81     // FIXME we do not check that we have valid character names
  82     Token tok;
  83     if (!getToken(allowIdentifier|allowEndOfEntity, tok)
  84          || tok == tokenEndOfEntity)
  85       break;
  86     interp_->addNameChar(currentToken_);
  87   }
  88 }
  89
  90 void SchemeParser::parseSeparatorChars()
  91 {
  92   for (;;) {
  93     // FIXME we do not check that we have valid character names
  94     Token tok;
  95     if (!getToken(allowIdentifier|allowEndOfEntity, tok)
  96         || tok == tokenEndOfEntity)
  97       break;
  98     interp_->addSeparatorChar(currentToken_);
  99   }
 100 }
 101
 102 void SchemeParser::parseMapSdataEntity(const StringC &ename, const StringC &etext)
 103 {
 104   Token tok;
 105   if (!getToken(allowIdentifier|allowEndOfEntity, tok)
 106        || tok == tokenEndOfEntity) {
 107     message(InterpreterMessages::badDeclaration);
 108     return;
 109   }
 110
 111   interp_->addSdataEntity(ename, etext, currentToken_);
 112 }
 113
 114 void SchemeParser::parse()
 115 {
 116   bool recovering = 0;
 117   for (;;) {
 118     Token tok;
 119     if (!getToken(recovering ? ~0 : allowOpenParen|allowEndOfEntity,
 120                  tok))
 121       recovering = 1;
 122     else {
 123       if (tok == tokenEndOfEntity)
 124         break;
 125       if (tok != tokenOpenParen
 126           || !getToken(recovering ? ~0 : unsigned(allowIdentifier), tok)
 127           || tok != tokenIdentifier)
 128         recovering = 1;
 129       else {
 130         const Identifier *ident = lookup(currentToken_);
 131         Identifier::SyntacticKey key;
 132         if (!ident->syntacticKey(key)) {
 133           if (!recovering)
 134             message(InterpreterMessages::unknownTopLevelForm,
 135                     StringMessageArg(currentToken_));
 136           recovering = 1;
 137         }
 138         else {
 139           switch (key) {
 140           case Identifier::keyDefine:
 141             recovering = !doDefine();
 142             break;
 143           case Identifier::keyDefineUnit:
 144             recovering = !doDefineUnit();
 145             break;
 146           case Identifier::keyDefault:
 147             recovering = !doDefault();
 148             break;
 149           case Identifier::keyElement:
 150             recovering = !doElement();
 151             break;
 152           case Identifier::keyOrElement:
 153             recovering = !doOrElement();
 154             break;
 155           case Identifier::keyRoot:
 156             recovering = !doRoot();
 157             break;
 158           case Identifier::keyId:
 159             recovering = !doId();
 160             break;
 161           case Identifier::keyMode:
 162             recovering = !doMode();
 163             break;
 164           case Identifier::keyDeclareInitialValue:
 165             recovering = !doDeclareInitialValue();
 166             break;
 167           case Identifier::keyDeclareCharacteristic:
 168             recovering = !doDeclareCharacteristic();
 169             break;
 170           case Identifier::keyDeclareFlowObjectClass:
 171             recovering = !doDeclareFlowObjectClass();
 172             break;
 173           case Identifier::keyDeclareClassAttribute:
 174             recovering = !doDeclareClassAttribute();
 175             break;
 176           case Identifier::keyDeclareIdAttribute:
 177             recovering = !doDeclareIdAttribute();
 178             break;
 179           case Identifier::keyDeclareFlowObjectMacro:
 180             recovering = !doDeclareFlowObjectMacro();
 181             break;
 182           case Identifier::keyDeclareDefaultLanguage:
 183             recovering = !doDeclareDefaultLanguage();
 184             break;
 185           case Identifier::keyDefineLanguage:
 186             recovering = !doDefineLanguage();
 187             break;
 188           case Identifier::keyDeclareCharProperty:
 189             recovering = !doDeclareCharProperty();
 190             break;
 191           case Identifier::keyAddCharProperties:
 192             recovering = !doAddCharProperties();
 193             break;
 194           case Identifier::keyDeclareCharCharacteristicAndProperty:
 195             recovering = !doDeclareCharCharacteristicAndProperty();
 196             break;
 197           case Identifier::keyDeclareReferenceValueType:
 198           case Identifier::keyDefinePageModel:
 199           case Identifier::keyDefineColumnSetModel:
 200             recovering = !skipForm();
 201             break;
 202           default:
 203             if (!recovering)
 204               message(InterpreterMessages::unknownTopLevelForm,
 205                       StringMessageArg(currentToken_));
 206             recovering = 1;
 207             break;
 208           }
 209         }
 210       }
 211     }
 212   }
 213 #if 0
 214   NamedTableIter<Identifier> iter(identTable_);
 215   for (;;) {
 216     Identifier *ident = iter.next();
 217     if (!ident)
 218       break;
 219     Location loc;
 220     unsigned part;
 221     if (ident->defined(part, loc)) {
 222       ELObj *obj = ident->computeValue(1, *this);
 223       if (!isError(obj)) {
 224         *os_ << ident->name() << "=";
 225         obj->print(*this, *os_);
 226         *os_ << OutputCharStream::newline;
 227         os_->flush();
 228       }
 229     }
 230   }
 231 #endif
 232 }
 233
 234 bool SchemeParser::parseExpression(Owner<Expression> &expr)
 235 {
 236   Identifier::SyntacticKey key;
 237   Token tok;
 238   if (!parseExpression(0, expr, key, tok))
 239     return 0;
 240   getToken(allowEndOfEntity, tok);
 241   return 1;
 242 }
 243
 244 bool SchemeParser::doMode()
 245 {
 246   Token tok;
 247   if (!getToken(allowIdentifier, tok))
 248     return 0;
 249   defMode_ = lookupProcessingMode(currentToken_);
 250   defMode_->setDefined();
 251   for (;;) {
 252     if (!getToken(allowOpenParen|allowCloseParen, tok))
 253       return 0;
 254     if (tok == tokenCloseParen)
 255       break;
 256     if (!getToken(allowIdentifier, tok))
 257       return 0;
 258     const Identifier *ident = lookup(currentToken_);
 259     Identifier::SyntacticKey key;
 260     if (!ident->syntacticKey(key)) {
 261       message(InterpreterMessages::badModeForm,
 262               StringMessageArg(currentToken_));
 263       return 0;
 264     }
 265     else {
 266       switch (key) {
 267       case Identifier::keyDefault:
 268         if (!doDefault())
 269           return 0;
 270         break;
 271       case Identifier::keyElement:
 272         if (!doElement())
 273           return 0;
 274         break;
 275       case Identifier::keyOrElement:
 276         if (!doOrElement())
 277           return 0;
 278         break;
 279       case Identifier::keyRoot:
 280         if (!doRoot())
 281           return 0;
 282         break;
 283       case Identifier::keyId:
 284         if (!doId())
 285           return 0;
 286         break;
 287       default:
 288         message(InterpreterMessages::badModeForm,
 289                 StringMessageArg(currentToken_));
 290         return 0;
 291       }
 292     }
 293   }
 294   defMode_ = interp_->initialProcessingMode();
 295   return 1;
 296 }
 297
 298 bool SchemeParser::doElement()
 299 {
 300   Location loc(in_->currentLocation());
 301   Token tok;
 302   ELObj *obj;
 303   if (!parseDatum(0, obj, loc, tok))
 304     return 0;
 305   NCVector<Pattern> patterns(1);
 306   Owner<Expression> expr;
 307   ProcessingMode::RuleType ruleType;
 308   if (interp_->convertToPattern(obj, loc, patterns[0])) {
 309     if (!parseRuleBody(expr, ruleType))
 310       return 0;
 311     defMode_->addRule(0, patterns, expr, ruleType, loc, *interp_);
 312   }
 313   else if (!parseRuleBody(expr, ruleType))
 314     return 0;
 315   return 1;
 316 }
 317
 318 bool SchemeParser::doOrElement()
 319 {
 320   Location loc(in_->currentLocation());
 321   Token tok;
 322   if (!getToken(allowOpenParen, tok))
 323     return 0;
 324   NCVector<Pattern> patterns;
 325   unsigned allowed = 0;
 326   bool ok = 1;
 327   for (;;) {
 328     ELObj *obj;
 329     if (!parseDatum(allowed, obj, loc, tok))
 330       return 0;
 331     if (!obj)
 332       break;
 333     allowed = allowCloseParen;
 334     if (ok) {
 335       patterns.resize(patterns.size() + 1);
 336       if (!interp_->convertToPattern(obj, loc, patterns.back()))
 337         ok = 0;
 338     }
 339   }
 340   ProcessingMode::RuleType ruleType;
 341   Owner<Expression> expr;
 342   if (!parseRuleBody(expr, ruleType))
 343     return 0;
 344   if (ok)
 345     defMode_->addRule(0, patterns, expr, ruleType, loc, *interp_);
 346   return 1;
 347 }
 348
 349 bool SchemeParser::doId()
 350 {
 351   Location loc(in_->currentLocation());
 352   Token tok;
 353   if (!getToken(allowString|allowIdentifier, tok))
 354     return 0;
 355   StringC id(currentToken_);
 356   Owner<Expression> expr;
 357   ProcessingMode::RuleType ruleType;
 358   if (!parseRuleBody(expr, ruleType))
 359     return 0;
 360   IList<Pattern::Element> list;
 361   Pattern::Element *elem = new Pattern::Element(StringC());
 362   list.insert(elem);
 363   elem->addQualifier(new Pattern::IdQualifier(id));
 364   Pattern pattern(list);
 365   NCVector<Pattern> patterns(1);
 366   patterns[0].swap(pattern);
 367   defMode_->addRule(0, patterns, expr, ruleType, loc, *interp_);
 368   return 1;
 369 }
 370
 371 bool SchemeParser::doDefault()
 372 {
 373   Location loc(in_->currentLocation());
 374   Owner<Expression> expr;
 375   ProcessingMode::RuleType ruleType;
 376   if (!parseRuleBody(expr, ruleType))
 377     return 0;
 378   IList<Pattern::Element> list;
 379   list.insert(new Pattern::Element(StringC()));
 380   Pattern pattern(list);
 381   NCVector<Pattern> patterns(1);
 382   pattern.swap(patterns[0]);
 383   defMode_->addRule(0, patterns, expr, ruleType, loc, *interp_);
 384   return 1;
 385 }
 386
 387 bool SchemeParser::doRoot()
 388 {
 389   Location loc(in_->currentLocation());
 390   Owner<Expression> expr;
 391   ProcessingMode::RuleType ruleType;
 392   if (!parseRuleBody(expr, ruleType))
 393     return 0;
 394   NCVector<Pattern> patterns;
 395   defMode_->addRule(1, patterns, expr, ruleType, loc, *interp_);
 396   return 1;
 397 }
 398
 399 bool SchemeParser::parseRuleBody(Owner<Expression> &expr, ProcessingMode::RuleType &ruleType)
 400 {
 401   Token tok;
 402   Identifier::SyntacticKey key;
 403   if (!parseExpression(0, expr, key, tok))
 404     return 0;
 405   const Identifier *k = dsssl2() ? expr->keyword() : 0;
 406   if (k) {
 407     // style rule
 408     Vector<const Identifier *> keys;
 409     NCVector<Owner<Expression> > exprs;
 410     for (;;) {
 411       keys.push_back(k);
 412       exprs.resize(exprs.size() + 1);
 413       if (!parseExpression(0, exprs.back(), key, tok))
 414         return 0;
 415       if (!getToken(allowKeyword|allowCloseParen, tok))
 416         return 0;
 417       if (tok == tokenCloseParen)
 418         break;
 419       k = lookup(currentToken_);
 420     }
 421     expr = new StyleExpression(keys, exprs, expr->location());
 422     ruleType = ProcessingMode::styleRule;
 423   }
 424   else {
 425     ruleType = ProcessingMode::constructionRule;
 426     if (!getToken(allowCloseParen, tok))
 427       return 0;
 428   }
 429   return 1;
 430 }
 431
 432 bool SchemeParser::doDeclareInitialValue()
 433 {
 434   Token tok;
 435   if (!getToken(allowIdentifier, tok))
 436     return 0;
 437   Identifier *ident = lookup(currentToken_);
 438   if (ident->inheritedC().isNull())
 439     message(InterpreterMessages::notABuiltinInheritedC,
 440             StringMessageArg(ident->name()));
 441   Owner<Expression> expr;
 442   Identifier::SyntacticKey key;
 443   if (!parseExpression(0, expr, key, tok))
 444     return 0;
 445   if (!getToken(allowCloseParen, tok))
 446     return 0;
 447   if (ident->inheritedC().isNull())
 448     return 1;
 449   interp_->installInitialValue(ident, expr);
 450   return 1;
 451 }
 452
 453 bool SchemeParser::doDeclareCharCharacteristicAndProperty()
 454 {
 455   Location loc(in_->currentLocation());
 456   Token tok;
 457   if (!getToken(allowIdentifier, tok))
 458     return 0;
 459   Identifier *ident = lookup(currentToken_);
 460   if (!getToken(allowString|(dsssl2() ? unsigned(allowFalse) : 0), tok))
 461     return 0;
 462   StringC pubid;
 463   if (tok == tokenString)
 464     pubid = currentToken_;
 465   Owner<Expression> expr;
 466   Identifier::SyntacticKey key;
 467   if (!parseExpression(0, expr, key, tok))
 468     return 0;
 469   if (!getToken(allowCloseParen, tok))
 470     return 0;
 471   Location defLoc;
 472   unsigned defPart;
 473   if (ident->inheritedCDefined(defPart, defLoc)) {
 474       interp_->setNextLocation(loc);
 475       interp_->message(InterpreterMessages::duplicateCharacteristic,
 476                        StringMessageArg(ident->name()),
 477                        defLoc);
 478   }
 479   else if (ident->charNICDefined(defPart, defLoc)
 480            && defPart <= interp_->currentPartIndex()) {
 481     if (defPart == interp_->currentPartIndex()) {
 482       interp_->setNextLocation(loc);
 483       interp_->message(InterpreterMessages::duplicateCharacteristic,
 484                        StringMessageArg(ident->name()),
 485                        defLoc);
 486     }
 487   }
 488   else {
 489     interp_->installExtensionCharNIC(ident, pubid, loc);
 490     interp_->addCharProperty(ident, expr);
 491   }
 492   return 1;
 493 }
 494
 495 bool SchemeParser::doDeclareCharacteristic()
 496 {
 497   Location loc(in_->currentLocation());
 498   Token tok;
 499   if (!getToken(allowIdentifier, tok))
 500     return 0;
 501   Identifier *ident = lookup(currentToken_);
 502   if (!getToken(allowString|(dsssl2() ? unsigned(allowFalse) : 0), tok))
 503     return 0;
 504   StringC pubid;
 505   if (tok == tokenString)
 506     pubid = currentToken_;
 507   Owner<Expression> expr;
 508   Identifier::SyntacticKey key;
 509   if (!parseExpression(0, expr, key, tok))
 510     return 0;
 511   if (!getToken(allowCloseParen, tok))
 512     return 0;
 513   Location defLoc;
 514   unsigned defPart;
 515   if (ident->charNICDefined(defPart, defLoc)) {
 516       interp_->setNextLocation(loc);
 517       interp_->message(InterpreterMessages::duplicateCharacteristic,
 518                        StringMessageArg(ident->name()),
 519                        defLoc);
 520   }
 521   else if (ident->inheritedCDefined(defPart, defLoc)
 522            && defPart <= interp_->currentPartIndex()) {
 523     if (defPart == interp_->currentPartIndex()) {
 524       interp_->setNextLocation(loc);
 525       interp_->message(InterpreterMessages::duplicateCharacteristic,
 526                        StringMessageArg(ident->name()),
 527                        defLoc);
 528     }
 529   }
 530   else {
 531     interp_->installExtensionInheritedC(ident, pubid, loc);
 532     interp_->installInitialValue(ident, expr);
 533   }
 534   return 1;
 535 }
 536
 537 bool SchemeParser::doDeclareFlowObjectClass()
 538 {
 539   Location loc(in_->currentLocation());
 540   Token tok;
 541   if (!getToken(allowIdentifier, tok))
 542     return 0;
 543   Identifier *ident = lookup(currentToken_);
 544   if (!getToken(allowString, tok))
 545     return 0;
 546   Location defLoc;
 547   unsigned defPart;
 548   if (ident->inheritedCDefined(defPart, defLoc)
 549       && defPart <= interp_->currentPartIndex()) {
 550     if (defPart == interp_->currentPartIndex()) {
 551       interp_->setNextLocation(loc);
 552       interp_->message(InterpreterMessages::duplicateFlowObjectClass,
 553                        StringMessageArg(ident->name()),
 554                        defLoc);
 555     }
 556   }
 557   else
 558     interp_->installExtensionFlowObjectClass(ident, currentToken_, loc);
 559   if (!getToken(allowCloseParen, tok))
 560     return 0;
 561   return 1;
 562 }
 563
 564 bool SchemeParser::doDeclareFlowObjectMacro()
 565 {
 566   Location loc(in_->currentLocation());
 567   Token tok;
 568   if (!getToken(allowIdentifier, tok))
 569     return 0;
 570   Identifier *ident = lookup(currentToken_);
 571   if (ident->flowObj())
 572     // FIXME report an error if same part
 573     ;
 574   if (!getToken(allowOpenParen, tok))
 575     return 0;
 576   Vector<const Identifier *> nics;
 577   NCVector<Owner<Expression> > inits;
 578   const Identifier *contentsId = 0;
 579   unsigned allowed = (allowOpenParen|allowCloseParen|allowIdentifier|allowHashContents);
 580   for (;;) {
 581     if (!getToken(allowed, tok))
 582       return 0;
 583     if (tok == tokenCloseParen)
 584       break;
 585     switch (tok) {
 586     case tokenHashContents:
 587       if (!getToken(allowIdentifier, tok))
 588         return 0;
 589       contentsId = lookup(currentToken_);
 590       allowed = allowCloseParen;
 591       break;
 592     case tokenIdentifier:
 593       nics.push_back(lookup(currentToken_));
 594       break;
 595     case tokenOpenParen:
 596       {
 597         if (!getToken(allowIdentifier, tok))
 598           return 0;
 599         nics.push_back(lookup(currentToken_));
 600         inits.resize(nics.size());
 601         Identifier::SyntacticKey key;
 602         if (!parseExpression(0, inits.back(), key, tok))
 603           return 0;
 604         if (!getToken(allowCloseParen, tok))
 605           return 0;
 606       }
 607       break;
 608     default:
 609       CANNOT_HAPPEN();
 610     }
 611   }
 612   // We could allow sequence which is appended together here.
 613   Owner<Expression> body;
 614   Identifier::SyntacticKey key;
 615   if (!parseExpression(0, body, key, tok))
 616     return 0;
 617   if (!getToken(allowCloseParen, tok))
 618     return 0;
 619   Location defLoc;
 620   unsigned defPart;
 621   if (ident->inheritedCDefined(defPart, defLoc)
 622       && defPart <= interp_->currentPartIndex()) {
 623     if (defPart == interp_->currentPartIndex()) {
 624       interp_->setNextLocation(loc);
 625       interp_->message(InterpreterMessages::duplicateFlowObjectClass,
 626                        StringMessageArg(ident->name()),
 627                        defLoc);
 628     }
 629   }
 630   else {
 631     MacroFlowObj *flowObj
 632       = new (*interp_) MacroFlowObj(nics, inits, contentsId, body);
 633     interp_->makePermanent(flowObj);
 634     ident->setFlowObj(flowObj);
 635   }
 636   return 1;
 637 }
 638
 639 bool SchemeParser::doDeclareClassAttribute()
 640 {
 641   Token tok;
 642   if (!getToken(allowString|allowIdentifier, tok))
 643     return 0;
 644   interp_->addClassAttributeName(currentToken_);
 645   if (!getToken(allowCloseParen, tok))
 646     return 0;
 647   return 1;
 648 }
 649
 650 bool SchemeParser::doDeclareIdAttribute()
 651 {
 652   Token tok;
 653   if (!getToken(allowString|allowIdentifier, tok))
 654     return 0;
 655   interp_->addIdAttributeName(currentToken_);
 656   if (!getToken(allowCloseParen, tok))
 657     return 0;
 658   return 1;
 659 }
 660
 661 bool SchemeParser::doDefine()
 662 {
 663   Location loc(in_->currentLocation());
 664   Token tok;
 665   if (!getToken(allowOpenParen|allowIdentifier, tok))
 666     return 0;
 667   Vector<const Identifier *> formals;
 668   bool isProcedure;
 669   if (tok == tokenOpenParen) {
 670     if (!getToken(allowIdentifier, tok))
 671       return 0;
 672     isProcedure = 1;
 673   }
 674   else
 675     isProcedure = 0;
 676   Identifier *ident = lookup(currentToken_);
 677   Identifier::SyntacticKey key;
 678   if (ident->syntacticKey(key) && key <= int(Identifier::lastSyntacticKey))
 679     message(InterpreterMessages::syntacticKeywordAsVariable,
 680             StringMessageArg(currentToken_));
 681   NCVector<Owner<Expression> > inits;
 682   int nOptional;
 683   int nKey;
 684   bool hasRest;
 685   if (isProcedure && !parseFormals(formals, inits, nOptional, hasRest, nKey))
 686     return 0;
 687   Owner<Expression> expr;
 688   if (isProcedure) {
 689     if (!parseBegin(expr))
 690       return 0;
 691   }
 692   else {
 693     if (!parseExpression(0, expr, key, tok))
 694       return 0;
 695     if (!getToken(allowCloseParen, tok))
 696       return 0;
 697   }
 698   if (isProcedure)
 699     expr = new LambdaExpression(formals, inits, nOptional, hasRest, nKey,
 700                                 expr, loc);
 701   Location defLoc;
 702   unsigned defPart;
 703   if (ident->defined(defPart, defLoc)
 704       && defPart <= interp_->currentPartIndex()) {
 705     if (defPart == interp_->currentPartIndex())
 706       message(InterpreterMessages::duplicateDefinition,
 707               StringMessageArg(ident->name()),
 708               defLoc);
 709   }
 710   else
 711     ident->setDefinition(expr, interp_->currentPartIndex(), loc);
 712   return 1;
 713 }
 714
 715 bool SchemeParser::doDefineUnit()
 716 {
 717   Location loc(in_->currentLocation());
 718   Token tok;
 719   if (!getToken(allowIdentifier, tok))
 720     return 0;
 721   int i;
 722   for (i = 0; i < currentToken_.size(); i++)
 723     if (interp_->lexCategory(currentToken_[i]) != Interpreter::lexLetter)
 724       break;
 725   if ((i < currentToken_.size())
 726        || ((currentToken_.size() == 1) && (currentToken_[0] =='e'))) {
 727     message(InterpreterMessages::invalidUnitName,
 728             StringMessageArg(currentToken_));
 729     return 0;
 730   }
 731
 732   Unit *unit = interp_->lookupUnit(currentToken_);
 733   Owner<Expression> expr;
 734   Identifier::SyntacticKey key;
 735   if (!parseExpression(0, expr, key, tok))
 736     return 0;
 737   if (!getToken(allowCloseParen, tok))
 738     return 0;
 739   Location defLoc;
 740   unsigned defPart;
 741   if (unit->defined(defPart, defLoc)
 742       && defPart <= interp_->currentPartIndex()) {
 743     if (defPart == interp_->currentPartIndex())
 744       message(InterpreterMessages::duplicateUnitDefinition,
 745               StringMessageArg(unit->name()),
 746               defLoc);
 747   }
 748   else
 749     unit->setDefinition(expr, interp_->currentPartIndex(), loc);
 750   return 1;
 751 }
 752
 753 bool SchemeParser::skipForm()
 754 {
 755   static const unsigned allow = (~0 & ~allowEndOfEntity);
 756   unsigned level = 0;
 757   for (;;) {
 758     Token tok;
 759     if (!getToken(allow, tok))
 760       break;
 761     switch (tok) {
 762     case tokenOpenParen:
 763       level++;
 764       break;
 765     case tokenCloseParen:
 766       if (level == 0)
 767         return 1;
 768       level--;
 769       break;
 770     default:
 771       break;
 772     }
 773   }
 774   return 0;
 775 }
 776
 777 bool SchemeParser::parseExpression(unsigned allowed,
 778                                   Owner<Expression> &expr,
 779                                   Identifier::SyntacticKey &key,
 780                                   Token &tok)
 781 {
 782   expr.clear();
 783   key = Identifier::notKey;
 784   ELObj *obj;
 785   if (!parseSelfEvaluating(allowed, obj, tok))
 786     return 0;
 787   if (obj) {
 788     interp_->makePermanent(obj);
 789     expr = new ConstantExpression(obj, in_->currentLocation());
 790     return 1;
 791   }
 792   switch (tok) {
 793   case tokenQuote:
 794     {
 795       Location loc;
 796       if (!parseDatum(0, obj, loc, tok))
 797         return 0;
 798       interp_->makePermanent(obj);
 799       expr = new ConstantExpression(obj, loc);
 800       break;
 801     }
 802   case tokenQuasiquote:
 803     {
 804       bool spliced;
 805       return parseQuasiquoteTemplate(0, 0, expr, key, tok, spliced);
 806     }
 807   case tokenOpenParen:
 808     {
 809       Location loc(in_->currentLocation());
 810       if (!parseExpression(allowExpressionKey, expr, key, tok))
 811         return 0;
 812       if (expr) {
 813         NCVector<Owner<Expression> > args;
 814         for (;;) {
 815           args.resize(args.size() + 1);
 816           if (!parseExpression(allowCloseParen, args.back(), key, tok))
 817             return 0;
 818           if (!args.back()) {
 819             args.resize(args.size() - 1);
 820             break;
 821           }
 822         }
 823         expr = new CallExpression(expr, args, loc);
 824       }
 825       else {
 826         switch (key) {
 827         case Identifier::keyQuote:
 828           return parseQuote(expr);
 829         case Identifier::keyLambda:
 830           return parseLambda(expr);
 831         case Identifier::keyIf:
 832           return parseIf(expr);
 833         case Identifier::keyCond:
 834           return parseCond(expr);
 835         case Identifier::keyAnd:
 836           return parseAnd(expr);
 837         case Identifier::keyOr:
 838           return parseOr(expr);
 839         case Identifier::keyCase:
 840           return parseCase(expr);
 841         case Identifier::keyLet:
 842           return parseLet(expr);
 843         case Identifier::keyLetStar:
 844           return parseLetStar(expr);
 845         case Identifier::keyLetrec:
 846           return parseLetrec(expr);
 847         case Identifier::keyThereExists:
 848           return parseSpecialQuery(expr, "node-list-some?");
 849         case Identifier::keyForAll:
 850           return parseSpecialQuery(expr, "node-list-every?");
 851         case Identifier::keySelectEach:
 852           return parseSpecialQuery(expr, "node-list-filter");
 853         case Identifier::keyUnionForEach:
 854           return parseSpecialQuery(expr, "node-list-union-map");
 855         case Identifier::keyMake:
 856           return parseMake(expr);
 857         case Identifier::keyStyle:
 858           return parseStyle(expr);
 859         case Identifier::keyWithMode:
 860           return parseWithMode(expr);
 861         case Identifier::keyQuasiquote:
 862           return parseQuasiquote(expr);
 863         case Identifier::keySet:
 864           return parseSet(expr);
 865         case Identifier::keyBegin:
 866           return parseBegin(expr);
 867         default:
 868           CANNOT_HAPPEN();
 869         }
 870       }
 871       break;
 872     }
 873   case tokenIdentifier:
 874     {
 875       const Identifier *ident = lookup(currentToken_);
 876       if (ident->syntacticKey(key) && key <= int(Identifier::lastSyntacticKey)) {
 877         switch (key) {
 878         case Identifier::keyDefine:
 879           if (allowed & allowKeyDefine)
 880             return 1;
 881           break;
 882         case Identifier::keyArrow:
 883           if (allowed & allowKeyArrow)
 884             return 1;
 885           break;
 886         case Identifier::keyElse:
 887           if (allowed & allowKeyElse)
 888             return 1;
 889           break;
 890         case Identifier::keyUnquote:
 891         case Identifier::keyUnquoteSplicing:
 892           break;
 893         default:
 894           if (allowed & allowExpressionKey)
 895             return 1;
 896           break;
 897         }
 898         message(InterpreterMessages::syntacticKeywordAsVariable,
 899                 StringMessageArg(currentToken_));
 900       }
 901       expr = new VariableExpression(ident, in_->currentLocation());
 902     }
 903     break;
 904   default:
 905     break;
 906   }
 907   return 1;
 908 }
 909
 910
 911 bool SchemeParser::parseQuote(Owner<Expression> &expr)
 912 {
 913   Token tok;
 914   Location loc;
 915   ELObj *obj;
 916   if (!parseDatum(0, obj, loc, tok))
 917     return 0;
 918   if (!getToken(allowCloseParen, tok))
 919     return 0;
 920   interp_->makePermanent(obj);
 921   expr = new ConstantExpression(obj, loc);
 922   return 1;
 923 }
 924
 925 bool SchemeParser::parseQuasiquote(Owner<Expression> &expr)
 926 {
 927   bool spliced;
 928   Token tok;
 929   Identifier::SyntacticKey key;
 930   if (!parseQuasiquoteTemplate(0, 0, expr, key, tok, spliced))
 931     return 0;
 932   return getToken(allowCloseParen, tok);
 933 }
 934
 935 bool SchemeParser::parseQuasiquoteTemplate(unsigned level,
 936                                           unsigned allowed,
 937                                           Owner<Expression> &expr,
 938                                           Identifier::SyntacticKey &key,
 939                                           Token &tok,
 940                                           bool &spliced)
 941 {
 942   key = Identifier::notKey;
 943   spliced = 0;
 944   ELObj *obj;
 945   if (!parseSelfEvaluating(allowed|allowUnquote|allowVector, obj, tok))
 946     return 0;
 947   switch (tok) {
 948   case tokenQuasiquote:
 949     if (!parseQuasiquoteTemplate(level + 1, 0, expr, key, tok, spliced))
 950       return 0;
 951     createQuasiquoteAbbreviation("quasiquote", expr);
 952     break;
 953   case tokenQuote:
 954     if (!parseQuasiquoteTemplate(level, 0, expr, key, tok, spliced))
 955       break;
 956     createQuasiquoteAbbreviation("quote", expr);
 957     break;
 958   case tokenUnquote:
 959   case tokenUnquoteSplicing:
 960     if (level == 0) {
 961       spliced = (tok == tokenUnquoteSplicing);
 962       if (!parseExpression(0, expr, key, tok))
 963         return 0;
 964     }
 965     else {
 966       Token tem;
 967       if (!parseQuasiquoteTemplate(level - 1, 0, expr, key, tem, spliced))
 968         break;
 969       createQuasiquoteAbbreviation(tok == tokenUnquote ? "unquote" : "unquote-splicing", expr);
 970     }
 971     break;
 972   case tokenOpenParen:
 973   case tokenVector:
 974     {
 975       QuasiquoteExpression::Type type
 976         = (tok == tokenVector
 977            ? QuasiquoteExpression::vectorType
 978            : QuasiquoteExpression::listType);
 979       Location loc(in_->currentLocation());
 980       NCVector<Owner<Expression> > exprs(1);
 981       Vector<PackedBoolean> exprsSpliced;
 982       bool temSpliced;
 983       if (!parseQuasiquoteTemplate(level,
 984                                    allowCloseParen|allowQuasiquoteKey|allowUnquoteSplicing,
 985                                    exprs[0], key, tok, temSpliced))
 986         return 0;
 987       if (!exprs[0]) {
 988         switch (key) {
 989         case Identifier::keyQuasiquote:
 990           if (!parseQuasiquoteTemplate(level + 1, 0, expr, key, tok, spliced))
 991             return 0;
 992           createQuasiquoteAbbreviation("quasiquotation", expr);
 993           break;
 994         case Identifier::keyUnquoteSplicing:
 995           spliced = 1;
 996           // fall through
 997         case Identifier::keyUnquote:
 998           if (level == 0) {
 999             if (!parseExpression(0, expr, key, tok))
1000               return 0;
1001           }
1002           else {
1003             if (!parseQuasiquoteTemplate(level - 1, 0, expr, key, tok, temSpliced))
1004               return 0;
1005             createQuasiquoteAbbreviation(spliced ? "unquote-splicing" : "unquote", expr);
1006             spliced = 0;
1007           }
1008           break;
1009         default:
1010            expr = new ConstantExpression(interp_->makeNil(), loc);
1011            return 1;
1012         }
1013         return getToken(allowCloseParen, tok);
1014       }
1015       exprsSpliced.push_back(PackedBoolean(temSpliced));
1016       for (;;) {
1017         Owner<Expression> tem;
1018         if (!parseQuasiquoteTemplate(level,
1019                                      allowCloseParen|allowUnquoteSplicing
1020                                      |(type == QuasiquoteExpression::vectorType
1021                                        ? 0
1022                                        : allowPeriod),
1023                                      tem, key, tok, temSpliced))
1024           return 0;
1025         if (!tem) {
1026           if (tok == tokenCloseParen)
1027             break;
1028           exprs.resize(exprs.size() + 1);
1029           type = QuasiquoteExpression::improperType;
1030           if (!parseQuasiquoteTemplate(level, 0, exprs.back(), key, tok, temSpliced))
1031             return 0;
1032           if (!getToken(allowCloseParen, tok))
1033             return 0;
1034           exprsSpliced.push_back(0);
1035           break;
1036         }
1037         exprs.resize(exprs.size() + 1);
1038         exprs.back().swap(tem);
1039         exprsSpliced.push_back(PackedBoolean(temSpliced));
1040       }
1041       expr = new QuasiquoteExpression(exprs, exprsSpliced, type, loc);
1042     }
1043     break;
1044   case tokenIdentifier:
1045     if (allowed & allowQuasiquoteKey) {
1046       const Identifier *ident = lookup(currentToken_);
1047       if (ident->syntacticKey(key)) {
1048         switch (key) {
1049         case Identifier::keyUnquoteSplicing:
1050         case Identifier::keyUnquote:
1051         case Identifier::keyQuasiquote:
1052           return 1;
1053         default:
1054           break;
1055         }
1056       }
1057     }
1058     obj = interp_->makeSymbol(currentToken_);
1059     // fall through
1060   default:
1061     if (obj) {
1062       interp_->makePermanent(obj);
1063       expr = new ConstantExpression(obj, in_->currentLocation());
1064     }
1065     break;
1066   }
1067   return 1;
1068 }
1069
1070 void SchemeParser::createQuasiquoteAbbreviation(const char *sym, Owner<Expression> &expr)
1071 {
1072   Location loc(expr->location());
1073   NCVector<Owner<Expression> > v(2);
1074   v[1].swap(expr);
1075   v[0] = new ConstantExpression(interp_->makeSymbol(Interpreter::makeStringC(sym)), loc);
1076   Vector<PackedBoolean> spliced;
1077   spliced.push_back(0);
1078   spliced.push_back(0);
1079   expr = new QuasiquoteExpression(v, spliced, QuasiquoteExpression::listType, loc);
1080 }
1081
1082 bool SchemeParser::parseIf(Owner<Expression> &expr)
1083 {
1084   Location loc(in_->currentLocation());
1085   Owner<Expression> expr0, expr1, expr2;
1086   Token tok;
1087   Identifier::SyntacticKey key;
1088   if (!parseExpression(0, expr0, key, tok)
1089       || !parseExpression(0, expr1, key, tok)
1090       || !parseExpression(dsssl2() ? allowCloseParen : 0, expr2, key, tok))
1091     return 0;
1092   if (!expr2)
1093     expr2 = new ConstantExpression(interp_->makeUnspecified(), in_->currentLocation());
1094   else if (!getToken(allowCloseParen, tok))
1095     return 0;
1096   expr = new IfExpression(expr0, expr1, expr2, loc);
1097   return 1;
1098 }
1099
1100 bool SchemeParser::parseCond(Owner<Expression> &expr, bool opt)
1101 {
1102   Location loc(in_->currentLocation());
1103   Token tok;
1104   if (!getToken(allowOpenParen|(opt ? unsigned(allowCloseParen) : 0), tok))
1105     return 0;
1106   if (tok == tokenCloseParen) {
1107     if (dsssl2())
1108       expr = new ConstantExpression(interp_->makeUnspecified(), loc);
1109     else
1110       expr = new CondFailExpression(loc);
1111     return 1;
1112   }
1113   Identifier::SyntacticKey key;
1114   Owner<Expression> testExpr;
1115   if (!parseExpression(allowKeyElse, testExpr, key, tok))
1116     return 0;
1117   if (!testExpr) {
1118     if (!parseBegin(expr))
1119       return 0;
1120     return getToken(allowCloseParen, tok);
1121   }
1122   NCVector<Owner<Expression> > valExprs;
1123   for (;;) {
1124     Owner<Expression> tem;
1125     if (!parseExpression(allowCloseParen, tem, key, tok))
1126       return 0;
1127     if (!tem)
1128       break;
1129     valExprs.resize(valExprs.size() + 1);
1130     tem.swap(valExprs.back());
1131   }
1132   Owner<Expression> valExpr;
1133   if (valExprs.size() == 1)
1134     valExprs[0].swap(valExpr);
1135   else if (valExprs.size())
1136     valExpr = new SequenceExpression(valExprs, valExprs[0]->location());
1137   Owner<Expression> elseExpr;
1138   if (!parseCond(elseExpr, 1))
1139     return 0;
1140   if (valExpr)
1141     expr = new IfExpression(testExpr, valExpr, elseExpr, loc);
1142   else
1143     expr = new OrExpression(testExpr, elseExpr, loc);
1144   return 1;
1145 }
1146
1147 bool SchemeParser::parseCase(Owner<Expression> &expr)
1148 {
1149   Owner<Expression> keyExpr;
1150   Owner<Expression> elseClause;
1151   NCVector<CaseExpression::Case> cases;
1152   Location loc(in_->currentLocation());
1153   Token tok;
1154   Identifier::SyntacticKey key;
1155   if (!parseExpression(0, keyExpr, key, tok))
1156     return 0;
1157   for (;;) {
1158     if (!getToken(allowOpenParen
1159       |(cases.size() ? unsigned(allowCloseParen) : 0), tok))
1160       return 0;
1161     if (tok == tokenCloseParen)
1162       break;
1163     if (!getToken(allowOpenParen|allowIdentifier, tok))
1164       return 0;
1165     if (tok == tokenOpenParen) {
1166       cases.resize(cases.size() + 1);
1167       Location loc;
1168       for (;;) {
1169         ELObj *obj;
1170         if (!parseDatum(allowCloseParen, obj, loc, tok))
1171           return 0;
1172         if (tok == tokenCloseParen)
1173           break;
1174         interp_->makePermanent(obj);
1175         cases.back().datums.push_back(obj);
1176       }
1177       if (!parseBegin(cases.back().expr))
1178         return 0;
1179     }
1180     else {
1181       const Identifier *ident = lookup(currentToken_);
1182       if (ident->syntacticKey(key) && key == Identifier::keyElse) {
1183         if (!parseBegin(elseClause))
1184           return 0;
1185         if (!getToken(allowCloseParen, tok))
1186           return 0;
1187         break;
1188       }
1189       else {
1190         message(InterpreterMessages::caseElse,
1191                 StringMessageArg(currentToken_));
1192         return 0;
1193       }
1194     }
1195   }
1196   if (dsssl2() && !elseClause)
1197     elseClause = new ConstantExpression(interp_->makeUnspecified(), loc);
1198   expr = new CaseExpression(keyExpr, cases, elseClause, loc);
1199   return 1;
1200 }
1201
1202 bool SchemeParser::parseOr(Owner<Expression> &expr)
1203 {
1204   Location loc(in_->currentLocation());
1205   Token tok;
1206   Identifier::SyntacticKey key;
1207   Owner<Expression> test1Expr;
1208   if (!parseExpression(allowCloseParen, test1Expr, key, tok))
1209     return 0;
1210   if (!test1Expr) {
1211     expr = new ConstantExpression(interp_->makeFalse(), loc);
1212     return 1;
1213   }
1214   Owner<Expression> test2Expr;
1215   if (!parseOr(test2Expr))
1216     return 0;
1217   expr = new OrExpression(test1Expr, test2Expr, loc);
1218   return 1;
1219 }
1220
1221 bool SchemeParser::parseAnd(Owner<Expression> &expr, bool opt)
1222 {
1223   Location loc(in_->currentLocation());
1224   Token tok;
1225   Identifier::SyntacticKey key;
1226   Owner<Expression> testExpr;
1227   if (!parseExpression(allowCloseParen, testExpr, key, tok))
1228     return 0;
1229   if (!testExpr) {
1230     if (!opt)
1231       expr = new ConstantExpression(interp_->makeTrue(), loc);
1232     return 1;
1233   }
1234   Owner<Expression> restExpr;
1235   if (!parseAnd(restExpr, 1))
1236     return 0;
1237   if (!restExpr)
1238     testExpr.swap(expr);
1239   else {
1240     // This relies on the fact that #f is the only false value.
1241     Owner<Expression> falseExpr(new ConstantExpression(interp_->makeFalse(), loc));
1242     expr = new IfExpression(testExpr, restExpr, falseExpr, loc);
1243   }
1244   return 1;
1245 }
1246
1247 bool SchemeParser::parseBegin(Owner<Expression> &expr)
1248 {
1249   Location loc(in_->currentLocation());
1250   Token tok;
1251   Identifier::SyntacticKey key;
1252   if (!parseExpression(0, expr, key, tok))
1253     return 0;
1254   if (dsssl2()) {
1255     NCVector<Owner<Expression> > exprs;
1256     for (size_t i = 1;; i++) {
1257       Owner<Expression> tem;
1258       if (!parseExpression(allowCloseParen, tem, key, tok))
1259         return 0;
1260       if (!tem)
1261         break;
1262       exprs.resize(i + 1);
1263       tem.swap(exprs[i]);
1264     }
1265     if (exprs.size()) {
1266       expr.swap(exprs[0]);
1267       expr = new SequenceExpression(exprs, loc);
1268     }
1269     return 1;
1270   }
1271   else
1272     return getToken(allowCloseParen, tok);
1273 }
1274
1275 bool SchemeParser::parseSet(Owner<Expression> &expr)
1276 {
1277   Location loc(in_->currentLocation());
1278   Token tok;
1279   if (!getToken(allowIdentifier, tok))
1280       return 0;
1281   const Identifier *var = lookup(currentToken_);
1282   Identifier::SyntacticKey key;
1283   Owner<Expression> value;
1284   if (!parseExpression(0, value, key, tok))
1285     return 0;
1286   if (!getToken(allowCloseParen, tok))
1287     return 0;
1288   expr = new AssignmentExpression(var, value, loc);
1289   return 1;
1290 }
1291
1292 bool SchemeParser::parseWithMode(Owner<Expression> &expr)
1293 {
1294   Location loc(in_->currentLocation());
1295   Token tok;
1296   if (!getToken(allowIdentifier|allowFalse, tok))
1297     return 0;
1298   const ProcessingMode *mode;
1299   if (tok == tokenFalse)
1300     mode = interp_->initialProcessingMode();
1301   else
1302     mode = interp_->lookupProcessingMode(currentToken_);
1303   Owner<Expression> content;
1304   Identifier::SyntacticKey key;
1305   if (!parseExpression(0, content, key, tok))
1306     return 0;
1307   if (!getToken(allowCloseParen, tok))
1308     return 0;
1309   expr = new WithModeExpression(mode, content, loc);
1310   return 1;
1311 }
1312
1313 bool SchemeParser::parseMake(Owner<Expression> &expr)
1314 {
1315   Location loc(in_->currentLocation());
1316   Token tok;
1317   if (!getToken(allowIdentifier, tok))
1318     return 0;
1319   const Identifier *foc = lookup(currentToken_);
1320   NCVector<Owner<Expression> > exprs;
1321   Vector<const Identifier *> keys;
1322   for (;;) {
1323     Owner<Expression> tem;
1324     Identifier::SyntacticKey key;
1325     if (!parseExpression(allowCloseParen, tem, key, tok))
1326       return 0;
1327     if (!tem)
1328       break;
1329     if (keys.size() == exprs.size()) {
1330       const Identifier *k = tem->keyword();
1331       if (k) {
1332         tem.clear();
1333         if (!parseExpression(0, tem, key, tok))
1334           return 0;
1335         size_t i;
1336         for (i = 0; i < keys.size(); i++)
1337           if (keys[i]->name() == k->name())
1338             break;
1339         if (i < keys.size())
1340           continue;
1341         keys.push_back(k);
1342       }
1343     }
1344     exprs.resize(exprs.size() + 1);
1345     tem.swap(exprs.back());
1346   }
1347   expr = new MakeExpression(foc, keys, exprs, loc);
1348   return 1;
1349 }
1350
1351 bool SchemeParser::parseStyle(Owner<Expression> &expr)
1352 {
1353   Location loc(in_->currentLocation());
1354   NCVector<Owner<Expression> > exprs;
1355   Vector<const Identifier *> keys;
1356   for (;;) {
1357     Token tok;
1358     if (!getToken(allowKeyword|allowCloseParen, tok))
1359       return 0;
1360     if (tok == tokenCloseParen)
1361       break;
1362     keys.resize(keys.size() + 1);
1363     keys.back() = lookup(currentToken_);
1364     exprs.resize(exprs.size() + 1);
1365     Identifier::SyntacticKey key;
1366     if (!parseExpression(0, exprs.back(), key, tok))
1367       return 0;
1368   }
1369   expr = new StyleExpression(keys, exprs, loc);
1370   return 1;
1371 }
1372
1373 bool SchemeParser::parseLambda(Owner<Expression> &expr)
1374 {
1375   Location loc(in_->currentLocation());
1376   Token tok;
1377   if (!getToken(allowOpenParen, tok))
1378     return 0;
1379   Vector<const Identifier *> formals;
1380   NCVector<Owner<Expression> > inits;
1381   int nOptional;
1382   int nKey;
1383   bool hasRest;
1384   if (!parseFormals(formals, inits, nOptional, hasRest, nKey))
1385     return 0;
1386   Owner<Expression> body;
1387   if (!parseBegin(body))
1388     return 0;
1389   expr = new LambdaExpression(formals, inits, nOptional, hasRest, nKey,
1390                               body, loc);
1391   return 1;
1392 }
1393
1394 // The rest arg is put last.
1395
1396 bool SchemeParser::parseFormals(Vector<const Identifier *> &formals,
1397                                NCVector<Owner<Expression> > &inits,
1398                                int &nOptional,
1399                                bool &hasRest,
1400                                int &nKey)
1401 {
1402   Token tok;
1403   enum FormalType { required, optional, rest, key } type = required;
1404   unsigned allowed = (allowCloseParen|allowIdentifier
1405                       |allowHashOptional|allowHashRest|allowHashKey);
1406   int argCount[4];
1407   for (int i = 0; i < 4; i++)
1408     argCount[i] = 0;
1409   for (;;) {
1410     if (!getToken(allowed, tok))
1411       return 0;
1412     switch (tok) {
1413     case tokenHashOptional:
1414       allowed |= allowOpenParen;
1415       allowed &= ~allowHashOptional;
1416       type = optional;
1417       break;
1418     case tokenHashRest:
1419       allowed = allowIdentifier;
1420       type = rest;
1421       break;
1422     case tokenHashKey:
1423       allowed = (allowOpenParen|allowCloseParen|allowIdentifier);
1424       type = key;
1425       break;
1426     case tokenOpenParen:
1427       {
1428         if (!getToken(allowIdentifier, tok))
1429           return 0;
1430         argCount[type]++;
1431         formals.push_back(lookup(currentToken_));
1432         inits.resize(argCount[optional] + argCount[key]);
1433         Identifier::SyntacticKey key;
1434         if (!parseExpression(0, inits.back(), key, tok))
1435           return 0;
1436         if (!getToken(allowCloseParen, tok))
1437           return 0;
1438       }
1439       break;
1440     case tokenIdentifier:
1441       {
1442         formals.push_back(lookup(currentToken_));
1443         argCount[type]++;
1444         if (type == rest)
1445           allowed = (allowHashKey|allowCloseParen);
1446       }
1447       break;
1448     case tokenCloseParen:
1449       goto done;
1450     default:
1451       CANNOT_HAPPEN();
1452     }
1453   }
1454 done:
1455   nOptional = argCount[optional];
1456   nKey = argCount[key];
1457   inits.resize(nOptional + nKey);
1458   hasRest = argCount[rest];
1459   return 1;
1460 }
1461
1462 bool SchemeParser::parseLet(Owner<Expression> &expr)
1463 {
1464   Location loc(in_->currentLocation());
1465   Token tok;
1466   if (!getToken(allowOpenParen|allowIdentifier, tok))
1467     return 0;
1468   Vector<const Identifier *> vars;
1469   NCVector<Owner<Expression> > inits;
1470   Owner<Expression> body;
1471   const Identifier *name;
1472   if (tok == tokenOpenParen) {
1473     name = 0;
1474     if (!parseBindingsAndBody1(vars, inits, body))
1475       return 0;
1476   }
1477   else {
1478     name = lookup(currentToken_);
1479     if (!parseBindingsAndBody(vars, inits, body))
1480       return 0;
1481   }
1482   if (name) {
1483     // Named let
1484     NCVector<Owner<Expression> > loopInit(1);
1485     NCVector<Owner<Expression> > argsInit;
1486     loopInit[0] = new LambdaExpression(vars, argsInit, 0, 0, 0, body, loc);
1487     Vector<const Identifier *> loopFormal(1);
1488     loopFormal[0] = name;
1489     expr = new VariableExpression(name, loc);
1490     expr = new LetrecExpression(loopFormal, loopInit, expr, loc);
1491     expr = new CallExpression(expr, inits, loc);
1492  }
1493  else
1494    expr = new LetExpression(vars, inits, body, loc);
1495  return 1;
1496 }
1497
1498 bool SchemeParser::parseLetStar(Owner<Expression> &expr)
1499 {
1500   Location loc(in_->currentLocation());
1501   Vector<const Identifier *> vars;
1502   NCVector<Owner<Expression> > inits;
1503   Owner<Expression> body;
1504   if (!parseBindingsAndBody(vars, inits, body))
1505     return 0;
1506   expr = new LetStarExpression(vars, inits, body, loc);
1507   return 1;
1508 }
1509
1510 bool SchemeParser::parseLetrec(Owner<Expression> &expr)
1511 {
1512   Location loc(in_->currentLocation());
1513   Vector<const Identifier *> vars;
1514   NCVector<Owner<Expression> > inits;
1515   Owner<Expression> body;
1516   if (!parseBindingsAndBody(vars, inits, body))
1517     return 0;
1518   expr = new LetrecExpression(vars, inits, body, loc);
1519   return 1;
1520 }
1521
1522 bool SchemeParser::parseBindingsAndBody(Vector<const Identifier *> &vars,
1523                                        NCVector<Owner<Expression> > &inits,
1524                                        Owner<Expression> &body)
1525 {
1526   Token tok;
1527   if (!getToken(allowOpenParen, tok))
1528     return 0;
1529   return parseBindingsAndBody1(vars, inits, body);
1530 }
1531
1532 bool SchemeParser::parseBindingsAndBody1(Vector<const Identifier *> &vars,
1533                                         NCVector<Owner<Expression> > &inits,
1534                                         Owner<Expression> &body)
1535 {
1536   Token tok;
1537   Identifier::SyntacticKey key;
1538   for (;;) {
1539     if (!getToken(allowCloseParen|allowOpenParen, tok))
1540       return 0;
1541     if (tok == tokenCloseParen)
1542       break;
1543     if (!getToken(allowIdentifier, tok))
1544       return 0;
1545     vars.push_back(lookup(currentToken_));
1546     inits.resize(inits.size() + 1);
1547     if (!parseExpression(0, inits.back(), key, tok))
1548       return 0;
1549     if (!getToken(allowCloseParen, tok))
1550       return 0;
1551   }
1552   return parseBegin(body);
1553 }
1554
1555 bool SchemeParser::parseDatum(unsigned otherAllowed,
1556                              ELObj *&result,
1557                              Location &loc,
1558                              Token &tok)
1559 {
1560   if (!parseSelfEvaluating(otherAllowed|allowVector|allowUnquote|allowUnquoteSplicing, result, tok))
1561     return 0;
1562   loc = in_->currentLocation();
1563   if (result)
1564     return 1;
1565   switch (tok) {
1566   case tokenIdentifier:
1567     result = interp_->makeSymbol(currentToken_);
1568     break;
1569   case tokenQuote:
1570     return parseAbbreviation("quote", result);
1571   case tokenQuasiquote:
1572     return parseAbbreviation("quasiquote", result);
1573   case tokenUnquote:
1574     return parseAbbreviation("unquote", result);
1575   case tokenUnquoteSplicing:
1576     return parseAbbreviation("unquote-splicing", result);
1577   case tokenOpenParen:
1578     {
1579       ELObj *tem;
1580       Location ignore;
1581       if (!parseDatum(allowCloseParen, tem, ignore, tok))
1582         return 0;
1583       if (!tem) {
1584         result = interp_->makeNil();
1585         break;
1586       }
1587       ELObjDynamicRoot list(*interp_, tem);
1588       PairObj *last = new (*interp_) PairObj(tem, 0);
1589       list = last;
1590       for (;;) {
1591         if (!parseDatum(allowCloseParen|allowPeriod, tem, ignore, tok))
1592           return 0;
1593         if (!tem) {
1594           if (tok == tokenCloseParen) {
1595             last->setCdr(interp_->makeNil());
1596             break;
1597           }
1598           if (!parseDatum(0, tem, ignore, tok))
1599             return 0;
1600           last->setCdr(tem);
1601           if (!getToken(allowCloseParen, tok))
1602             return 0;
1603           break;
1604         }
1605         last->setCdr(tem); // to protect it
1606         PairObj *p = new (*interp_) PairObj(tem, 0);
1607         last->setCdr(p);
1608         last = p;
1609       }
1610       result = list;
1611     }
1612     break;
1613   case tokenVector:
1614     {
1615       VectorObj *v = new (*interp_) VectorObj;
1616       ELObjDynamicRoot protect(*interp_, v);
1617       Vector<ELObj *> &vec = *v;
1618       Location ignore;
1619       for (;;) {
1620         ELObj *tem;
1621         if (!parseDatum(allowCloseParen, tem, ignore, tok))
1622           return 0;
1623         if (!tem)
1624           break;
1625         vec.push_back(tem);
1626       }
1627       result = v;
1628     }
1629     break;
1630   default:
1631     break;
1632   }
1633   return 1;
1634 }
1635
1636 bool SchemeParser::parseSelfEvaluating(unsigned otherAllowed,
1637                                       ELObj *&result,
1638                                       Token &tok)
1639 {
1640   if (!getToken(allowExpr|otherAllowed, tok))
1641     return 0;
1642   switch (tok) {
1643   case tokenTrue:
1644     result = interp_->makeTrue();
1645     break;
1646   case tokenFalse:
1647     result = interp_->makeFalse();
1648     break;
1649   case tokenVoid:
1650     result = interp_->makeUnspecified();
1651     break;
1652   case tokenString:
1653     result = new (*interp_) StringObj(currentToken_);
1654     break;
1655   case tokenKeyword:
1656     result = interp_->makeKeyword(currentToken_);
1657     break;
1658   case tokenChar:
1659     result = interp_->makeChar(currentToken_[0]);
1660     break;
1661   case tokenNumber:
1662     result = interp_->convertNumber(currentToken_);
1663     if (!result) {
1664       message(InterpreterMessages::invalidNumber,
1665               StringMessageArg(currentToken_));
1666       result = interp_->makeError();
1667     }
1668     break;
1669   case tokenGlyphId:
1670     result = convertAfiiGlyphId(currentToken_);
1671     break;
1672   default:
1673     result = 0;
1674     break;
1675   }
1676   return 1;
1677 }
1678
1679 bool SchemeParser::parseAbbreviation(const char *sym, ELObj *&result)
1680 {
1681   SymbolObj *quoteSym = interp_->makeSymbol(Interpreter::makeStringC(sym));
1682   ELObj *obj;
1683   Location ignore;
1684   Token tok;
1685   if (!parseDatum(0, obj, ignore, tok))
1686     return 0;
1687   ELObjDynamicRoot protect(*interp_, obj);
1688   protect = new (*interp_) PairObj(protect, interp_->makeNil());
1689   result = interp_->makePair(quoteSym, protect);
1690   return 1;
1691 }
1692
1693 bool SchemeParser::getToken(unsigned allowed, Token &tok)
1694 {
1695   InputSource *in = in_.pointer();
1696   for (;;) {
1697     in->startToken();
1698     Xchar c = in->tokenChar(*this);
1699     switch (c) {
1700     case InputSource::eE:
1701       if (!(allowed & allowEndOfEntity))
1702         return tokenRecover(allowed, tok);
1703       tok = tokenEndOfEntity;
1704       return 1;
1705     case '(':
1706       if (!(allowed & allowOpenParen))
1707         return tokenRecover(allowed, tok);
1708       tok = tokenOpenParen;
1709       return 1;
1710     case ')':
1711       if (!(allowed & allowCloseParen))
1712         return tokenRecover(allowed, tok);
1713       tok = tokenCloseParen;
1714       return 1;
1715     case '\'':
1716       if (!(allowed & allowOtherExpr))
1717         return tokenRecover(allowed, tok);
1718       tok = tokenQuote;
1719       return 1;
1720     case '`':
1721       if (!(allowed & allowOtherExpr))
1722         return tokenRecover(allowed, tok);
1723       tok = tokenQuasiquote;
1724       return 1;
1725     case ',':
1726       c = in->tokenChar(*this);
1727       if (c == '@') {
1728         if (!(allowed & allowUnquoteSplicing))
1729           return tokenRecover(allowed, tok);
1730         tok = tokenUnquoteSplicing;
1731       }
1732       else {
1733         if (!(allowed & allowUnquote))
1734           return tokenRecover(allowed, tok);
1735         tok = tokenUnquote;
1736         in->endToken(1);
1737       }
1738       return 1;
1739     case ' ':
1740     case '\r':
1741     case '\n':
1742     case '\t':
1743     case '\f':
1744       // whitespace
1745       break;
1746     case '#':
1747       c = in->tokenChar(*this);
1748       switch (c) {
1749       case 't':
1750         if (!(allowed & allowOtherExpr))
1751           return tokenRecover(allowed, tok);
1752         tok = tokenTrue;
1753         return 1;
1754       case 'f':
1755         if (!(allowed & allowFalse))
1756           return tokenRecover(allowed, tok);
1757         tok = tokenFalse;
1758         return 1;
1759       case '\\':
1760         {
1761           c = in->tokenChar(*this);
1762           if (c == InputSource::eE) {
1763             message(InterpreterMessages::unexpectedEof);
1764             if (allowed & allowEndOfEntity) {
1765               tok = tokenEndOfEntity;
1766               return 1;
1767             }
1768             return 0;
1769           }
1770           if (!(allowed & allowOtherExpr)) {
1771             extendToken();
1772             return tokenRecover(allowed, tok);
1773           }
1774           in->discardInitial();
1775           extendToken();
1776           tok = tokenChar;
1777           if (in->currentTokenLength() == 1) {
1778             currentToken_.assign(in->currentTokenStart(), 1);
1779           }
1780           else {
1781             StringC tem(in->currentTokenStart(), in->currentTokenLength());
1782             currentToken_.resize(1);
1783             if (!interp_->convertCharName(tem, currentToken_[0])) {
1784               message(InterpreterMessages::unknownCharName,
1785                       StringMessageArg(tem));
1786               currentToken_[0] = defaultChar;
1787             }
1788           }
1789           return 1;
1790         }
1791       case '!':
1792         {
1793           extendToken();
1794           StringC tem(in->currentTokenStart() + 2,
1795                       in->currentTokenLength() - 2);
1796           if (tem == Interpreter::makeStringC("optional")) {
1797             if (!(allowed & allowHashOptional))
1798               return tokenRecover(allowed, tok);
1799             tok = tokenHashOptional;
1800             return 1;
1801           }
1802           if (tem == Interpreter::makeStringC("key")) {
1803             if (!(allowed & allowHashKey))
1804               return tokenRecover(allowed, tok);
1805             tok = tokenHashKey;
1806             return 1;
1807           }
1808           if (tem == Interpreter::makeStringC("rest")) {
1809             if (!(allowed & allowHashRest))
1810               return tokenRecover(allowed, tok);
1811             tok = tokenHashRest;
1812             return 1;
1813           }
1814           if (tem == Interpreter::makeStringC("contents")) {
1815             if (!(allowed & allowHashContents))
1816               return tokenRecover(allowed, tok);
1817             tok = tokenHashContents;
1818             return 1;
1819           }
1820           message(InterpreterMessages::unknownNamedConstant,
1821                   StringMessageArg(tem));
1822           break;
1823         }
1824       case 'b':
1825       case 'o':
1826       case 'x':
1827       case 'd':
1828         extendToken();
1829         if (!(allowed & allowOtherExpr))
1830           return tokenRecover(allowed, tok);
1831         tok = tokenNumber;
1832         currentToken_.assign(in->currentTokenStart(),
1833                              in->currentTokenLength());
1834         return 1;
1835       case 'A':
1836         extendToken();
1837         if (!(allowed & allowOtherExpr))
1838           return tokenRecover(allowed, tok);
1839         tok = tokenGlyphId;
1840         currentToken_.assign(in->currentTokenStart() + 2,
1841                              in->currentTokenLength() - 2);
1842         return 1;
1843       case InputSource::eE:
1844         message(InterpreterMessages::unexpectedEof);
1845         if (allowed & allowEndOfEntity) {
1846           tok = tokenEndOfEntity;
1847           return 1;
1848         }
1849         return 0;
1850       case 'v':
1851         if (dsssl2()) {
1852           if (!(allowed & allowOtherExpr))
1853             return tokenRecover(allowed, tok);
1854           tok = tokenVoid;
1855           return 1;
1856         }
1857         // fall through
1858       case '(':
1859         if (dsssl2()) {
1860           if (!(allowed & allowVector))
1861             return tokenRecover(allowed, tok);
1862           tok = tokenVector;
1863           return 1;
1864         }
1865         //fall through
1866       default:
1867         message(InterpreterMessages::unknownHash);
1868         break;
1869       }
1870       break;
1871     case '"':
1872       if (!(allowed & allowString))
1873         return tokenRecover(allowed, tok);
1874       return scanString(allowed, tok);
1875     case ';':
1876       skipComment();
1877       break;
1878     case '.':
1879       extendToken();
1880       switch (in->currentTokenLength()) {
1881       case 1:
1882         if (!(allowed & allowPeriod))
1883           return tokenRecover(allowed, tok);
1884         tok = tokenPeriod;
1885         return 1;
1886       case 3:
1887         if (in_->currentTokenStart()[1] == '.'
1888             && in_->currentTokenStart()[2] == '.')
1889           return handleIdentifier(allowed, tok);
1890         break;
1891       }
1892       return handleNumber(allowed, tok);
1893     default:
1894       switch (interp_->lexCategory(c)) {
1895       case Interpreter::lexAddWhiteSpace:
1896         break;
1897       case Interpreter::lexOtherNumberStart:
1898         extendToken();
1899         // handle + and - as identifiers
1900         if (in->currentTokenLength() == 1)
1901           return handleIdentifier(allowed, tok);
1902         return handleNumber(allowed, tok);
1903       case Interpreter::lexDigit:
1904         extendToken();
1905         return handleNumber(allowed, tok);
1906       case Interpreter::lexOther:
1907         if (c < ' ') {
1908           // ignore control characters
1909           message(InterpreterMessages::invalidChar);
1910           break;
1911         }
1912         in->ungetToken();
1913         // fall through
1914       default:
1915         {
1916           bool invalid = 0;
1917           size_t length = in->currentTokenLength();
1918           for (;;) {
1919             Interpreter::LexCategory lc = interp_->lexCategory(in->tokenChar(*this));
1920             if (lc > Interpreter::lexOther)
1921               break;
1922             if (lc == Interpreter::lexOther)
1923               invalid = 1;
1924             length++;
1925           }
1926           in->endToken(length);
1927
1928           if (in->currentTokenEnd()[-1] == ':'
1929               && in->currentTokenLength() > 1) {
1930             if (!(allowed & allowKeyword))
1931               return tokenRecover(allowed, tok);
1932             currentToken_.assign(in->currentTokenStart(),
1933                                  in->currentTokenLength() - 1);
1934             tok = tokenKeyword;
1935             if (invalid || (currentToken_.size() > 1
1936                   && currentToken_[currentToken_.size() - 1] == ':'))
1937               message(InterpreterMessages::invalidIdentifier,
1938                       StringMessageArg(currentToken_));
1939             return 1;
1940           }
1941           if (invalid)
1942             message(InterpreterMessages::invalidIdentifier,
1943                     StringMessageArg(StringC(in->currentTokenStart(),
1944                                              in->currentTokenLength())));
1945           return handleIdentifier(allowed, tok);
1946         }
1947       }
1948     }
1949   }
1950 }
1951
1952 bool SchemeParser::handleNumber(unsigned allowed, Token &tok)
1953 {
1954   if (!(allowed & allowOtherExpr))
1955     return tokenRecover(allowed, tok);
1956   tok = tokenNumber;
1957   currentToken_.assign(in_->currentTokenStart(),
1958                        in_->currentTokenLength());
1959   return 1;
1960 }
1961
1962 bool SchemeParser::handleIdentifier(unsigned allowed, Token &tok)
1963 {
1964   if (!(allowed & allowIdentifier))
1965     return tokenRecover(allowed, tok);
1966   currentToken_.assign(in_->currentTokenStart(),
1967                        in_->currentTokenLength());
1968   tok = tokenIdentifier;
1969   return 1;
1970 }
1971
1972 bool SchemeParser::tokenRecover(unsigned allowed, Token &tok)
1973 {
1974   if (allowed == allowCloseParen) {
1975     in_->ungetToken();
1976     tok = tokenCloseParen;
1977     message(InterpreterMessages::missingCloseParen);
1978     return 1;
1979   }
1980   if (in_->currentTokenLength() == 0)
1981     message(InterpreterMessages::unexpectedEof);
1982   else
1983     message(InterpreterMessages::unexpectedToken,
1984             StringMessageArg(StringC(in_->currentTokenStart(),
1985                                      in_->currentTokenLength())));
1986   return 0;
1987 }
1988
1989 void SchemeParser::extendToken()
1990 {
1991   // extend to a delimiter
1992   InputSource *in = in_.pointer();
1993   size_t length = in->currentTokenLength();
1994   while (interp_->lexCategory(in->tokenChar(*this))
1995          <= Interpreter::lexOther)
1996     length++;
1997   in->endToken(length);
1998 }
1999
2000 bool SchemeParser::scanString(unsigned allowed, Token &tok)
2001 {
2002   InputSource *in = in_.pointer();
2003   currentToken_.resize(0);
2004   for (;;) {
2005     Xchar c = in->tokenChar(*this);
2006     switch (c) {
2007     case InputSource::eE:
2008       message(InterpreterMessages::unterminatedString);
2009       in->endToken(1);
2010       return 0;
2011     case '"':
2012       tok = tokenString;
2013       return 1;
2014     case '\\':
2015       c = in->tokenChar(*this);
2016       if (c == '\\' || c == '"')
2017         currentToken_ += c;
2018       else if (c == InputSource::eE)
2019         break;
2020       else {
2021         StringC name;
2022         name += c;
2023         while (interp_->lexCategory(c = in->tokenChar(*this)) < Interpreter::lexOther)
2024           name += c;
2025         if (c != ';')
2026           in->endToken(in->currentTokenLength() - 1);
2027         Char ch;
2028         if (interp_->convertCharName(name, ch))
2029           currentToken_ += ch;
2030         else
2031           message(InterpreterMessages::unknownCharName, StringMessageArg(name));
2032       }
2033       break;
2034     default:
2035       currentToken_ += c;
2036       break;
2037     }
2038   }
2039   return 0; // not reached
2040 }
2041
2042 void SchemeParser::skipComment()
2043 {
2044   for (;;) {
2045     Xchar c = in_->get(*this);
2046     if (c == InputSource::eE || c == '\r')
2047       break;
2048   }
2049 }
2050
2051 ELObj *SchemeParser::convertAfiiGlyphId(const StringC &str)
2052 {
2053   unsigned long n = 0;
2054   for (size_t i = 0; i < str.size(); i++) {
2055     if (str[i] < '0' || str[i] > '9') {
2056       n = 0;
2057       break;
2058     }
2059     // FIXME check for overflow
2060     n = n*10 + (str[i] - '0');
2061   }
2062   if (n == 0) {
2063     message(InterpreterMessages::invalidAfiiGlyphId, StringMessageArg(str));
2064     return 0;
2065   }
2066   return new (*interp_) GlyphIdObj(FOTBuilder::GlyphId(afiiPublicId_, n));
2067 }
2068
2069 void SchemeParser::dispatchMessage(Message &msg)
2070 {
2071   interp_->dispatchMessage(msg);
2072 }
2073
2074 void SchemeParser::dispatchMessage(const Message &msg)
2075 {
2076   interp_->dispatchMessage(msg);
2077 }
2078
2079 void SchemeParser::initMessage(Message &msg)
2080 {
2081   if (in_)
2082     msg.loc = in_->currentLocation();
2083 }
2084
2085 bool SchemeParser::doDeclareDefaultLanguage()
2086 {
2087   Location loc(in_->currentLocation());
2088   Owner<Expression> expr;
2089   Token tok;
2090   Identifier::SyntacticKey key;
2091   if (!parseExpression(0, expr, key, tok))
2092     return 0;
2093   if (!getToken(allowCloseParen, tok))
2094     return 0;
2095   Location defLoc;
2096   unsigned defPart;
2097   if(interp_->defaultLanguageSet(defPart, defLoc)
2098      && defPart <= interp_->currentPartIndex()) {
2099     if(defPart == interp_->currentPartIndex()) {
2100       interp_->setNextLocation(loc);
2101       message(InterpreterMessages::duplicateDefLangDecl, defLoc);
2102     }
2103   }
2104   else
2105     interp_->setDefaultLanguage(expr, interp_->currentPartIndex(), loc);
2106   return 1;
2107 }
2108
2109 bool SchemeParser::doDefineLanguage()
2110 {
2111   Location loc(in_->currentLocation());
2112   Token tok;
2113   if (!getToken(allowIdentifier, tok))
2114     return 0;
2115   Identifier *ident = lookup(currentToken_);
2116   Identifier::SyntacticKey key;
2117   if (ident->syntacticKey(key) && (key <= int(Identifier::lastSyntacticKey)))
2118     message(InterpreterMessages::syntacticKeywordAsVariable,
2119             StringMessageArg(currentToken_));
2120   Location defLoc;
2121   unsigned defPart;
2122   if (ident->defined(defPart, defLoc)
2123       && defPart <= interp_->currentPartIndex()) {
2124     if (defPart == interp_->currentPartIndex()) {
2125       message(InterpreterMessages::duplicateDefinition,
2126               StringMessageArg(ident->name()),
2127               defLoc);
2128       return 0;
2129     }
2130   }
2131   lang_ = new (*interp_) LangObj;
2132   for (;;) {
2133     if (!getToken(allowOpenParen|allowCloseParen, tok))
2134       return 0;
2135     if (tok == tokenCloseParen)
2136       break;
2137     if (!getToken(allowIdentifier, tok))
2138       return 0;
2139     const Identifier *ident = lookup(currentToken_);
2140     Identifier::SyntacticKey key;
2141     if (!ident->syntacticKey(key))
2142       return 0;
2143     else {
2144       switch (key) {
2145       case Identifier::keyCollate:
2146         if (!doCollate())
2147           return 0;
2148         break;
2149       case Identifier::keyToupper:
2150         if (!doToupper())
2151           return 0;
2152         break;
2153       case Identifier::keyTolower:
2154         if (!doTolower())
2155           return 0;
2156         break;
2157       default:
2158         return 0;
2159       }
2160     }
2161   }
2162   if (!lang_->compile())
2163     return 0;
2164   interp_->makePermanent(lang_);
2165   Owner<Expression> expr;
2166   expr = new ConstantExpression(lang_, in_->currentLocation());
2167   lang_ = 0;
2168   ident->setDefinition(expr, interp_->currentPartIndex(), loc);
2169   return 1;
2170 }
2171
2172 bool SchemeParser::doCollate()
2173 {
2174   Token tok;
2175   for (;;) {
2176     if (!getToken(allowOpenParen|allowCloseParen, tok))
2177       return 0;
2178     if (tok == tokenCloseParen)
2179       break;
2180     if (!getToken(allowIdentifier, tok))
2181       return 0;
2182     const Identifier *ident = lookup(currentToken_);
2183     Identifier::SyntacticKey key;
2184     if (!ident->syntacticKey(key)) {
2185       return 0;
2186     } else {
2187       switch (key) {
2188       case Identifier::keyElement:
2189         if (!doMultiCollatingElement())
2190           return 0;
2191         break;
2192       case Identifier::keySymbol:
2193         if (!doCollatingSymbol())
2194           return 0;
2195         break;
2196       case Identifier::keyOrder:
2197         if (!doCollatingOrder())
2198           return 0;
2199         break;
2200       default:
2201         return 0;
2202       }
2203     }
2204   }
2205   return 1;
2206 }
2207
2208 bool SchemeParser::doMultiCollatingElement()
2209 {
2210   Token tok;
2211   if (!getToken(allowIdentifier, tok))
2212     return 0;
2213   StringC sym(currentToken_);
2214   if (!getToken(allowString, tok))
2215     return 0;
2216   StringC str(currentToken_);
2217   if (!getToken(allowCloseParen, tok))
2218     return 0;
2219   lang_->addMultiCollatingElement(sym, str);
2220   return 1;
2221 }
2222
2223 bool SchemeParser::doCollatingSymbol()
2224 {
2225   Token tok;
2226   if (!getToken(allowIdentifier, tok))
2227     return 0;
2228   StringC sym(currentToken_);
2229   if (!getToken(allowCloseParen, tok))
2230     return 0;
2231   lang_->addCollatingSymbol(sym);
2232   return 1;
2233 }
2234
2235 bool SchemeParser::doCollatingOrder()
2236 {
2237   Token tok;
2238   if (!getToken(allowOpenParen, tok))
2239     return 0;
2240   int nested = 0;
2241   LangObj::LevelSort sort = { 0, 0, 0};
2242   for (;;) {
2243     if (!getToken(((nested == 0) ? allowOpenParen : 0)|
2244                   allowCloseParen|allowIdentifier, tok))
2245       return 0;
2246     if (tok == tokenOpenParen)
2247       nested++;
2248     else if (tok == tokenCloseParen)
2249       nested--;
2250     else {
2251       const Identifier *ident = lookup(currentToken_);
2252       Identifier::SyntacticKey key;
2253       if (!ident->syntacticKey(key))
2254         return 0;
2255       switch (key) {
2256         case Identifier::keyForward:
2257           if (sort.backward)
2258             return 0;
2259           sort.forward = 1;
2260           break;
2261         case Identifier::keyBackward:
2262           if (sort.forward)
2263             return 0;
2264           sort.backward = 1;
2265           break;
2266         case Identifier::keyPosition:
2267           sort.position = 1;
2268           break;
2269         default:
2270           return 0;
2271         }
2272       }
2273     if (nested < 0)
2274       break;
2275     if (nested == 0) {
2276       if (!sort.backward)
2277         sort.forward = 1;
2278       lang_->addLevel(sort);
2279     }
2280   }
2281   for (;;) {
2282     if (!getToken(allowOpenParen|
2283                   allowCloseParen|
2284                   allowIdentifier|
2285                   allowOtherExpr, tok))
2286       return 0;
2287     if (tok == tokenCloseParen)
2288       break;
2289     StringC empty;
2290     switch (tok) {
2291     case tokenTrue:
2292       lang_->addDefaultPos();
2293       for(Char i = 0; i < lang_->levels(); i++)
2294         lang_->addLevelWeight(i, empty);
2295       break;
2296     case tokenIdentifier:
2297     case tokenChar:
2298        if (!lang_->addCollatingPos(currentToken_))
2299         return 0;
2300       for (unsigned i = 0; i < lang_->levels(); i++)
2301         lang_->addLevelWeight(i, currentToken_);
2302       break;
2303     case tokenOpenParen:
2304       if (!doWeights())
2305         return 0;
2306       break;
2307     default:
2308       return 0;
2309     }
2310   }
2311   return 1;
2312 }
2313
2314 bool SchemeParser::doWeights()
2315 {
2316   Token tok;
2317   if (!getToken(allowIdentifier|allowOtherExpr, tok))
2318     return 0;
2319   StringC sym(currentToken_);
2320   if (!lang_->addCollatingPos(sym))
2321     return 0;
2322   int nested = 0;
2323   unsigned l = 0;
2324   for (;;) {
2325     if (!getToken((nested ? 0 : allowOpenParen)|
2326                   allowCloseParen|
2327                   allowIdentifier|
2328                   allowOtherExpr|
2329                   allowString, tok))
2330       return 0;
2331     if (tok == tokenOpenParen)
2332       nested++;
2333     else if (tok == tokenCloseParen)
2334       nested--;
2335     else {
2336       switch (tok) {
2337       case tokenString:
2338          for (size_t i = 0; i < currentToken_.size(); i++) {
2339           StringC ctok(&(currentToken_[i]), 1);
2340           if (!lang_->addLevelWeight(l, ctok))
2341             return 0;
2342         }
2343         break;
2344       case tokenIdentifier:
2345       case tokenChar:
2346         if (!lang_->addLevelWeight(l, currentToken_))
2347           return 0;
2348         break;
2349       default:
2350         return 0;
2351       }
2352     }
2353     if (nested < 0)
2354       break;
2355     if (nested == 0)
2356       l++;
2357   }
2358   return 1;
2359 }
2360
2361 bool SchemeParser::doToupper()
2362 {
2363   Token tok;
2364   for (;;) {
2365     if (!getToken(allowOpenParen|allowCloseParen, tok))
2366       return 0;
2367     if (tok == tokenCloseParen) break;
2368     if (!getToken(allowOtherExpr, tok) || (tok != tokenChar))
2369       return 0;
2370     Char lc = currentToken_[0];
2371     if (!getToken(allowOtherExpr, tok) || (tok != tokenChar))
2372       return 0;
2373     Char uc = currentToken_[0];
2374     if (!getToken(allowCloseParen, tok))
2375       return 0;
2376     lang_->addToupper(lc, uc);
2377   }
2378   return 1;
2379 }
2380
2381 bool SchemeParser::doTolower()
2382 {
2383   Token tok;
2384   for (;;) {
2385     if (!getToken(allowOpenParen|allowCloseParen, tok))
2386       return 0;
2387     if (tok == tokenCloseParen) break;
2388     if (!getToken(allowOtherExpr, tok) || (tok != tokenChar))
2389       return 0;
2390     Char uc = currentToken_[0];
2391     if (!getToken(allowOtherExpr, tok) || (tok != tokenChar))
2392       return 0;
2393     Char lc = currentToken_[0];
2394     if (!getToken(allowCloseParen, tok))
2395       return 0;
2396     lang_->addTolower(uc, lc);
2397   }
2398   return 1;
2399 }
2400
2401 bool SchemeParser::parseSpecialQuery(Owner<Expression> &rexp, const char *query)
2402 {
2403   Location loc(in_->currentLocation());
2404   Token tok;
2405   if (!getToken(allowIdentifier, tok))
2406     return 0;
2407   Vector<const Identifier *> vars;
2408   vars.push_back(lookup(currentToken_));
2409   Identifier::SyntacticKey key;
2410   if (vars.back()->syntacticKey(key) && key <= int(Identifier::lastSyntacticKey))
2411     message(InterpreterMessages::syntacticKeywordAsVariable,
2412             StringMessageArg(currentToken_));
2413
2414   Owner<Expression> op(new ConstantExpression(
2415     interp_->lookup(interp_->makeStringC(query))->computeBuiltinValue(1, *interp_),
2416     loc));
2417   NCVector<Owner<Expression> > inits, args(2);
2418   Owner<Expression> expr;
2419   if (!parseExpression(0, args[1], key, tok)
2420       || !parseExpression(0, expr, key, tok)
2421       || !getToken(allowCloseParen, tok))
2422     return 0;
2423   args[0] = new LambdaExpression(vars, inits, 0, 0, 0, expr, loc);
2424   rexp = new CallExpression(op, args, loc);
2425   return 1;
2426 }
2427
2428 bool SchemeParser::doDeclareCharProperty()
2429 {
2430   Token tok;
2431   if (!getToken(allowIdentifier, tok))
2432     return 0;
2433   Identifier *ident = lookup(currentToken_);
2434   Owner<Expression> expr;
2435   Identifier::SyntacticKey key;
2436   if (!parseExpression(0, expr, key, tok))
2437     return 0;
2438   if (!getToken(allowCloseParen, tok))
2439     return 0;
2440   interp_->addCharProperty(ident, expr);
2441   return 1;
2442 }
2443
2444 bool SchemeParser::doAddCharProperties()
2445 {
2446   NCVector<Owner<Expression> > exprs;
2447   Vector<const Identifier *> keys;
2448   Token tok;
2449   for (;;) {
2450     if (!getToken(allowKeyword|allowOtherExpr, tok))
2451       return 0;
2452     if (tok!=tokenKeyword)
2453       break;
2454     keys.push_back(lookup(currentToken_));
2455     exprs.resize(exprs.size() + 1);
2456     Identifier::SyntacticKey key;
2457     if (!parseExpression(0, exprs.back(), key, tok))
2458       return 0;
2459   }
2460
2461   for(;;) {
2462     if (tok!=tokenChar) {
2463       message(InterpreterMessages::badAddCharProperty);
2464       return 0;
2465     }
2466     for (size_t j = 0; j < keys.size(); j++)
2467       interp_->setCharProperty(keys[j], currentToken_[0], exprs[j]);
2468     if(!getToken(allowOtherExpr|allowCloseParen, tok))
2469       return 0;
2470     if (tok==tokenCloseParen)
2471       break;
2472   }
2473   return 1;
2474 }
2475
2476
2477 #ifdef DSSSL_NAMESPACE
2478 }
2479 #endif