Changeset 7
- Timestamp:
- 02/09/05 06:00:26 (4 years ago)
- svk:copy_cache_prev:
- 1041
- Files:
-
- 1 added
- 13 modified
-
AUTHORS (modified) (1 diff)
-
MANIFEST (modified) (2 diffs)
-
Makefile.PL (modified) (2 diffs)
-
lib/Perl6/Pugs.pm (modified) (3 diffs)
-
src/AST.hs (modified) (11 diffs)
-
src/Context.hs (added)
-
src/Eval.hs (modified) (2 diffs)
-
src/Help.hs (modified) (3 diffs)
-
src/Internals.hs (modified) (3 diffs)
-
src/Lexer.hs (modified) (3 diffs)
-
src/Parser.hs (modified) (5 diffs)
-
src/Pretty.hs (modified) (1 diff)
-
src/Prim.hs (modified) (8 diffs)
-
t/01basic.t (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
AUTHORS
r6 r7 4 4 the appropriate patches. Corrections, additions, deletions welcome: 5 5 6 Bestian Tang 6 7 Brian Ingerson (INGY) 7 8 Damian Conway (DCONWAY) -
MANIFEST
r6 r7 18 18 SIGNATURE Public-key signature (added by MakeMaker) 19 19 src/AST.hs 20 src/Context.hs 20 21 src/Eval.hs 21 22 src/Help.hs … … 27 28 src/Prim.hs 28 29 src/Shell.hs 30 t/01basic.t -
Makefile.PL
r5 r7 2 2 3 3 use strict; 4 use FindBin; 4 5 use inc::Module::Install; 6 7 chdir $FindBin::Bin; 5 8 6 9 name ('Perl6-Pugs'); … … 33 36 34 37 38 open IN, '< lib/Perl6/Pugs.pm' or die $!; 35 39 open FH, '> config.h' or die $!; 40 41 while (<IN>) { 42 /version (\S+) .*\breleased (.*)\./ or next; 43 print FH << "."; 44 45 #ifdef VERSION 46 #undef VERSION 47 #endif 48 #define VERSION "$1" 49 50 #ifdef DATE 51 #undef DATE 52 #endif 53 #define DATE "$2" 54 55 . 56 last; 57 } 58 36 59 if ($has_readline) { 37 60 print FH "#define READLINE 1\n"; -
lib/Perl6/Pugs.pm
r6 r7 1 1 package Perl6::Pugs; 2 $Pugs::VERSION = '6.0. 1';2 $Pugs::VERSION = '6.0.2'; 3 3 4 4 use strict; … … 10 10 =head1 VERSION 11 11 12 This document describes version 6.0. 1 of Pugs, released February 7, 2005.12 This document describes version 6.0.2 of Pugs, released February 9, 2005. 13 13 14 14 =head1 SYNOPSIS 15 15 16 % pugs -e "'Hello, World!'"16 % pugs -e 'sub hi { "Hello, " ~ $_ } ; hi "World!\n"' 17 17 Hello, World! 18 18 … … 56 56 =over 4 57 57 58 =item * C<@*ARGS>, C<$*PID>, C<$*PROGRAM_NAME>, etc. .58 =item * C<@*ARGS>, C<$*PID>, C<$*PROGRAM_NAME>, etc. 59 59 60 =item * C<< <> >> (lazily-evaluated lines of input) 60 =item * C<< <> >> (lazily-evaluated lines of input). 61 61 62 62 =item * The toplevel evaluation result is printed under flattened list context with items stringified. -
src/AST.hs
r4 r7 15 15 import Internals 16 16 17 import Context 18 17 19 type Ident = String 18 20 … … 25 27 vCast (VPair _ v) = vCast v 26 28 vCast v = doCast v 29 castV :: n -> Val 30 castV v = error $ "cannot cast into Val" 27 31 doCast :: Val -> n 28 doCast v = error $ "cannot cast: " ++ (show v) 32 doCast v = error $ "cannot cast from Val: " ++ (show v) 33 fmapVal :: (n -> n) -> Val -> Val 34 fmapVal f = castV . f . vCast 35 36 instance Context VSub where 37 castV = VSub 38 doCast (VSub b) = b 29 39 30 40 instance Context VBool where 41 castV = VBool 31 42 doCast (VJunc j l) = juncToBool j l 32 43 doCast (VBool b) = b … … 47 58 48 59 instance Context VInt where 60 castV = VInt 49 61 doCast (VInt i) = i 50 62 doCast (VStr s) … … 54 66 55 67 instance Context VRat where 68 castV = VRat 56 69 doCast (VInt i) = i % 1 57 70 doCast (VRat r) = r … … 59 72 60 73 instance Context VNum where 74 castV = VNum 61 75 doCast VUndef = 0 62 76 doCast (VBool b) = if b then 1 else 0 … … 71 85 72 86 instance Context VComplex where 87 castV = VComplex 73 88 doCast x = (vCast x :: VNum) :+ 0 74 89 75 90 instance Context VStr where 91 castV = VStr 76 92 vCast VUndef = "" 77 93 vCast (VStr s) = s … … 93 109 94 110 instance Context VList where 111 castV = VList 95 112 vCast (VList l) = l 96 113 vCast (VPair k v) = [k, v] … … 110 127 111 128 instance Context VScalar where 112 vCast x = x 129 vCast = id 130 castV = id 113 131 114 132 strRangeInf s = (s:strRangeInf (strInc s)) … … 148 166 instance (Show a, Show b) => Show (FiniteMap a b) where 149 167 show fm = show (fmToList fm) 150 151 instance (Ord a, Ord b) => Ord (FiniteMap a b) where152 153 instance Ord VComplex where154 {- ... -}155 168 156 169 data Val … … 167 180 | VRef Val 168 181 | VPair Val Val 169 | VSub Exp182 | VSub VSub 170 183 | VBlock Exp 171 184 | VJunc JuncType [Val] 172 185 | VError VStr Exp 173 | VPoly { polyScalar :: Val 174 , polyList :: Val 175 } 186 deriving (Show, Eq, Ord) 187 188 data SubType = SubMethod | SubRoutine | SubMulti 189 deriving (Show, Eq, Ord) 190 191 data VSub = Sub 192 { subType :: SubType 193 , subAssoc :: String 194 , subParams :: [Cxt] 195 , subReturns :: Cxt 196 , subFun :: Exp 197 } 176 198 deriving (Show, Eq, Ord) 177 199 … … 184 206 deriving (Show, Eq, Ord) 185 207 208 instance Eq ([Val] -> Val) 209 instance Ord ([Val] -> Val) 210 instance Ord VComplex where {- ... -} 211 instance (Ord a, Ord b) => Ord (FiniteMap a b) 212 213 type Var = String 214 186 215 data Exp 187 = Op1 String Exp 188 | Op2 String Exp Exp 189 | Op3 String Exp Exp Exp 190 | OpCmp String Exp Exp 216 = App String [Exp] 217 | Syn String [Exp] 218 | Prim ([Val] -> Val) 191 219 | Val Val 220 | Var Var SourcePos 221 | Parens Exp 192 222 | NonTerm SourcePos 193 223 deriving (Show, Eq, Ord) 224 225 isTotalJunc (VJunc JAll _, b) = not b 226 isTotalJunc (VJunc JNone _, b) = not b 227 isTotalJunc _ = False 228 229 isPartialJunc (VJunc JOne _, b) = not b 230 isPartialJunc (VJunc JAny _, b) = not b 231 isPartialJunc _ = False 232 -
src/Eval.hs
r1 r7 4 4 Evaluation and reduction engine. 5 5 6 Tree and flower and leaf and grass, 7 Let them pass! Let them pass! 8 Hill and water under sky, 9 Pass them by! Pass them by! 6 Home is behind, the world ahead, 7 And there are many paths to tread 8 Through shadows to the edge of night, 9 Until the stars are all alight. 10 Then world behind and home ahead, 11 We'll wander back to home and bed... 10 12 -} 11 13 12 14 module Eval where 15 import Internals 16 13 17 import AST 14 18 import Prim 19 import Context 15 20 16 type Env = () 17 emptyEnv = () 21 data Env = Env { cxt :: Cxt 22 , sym :: Symbols 23 , cls :: ClassTree 24 } deriving (Show) 25 emptyEnv = Env { cxt = "List" 26 , sym = initSyms 27 , cls = initTree 28 } 29 30 addSym :: Env -> [(String, Val)] -> Env 31 addSym env [] = env 32 addSym env ((var, val):vs) = env{ sym = (var, val):(sym $ addSym env vs) } 18 33 19 34 evaluate :: Env -> Exp -> Val 20 evaluate env exp21 | Val v <- reduce env exp= v22 | otherwise = VError "invalid expression" exp23 24 -- Lazy evaluation for lists. 25 -- Context propagation. 35 evaluate env@Env{ cxt = cxt, cls = cls } exp 36 | Val v <- val = v 37 | otherwise = VError "Invalid expression" exp 38 where 39 (env', val) = reduce env exp 40 isaContext = isaType cls cxt 26 41 27 42 -- OK... Now let's implement the hideously clever autothreading algorithm. … … 44 59 = Nothing 45 60 46 reduce :: Env -> Exp -> Exp 47 reduce env (Op1 name exp) 48 | VError _ _ <- arg 49 = Val $ arg 50 | VJunc j l <- arg 51 = if name == "?" 52 then Val $ VBool (vCast arg) 53 else Val $ VJunc j [ reval a | a <- l ] 61 applyFun :: Env -> Exp -> [Val] -> Val 62 applyFun env (Prim f) vals = f vals 63 applyFun env body vals 64 | Val val <- exp = val 65 | otherwise = VError "Invalid expression" exp 66 where 67 (fenv, exp) = reduce (env `addSym` [("$_", head vals),("@_", VList vals)]) body 68 69 chainFun :: Env -> Exp -> Exp -> [Val] -> Val 70 chainFun env f1 f2 (v1:v2:vs) 71 | VBool False <- applyFun env f1 [v1, v2] 72 = VBool False 54 73 | otherwise 55 = Val $ op1 name (vCast arg) 74 = applyFun env f2 (v2:vs) 75 76 apply :: Env -> VSub -> [Exp] -> ((Env -> Env), Exp) 77 apply env@Env{ cls = cls } Sub{ subParams = prms, subFun = fun } exps 78 = retVal $ juncApply eval args 56 79 where 57 arg = evaluate env exp 58 reval = evaluate env . Op1 name . Val 80 eval = applyFun env fun 81 args = map expToVal (prms `zip` exps) 82 expToVal (cxt, exp) = (evaluate env{ cxt = cxt } exp, isaType cls cxt "Bool") 59 83 60 reduce env (OpCmp name exp1 exp2) 61 | OpCmp _ _ exp1b <- exp1 62 = reduce env $ Op2 "&&" exp1 $ Op2 name exp1b exp2 84 juncApply f args 85 | (before, (VJunc j vs, cxt):after) <- break isTotalJunc args 86 = VJunc j [ juncApply f (before ++ ((v, cxt):after)) | v <- vs ] 87 | (before, (VJunc j vs, cxt):after) <- break isPartialJunc args 88 = VJunc j [ juncApply f (before ++ ((v, cxt):after)) | v <- vs ] 89 | (val, _):_ <- [ err | err@(VError _ _, _) <- args ] 90 = val 63 91 | otherwise 64 = reduce env $ Op2 name exp1 exp292 = f $ map fst args 65 93 66 {- XXX - this really wants a rewrite with multi subs -} 67 reduce env (Op2 name exp1 exp2) 68 | name `elem` words " ! & | ^ && || ^^ // and or xor err " -- XXX contextify 69 = Val $ op arg1 arg2 70 | VError _ _ <- arg1 = Val $ arg1 71 | VError _ _ <- arg2 = Val $ arg2 72 -- two junctions, all/none at left 73 | Just (j1, l1) <- arg1 `juncTypeIs` [JAll, JNone] 74 , Just (j2, l2) <- juncType arg2 75 = Val $ VJunc j1 [ VJunc j2 [ reval a1 a2 | a2 <- l2 ] | a1 <- l1 ] 76 -- two junctions, all/none at right 77 | Just (j1, l1) <- juncType arg1 78 , Just (j2, l2) <- arg2 `juncTypeIs` [JAll, JNone] 79 = Val $ VJunc j2 [ VJunc j1 [ reval a1 a2 | a1 <- l1 ] | a2 <- l2 ] 80 -- two junctions with all low prec. 81 | Just (j1, l1) <- juncType arg1 82 , Just (j2, l2) <- juncType arg2 83 = Val $ VJunc j1 [ VJunc j2 [ reval a1 a2 | a2 <- l2 ] | a1 <- l1 ] 84 -- one junctions at left 85 | Just (j, l) <- juncType arg1 86 = Val $ VJunc j [ reval a arg2 | a <- l ] 87 -- one junctions at right 88 | Just (j, l) <- juncType arg2 89 = Val $ VJunc j [ reval arg1 a | a <- l ] 94 retVal :: Val -> ((Env -> Env), Exp) 95 retVal val = (id, Val val) 96 97 reduce :: Env -> Exp -> ((Env -> Env), Exp) 98 reduce env@Env{ sym = sym } exp@(Var var _) 99 | Just val <- lookup var sym 100 = retVal val 90 101 | otherwise 91 = Val $ op arg1 arg2 102 = retVal $ VError ("Undefined variable " ++ var) exp 103 104 reduce env@Env{ cxt = cxt } exp@(Syn name exps) 105 | name `isInfix` ";" 106 , [left, right] <- exps 107 , (env', exp) <- runStatement "Any" (env, Val VUndef) left 108 , (env', exp) <- runStatement cxt (env', exp) right 109 = (const env', exp) 110 | name `isInfix` ":=" 111 , [Var var _, exp] <- exps 112 , (fenv, Val val) <- reduce env exp 113 = (combineEnv fenv var val, Val val) 114 | name `isInfix` "::=" 115 , [Var var _, Val val] <- exps 116 = (combineEnv id var val, Val VUndef) 92 117 where 93 op = op2 name 94 arg1 = evaluate env exp1 95 arg2 = evaluate env exp2 96 reval x y = evaluate env $ Op2 name (Val x) (Val y) 118 runStatement :: Cxt -> (Env, Exp) -> Exp -> (Env, Exp) 119 runStatement cxt (env, (Val val)) exp 120 | VError _ _ <- val 121 = (env, Val val) 122 | (fenv, exp) <- reduce env{ cxt = cxt } exp 123 = (fenv env, exp) 124 | otherwise 125 = (env, Val $ VError "Unterminated statement" exp) 126 combineEnv f var val env = (f env) `addSym` [(var, val)] 127 isInfix name s = name == "&infix:" ++ s 97 128 98 reduce env other = other 129 reduce env@Env{ cxt = cxt, cls = cls } exp@(App name exps) 130 | Just sub <- findSub name 131 = applySub sub exps 132 | otherwise 133 = retVal $ VError ("Undefined subroutine " ++ name ++ (show $ sym env)) exp 134 where 135 applySub sub exps 136 -- list-associativity 137 | Sub{ subAssoc = "list" } <- sub 138 , (App name' exps'):rest <- exps 139 , name == name' 140 = applySub sub (exps' ++ rest) 141 -- fix subParams to agree with number of actual arguments 142 | Sub{ subAssoc = "list", subParams = (p:_) } <- sub 143 , trace ("meow " ++ (show exps)) True 144 = apply env sub{ subParams = (length exps) `replicate` p } exps 145 -- chain-associativity 146 | Sub{ subAssoc = "chain", subFun = fun } <- sub 147 , (App name' exps'):rest <- exps 148 , Just sub' <- findSub name' 149 , Sub{ subAssoc = "chain", subFun = fun' } <- sub' 150 = applySub sub{ subFun = Prim $ chainFun env fun' fun } (exps' ++ rest) 151 -- fix subParams to agree with number of actual arguments 152 | Sub{ subAssoc = "chain", subParams = (p:_) } <- sub 153 = apply env sub{ subParams = (length exps) `replicate` p } exps -- XXX Wrong 154 -- apply normally 155 | Sub{ subParams = [('*':p)] } <- sub -- XXX Wrong 156 = apply env sub{ subParams = (length exps) `replicate` p } exps 157 | otherwise 158 = apply env sub exps 159 findSub name 160 | ((_, sub):_) <- sort (subs name) = Just sub 161 | otherwise = Nothing 162 subs name = [ ((subT, deltaFromCxt ret : map deltaFromScalar prms), sub) 163 | (n, val) <- sym env 164 , let sub@(Sub{ subType = subT, subReturns = ret, subParams = prms }) = vCast val 165 , n == name 166 , arityMatch sub prms exps 167 , deltaFromCxt ret /= 0 168 ] 169 deltaFromCxt = deltaType cls cxt 170 deltaFromScalar x = deltaType cls x "Scalar" 171 arityMatch Sub{ subAssoc = assoc, subParams = prms } x y 172 | assoc == "list" = True 173 | Just _ <- find ((== '*') . head) prms 174 , assoc == "pre" = True 175 | (length x) == (length y) = True -- XXX - slurping star 176 | otherwise = False 99 177 178 reduce env (Parens exp) = reduce env exp 179 reduce env other = (id, other) 180 -
src/Help.hs
r1 r7 1 1 {-# OPTIONS -cpp #-} 2 #define VERSION "" 3 #define DATE "" 4 #include "config.h" 2 5 3 6 {- … … 26 29 27 30 name = "Perl6 User's Golfing System" 28 versnum = "6.0.0"29 date = "04 Feb 2005"31 versnum = VERSION 32 date = DATE 30 33 version = name ++ ", version " ++ versnum ++ ", " ++ date 31 copyright = "Copyright (c)2005 by Autrijus Tang"34 copyright = "Copyright 2005 by Autrijus Tang" 32 35 disclaimer = 33 36 "This software is distributed under the terms of the " ++ … … 45 48 [ ".=====. __ __ ____ ___ _________________________________________" 46 49 , "|| || || || || || ||__' Pugs 6: Based on the Perl 6 Synopses " 47 , "||====' ||__|| ||__|| __|| Copyright (c) 2005 Autrijus Tang "50 , "||====' ||__|| ||__|| __|| " ++ copyright 48 51 , "|| `====' ___|| `===' World Wide Web: http://autrijus.org/pugs " 49 52 , "|| `====' Report bugs to: autrijus@autrijus.org " 50 53 , "==" ++ versionFill 27 ++ " =========================================" 51 54 , "" 52 , "Welcome to Pugs -- Perl6 User's Golfing System"55 , "Welcome to Pugs -- " ++ name 53 56 , "Type :h for help" 54 57 ] -
src/Internals.hs
r4 r7 20 20 module Data.List, 21 21 module Data.Word, 22 module Data.Ratio, 22 23 module Data.Char, 24 module Data.Tree, 23 25 module Data.Maybe, 24 module Data.Ratio,25 26 module Data.Complex, 26 27 module Data.FiniteMap, … … 36 37 import Data.Bits 37 38 import Data.Maybe 39 import Data.List 38 40 import Data.Ratio 39 import Data.List40 41 import Data.Word 41 42 import Data.Char … … 43 44 import Data.Complex 44 45 import Data.FiniteMap 46 import Data.Tree 45 47 import Debug.Trace 46 48 import Text.ParserCombinators.Parsec -
src/Lexer.hs
r5 r7 19 19 , P.commentLine = "#" 20 20 , P.nestedComments = False 21 , P.identStart = letter <|> oneOf "_:$@%&"22 , P.identLetter = alphaNum <|> oneOf "_ :"21 , P.identStart = letter <|> char '_' 22 , P.identLetter = alphaNum <|> oneOf "_" 23 23 , P.reservedNames = words $ 24 24 "if then else do while skip" … … 46 46 float = P.float perl6Lexer 47 47 lexeme = P.lexeme perl6Lexer 48 identifier = P.identifier perl6Lexer 49 braces = P.braces perl6Lexer 50 brackets = P.brackets perl6Lexer 48 51 stringLiteral = choice 49 52 [ P.stringLiteral perl6Lexer … … 51 54 ] 52 55 53 naturalOrFloat = lexeme (natFloat) <?> "number" 56 naturalOrRat = do 57 b <- lexeme sign 58 n <- lexeme natRat 59 return $ if b 60 then n 61 else case n of 62 Left x -> Left $ -x 63 Right y -> Right $ -y 64 <?> "number" 54 65 where 55 nat Float = do{ char '0'56 ; zeroNumFloat57 }58 <|> decimalFloat66 natRat = do 67 char '0' 68 zeroNumRat 69 <|> decimalRat 59 70 60 zeroNum Float = do{ n <- hexadecimal <|> octal <|> binary61 ; return (Left n)62 }63 <|> decimalFloat64 <|> fractFloat 065 71 zeroNumRat = do 72 n <- hexadecimal <|> octal <|> binary 73 return (Left n) 74 <|> decimalRat 75 <|> fractRat 0 76 <|> return (Left 0) 66 77 67 decimalFloat = do{ n <- decimal 68 ; option (Left n) 69 (try $ fractFloat n) 70 } 78 decimalRat = do 79 n <- decimal 80 option (Left n) (try $ fractRat n) 71 81 72 fractFloat n = do{ f <- fractExponent n 73 ; return (Right f) 74 } 75 76 fractExponent n = do{ fract <- fraction 77 ; expo <- option 1.0 exponent' 78 ; return ((fromInteger n + fract)*expo) 79 } 80 <|> 81 do{ expo <- exponent' 82 ; return ((fromInteger n)*expo) 83 } 82 fractRat n = do 83 fract <- try fraction 84 expo <- option (1%1) expo 85 return (Right $ ((n % 1) + fract) * expo) -- Right is Rat 86 <|> do 87 expo <- expo 88 if expo < 1 89 then return (Left $ n * numerator expo) 90 else return (Right $ (n % 1) * expo) 84 91 85 fraction = do{ char '.' 86 ; digits <- many digit <?> "fraction" 87 ; return (foldr op 0.0 digits) 88 } 89 <?> "fraction" 90 where 91 op d f = (f + fromIntegral (digitToInt d))/10.0 92 93 exponent' = do{ oneOf "eE" 94 ; f <- sign 95 ; e <- decimal <?> "exponent" 96 ; return (power (f e)) 97 } 98 <?> "exponent" 99 where 100 power e | e < 0 = 1.0/power(-e) 101 | otherwise = fromInteger (10^e) 92 fraction = do 93 char '.' 94 try $ do { char '.'; unexpected "dotdot" } <|> return () 95 digits <- many digit <?> "fraction" 96 return (digitsToRat digits) 97 <?> "fraction" 98 where 99 digitsToRat d = digitsNum d % (10 ^ length d) 100 digitsNum d = foldl (\x y -> x * 10 + (toInteger $ digitToInt y)) 0 d 102 101 102 expo :: GenParser Char st Rational 103 expo = do 104 oneOf "eE" 105 f <- sign 106 e <- decimal <?> "exponent" 107 return (power (if f then e else -e)) 108 <?> "exponent" 109 where 110 power e | e < 0 = 1 % (10^e) 111 | otherwise = (10^e) % 1 103 112 104 -- integers and naturals105 int = do{ f <- lexeme sign106 ; n <- nat107 ; return (f n)108 }109