Changeset 6594

Timestamp:

08/30/05 22:57:49 (3 years ago)

Author:

putter

Message:

pugs - a Syn package/namespace now remembers whether it was a package/module/class/etc. When compiling to PIL, emit a kludge declaration info statement (eg &Module::_create("M"); for a module M {...}).
Prelude/JS.pm: added placeholder hooks for declaration info calls.

Files:

• perl5/PIL2JS/lib6/Prelude/JS.pm (modified) (1 diff)
• src/Pugs/AST.hs (modified) (1 diff)
• src/Pugs/Compile.hs (modified) (1 diff)
• src/Pugs/Eval.hs (modified) (1 diff)
• src/Pugs/Parser.hs (modified) (3 diffs)

perl5/PIL2JS/lib6/Prelude/JS.pm

@@ -108 +108 @@
   })')($sigil ~ join "::", @parts);
 }
+
+
+# XXX PIL1 pugs -C kludge.
+sub Package::_create($name) {}
+sub Module::_create($name) {}
+sub Class::_create($name) {}
+sub Rule::_create($name) {}
+sub Grammar::_create($name) {}

src/Pugs/AST.hs

@@ -124 +124 @@
 mergeStmts (Sym scope name x) y = Sym scope name (mergeStmts x y)
 mergeStmts (Pad scope lex x) y = Pad scope lex (mergeStmts x y)
-mergeStmts (Syn "package" [pkg@(Val (VStr _))]) y =
-    Syn "namespace" [pkg, y]
+mergeStmts (Syn "package" [kind, pkg@(Val (VStr _))]) y =
+    Syn "namespace" [kind, pkg, y]
 mergeStmts x@(Pos pos (Syn syn _)) y | (syn ==) `any` words "subst match //"  =
     mergeStmts (Pos pos (App (Var "&infix:~~") Nothing [Var "$_", x])) y

src/Pugs/Compile.hs

@@ -167 +167 @@
         tailCall (PPos pos exp x) = PPos pos exp (tailCall x)
         tailCall x = x
-    Stmts this (Syn "namespace" [Val (VStr pkg), rest]) -> do
+    Stmts this (Syn "namespace" [Val (VStr sym), Val (VStr pkg), rest]) -> do
         thisC   <- enter cxtVoid $ compile this
+        declC   <- enter cxtVoid $ compile decl
         restC   <- enterPackage pkg $ compileStmts rest
-        return $ PStmts thisC restC
+        return $ PStmts thisC $ PStmts declC restC
+        where
+          -- XXX - kludge.
+          decl = App (Var func) Nothing [(Val (VStr pkg))]
+          func = "&" ++ (capitalize sym) ++ "::_create"
+          capitalize []     = []
+          capitalize (c:cs) = toUpper c:cs
+
     Stmts this rest -> do
         thisC   <- enter cxtVoid $ compile this

src/Pugs/Eval.hs

@@ -688 +688 @@
     retEmpty
 
-reduceSyn "package" [exp] = reduceSyn "namespace" [exp, emptyExp]
-
-reduceSyn "namespace" [exp, body] = do
+reduceSyn "package" [kind, exp] = reduceSyn "namespace" [kind, exp, emptyExp]
+
+reduceSyn "namespace" [_kind, exp, body] = do
     val <- evalExp exp
     str <- fromVal val

src/Pugs/Parser.hs

@@ -315 +315 @@
 rulePackageBlockDeclaration :: RuleParser Exp
 rulePackageBlockDeclaration = rule "package block declaration" $ do
-    (_, pkgVal, env) <- try $ do
+    (_, kind, pkgVal, env) <- try $ do
         rv <- rulePackageHead
         lookAhead (char '{')
@@ -322 +322 @@
     env' <- getRuleEnv
     putRuleEnv env'{ envPackage = envPackage env }
-    return $ Syn "namespace" [pkgVal, body]
+    return $ Syn "namespace" [kind, pkgVal, body]
 
 rulePackageDeclaration :: RuleParser Exp
 rulePackageDeclaration = rule "package declaration" $ try $ do
-    (_, pkgVal, _) <- rulePackageHead
-    return $ Syn "package" [pkgVal]
-
-rulePackageHead :: RuleParser (String, Exp, Env)
+    (_, kind, pkgVal, _) <- rulePackageHead
+    return $ Syn "package" [kind, pkgVal]
+
+rulePackageHead :: RuleParser (String, Exp, Exp, Env)
 rulePackageHead = do
     sym <- choice $ map symbol (words "package module class role grammar")
@@ -349 +349 @@
                     envClasses = envClasses env `addNode` mkType name }
     let pkgVal = Val . VStr $ name -- ++ v ++ a
-    return (name, pkgVal, env)
+        kind   = Val . VStr $ sym
+    return (name, kind, pkgVal, env)
 
 ruleSubDeclaration :: RuleParser Exp