Context Navigation

Prim.hs

Revision 22989, 85.6 kB (checked in by audreyt, 8 months ago)
* GHC 6.10 support, part 2 of 3: Adjust for extensible exceptions.
Property svn:mime-type set to `text/plain; charset=UTF-8` Property svn:eol-style set to `native`

Line
1	{-# OPTIONS_GHC -fglasgow-exts -fno-warn-orphans -fno-full-laziness -fno-cse -fallow-overlapping-instances #-}
2
3	{-\|
4	Primitive operators.
5
6	> There hammer on the anvil smote,
7	> There chisel clove, and graver wrote;
8	> There forged was blade, and bound was hilt;
9	> The delver mined, the mason built...
10	-}
11
12	module Pugs.Prim (
13	primOp,
14	primDecl,
15	initSyms,
16	op2ChainedList,
17	op1Exit,
18
19	-- used by Pugs.Compile.Haskell
20	op0, op1, op2,
21
22	-- used Pugs.Eval
23	op1Return, op1Yield,
24	foldParam, op2Hyper, op1HyperPrefix, op1HyperPostfix, retSeq, atomicEval
25	) where
26	import Pugs.Internals
27	import Pugs.Junc
28	import Pugs.AST
29	import Pugs.Types
30	import Pugs.Monads
31	import Pugs.Pretty
32	import Text.Printf
33	import Pugs.External
34	import Pugs.Embed
35	import Pugs.Eval.Var
36	import Pugs.Meta ()
37	import qualified Data.Map as Map
38	import qualified Data.Set as Set
39	import Data.IORef
40	import System.IO.Error (isEOFError)
41
42	import Pugs.Prim.Keyed
43	import Pugs.Prim.Yaml
44	import Pugs.Prim.Match
45	import Pugs.Prim.List
46	import Pugs.Prim.Numeric
47	import Pugs.Prim.Lifts
48	import Pugs.Prim.Eval
49	import Pugs.Prim.Code
50	import Pugs.Prim.Param
51	import qualified Data.IntSet as IntSet
52	import DrIFT.YAML
53	import GHC.Exts (unsafeCoerce#)
54	import GHC.Unicode
55	import qualified Data.HashTable as H
56	import Data.Time.LocalTime
57	import Data.Time.Calendar.OrdinalDate
58	import Data.Time.Calendar.MonthDay
59
60	constMacro :: Exp -> [Val] -> Eval Val
61	constMacro = const . expToEvalVal
62
63	-- \|Implementation of 0-ary and variadic primitive operators and functions
64	-- (including list ops).
65	op0 :: String -> [Val] -> Eval Val
66	op0 "&" = fmap opJuncAll . mapM fromVal
67	op0 "^" = fmap opJuncOne . mapM fromVal
68	op0 "\|" = fmap opJuncAny . mapM fromVal
69	op0 "want" = const $ fmap VStr (asks (maybe "Item" envWant . envCaller))
70	op0 "Bool::True" = const . return $ VBool True
71	op0 "Bool::False" = const . return $ VBool False
72	op0 "True" = constMacro . Val $ VBool True
73	op0 "False" = constMacro . Val $ VBool False
74	op0 "time" = const $ do
75	clkt <- guardIO getCurrentTime
76	return $ VRat $ pugsTimeSpec clkt
77	op0 "times" = const $ do
78	ProcessTimes _ u s cu cs <- guardIO getProcessTimes
79	return . VList $ map (castV . (% (clocksPerSecond :: VInt)) . toInteger . fromEnum)
80	[u, s, cu, cs]
81	op0 "Z" = op0Zip
82	op0 "X" = op0Cross
83	-- op0 "minmax" = op0Minmax
84	op0 "File::Spec::cwd" = const $ do
85	cwd <- guardIO getCurrentDirectory
86	return $ VStr cwd
87	op0 "File::Spec::tmpdir" = const $ do
88	tmp <- guardIO getTemporaryDirectory
89	return $ VStr tmp
90	op0 "Pugs::Internals::pi" = const $ return $ VNum pi
91	op0 "self" = const $ expToEvalVal (_Var "$__SELF__")
92	op0 "say" = const $ op1 "IO::say" (VHandle stdout)
93	op0 "print" = const $ op1 "IO::print" (VHandle stdout)
94	op0 "return" = const $ op1Return (retControl (ControlLeave (<= SubRoutine) 0 undef))
95	op0 "yield" = const $ op1Yield (retControl (ControlLeave (<= SubRoutine) 0 undef))
96	op0 "leave" = const $ retControl (ControlLeave (>= SubBlock) 0 undef)
97	op0 "take" = const $ assertFrame FrameGather retEmpty
98	op0 "nothing" = const . return $ VBool True
99	op0 "Pugs::Safe::safe_getc" = const . op1Getc $ VHandle stdin
100	op0 "Pugs::Safe::safe_readline" = const . op1Readline $ VHandle stdin
101	op0 "reverse" = const $ return (VList [])
102	op0 "chomp" = const $ return (VList [])
103	op0 "fork" = const $ opPerl5 "fork" []
104	op0 "defer" = const $ do
105	env <- ask
106	if envAtomic env then guardSTM retry else fail "Cannot call &defer outside a contend block."
107	op0 other = const $ fail ("Unimplemented listOp: " ++ other)
108
109	-- \|Implementation of unary primitive operators and functions
110	op1 :: String -> Val -> Eval Val
111	op1 "!" = op1Cast (VBool . not)
112	op1 "WHICH" = \x -> do
113	val <- fromVal x
114	return $ case val of
115	VObject o -> castV . unObjectId $ objId o
116	_ -> val
117	op1 "chop" = \x -> do
118	str <- fromVal x
119	return $ if null str
120	then VStr str
121	else VStr $ init str
122	op1 "Scalar::chomp" = \x -> do
123	str <- fromVal x
124	return $ op1Chomp str
125	op1 "Str::split" = op1Cast (castV . words)
126	op1 "lc" = op1Cast (VStr . map toLower)
127	op1 "lcfirst" = op1StrFirst toLower
128	op1 "uc" = op1Cast (VStr . map toUpper)
129	op1 "ucfirst" = op1StrFirst toUpper
130	op1 "capitalize" = op1Cast $ VStr . (mapEachWord capitalizeWord)
131	where
132	mapEachWord _ [] = []
133	mapEachWord f str@(c:cs)
134	\| isSpace c = c:(mapEachWord f cs)
135	\| otherwise = f word ++ mapEachWord f rest
136	where (word,rest) = break isSpace str
137	capitalizeWord [] = []
138	capitalizeWord (c:cs) = toUpper c:(map toLower cs)
139	op1 "quotemeta" = op1Cast (VStr . concat . map toQuoteMeta)
140	op1 "undef" = const $ return undef
141	op1 "undefine" = \x -> do
142	when (defined x) $ do
143	ref <- fromVal x
144	clearRef ref
145	return undef
146	op1 "+" = op1Numeric id
147	op1 "abs" = op1Numeric abs
148	op1 "Pugs::Internals::truncate" = op1Round truncate
149	op1 "Pugs::Internals::round" = op1Round round
150	op1 "Pugs::Internals::floor" = op1Round floor
151	op1 "Pugs::Internals::ceiling" = op1Round ceiling
152	op1 "cos" = op1Floating cos
153	op1 "sin" = op1Floating sin
154	op1 "tan" = op1Floating tan
155	op1 "sqrt" = op1Floating sqrt
156	op1 "atan" = op1Floating atan
157	op1 "post:i" = \x -> do
158	n <- fromVal x
159	return $ VComplex (0 :+ n)
160	op1 "post:++" = \x -> atomicEval $ do
161	ref <- fromVal x
162	val <- fromVal x
163	val' <- case val of
164	(VStr str) -> return (VStr $ strInc str)
165	_ -> op1Numeric (+1) val
166	writeRef ref val'
167	case val of
168	(VStr _) -> return val
169	_ -> op1 "+" val
170	op1 "++" = \mv -> do
171	op1 "post:++" mv
172	fromVal mv
173	op1 "post:--" = \x -> atomicEval $ do
174	ref <- fromVal x
175	val <- fromVal x
176	writeRef ref =<< op1Numeric (\x -> x - 1) val
177	return val
178	op1 "--" = \mv -> do
179	op1 "post:--" mv
180	fromVal mv
181	op1 "-" = op1Numeric negate
182	op1 "item" = \v -> return $ case v of
183	VList vs -> VRef . arrayRef $ vs
184	_ -> v
185	op1 "sort" = \v -> do
186	args <- fromVal v
187	(valList, sortByGiven) <- case args of
188	(v:vs) -> do
189	ifValTypeIsa v "Code"
190	(return (vs, Just v))
191	(ifValTypeIsa (last args) "Code"
192	(return (init args, Just $ last args))
193	(return (args, Nothing)))
194	_ -> return (args, Nothing)
195	sortBy <- case sortByGiven of
196	Nothing -> readVar (cast "&*infix:cmp")
197	Just subVal -> return subVal
198	sub <- fromVal sortBy
199	sorted <- (`sortByM` valList) $ \v1 v2 -> do
200	rv <- enterEvalContext (cxtItem "Int") $ App (Val sub) Nothing [Val v1, Val v2]
201	int <- fromVal rv
202	return (int <= (0 :: Int))
203	retSeq sorted
204	op1 "Scalar::reverse" = \v -> do
205	str <- fromVal v
206	return (VStr $ reverse str)
207	op1 "List::reverse" = \v -> do
208	vlist <- fromVal v
209	return (VList $ reverse vlist)
210	op1 "list" = op1Cast VList
211	op1 "pair" = op1Cast $ VList . (map $ \(k, v) -> castV ((VStr k, v) :: VPair))
212	op1 "~" = op1Cast VStr
213	op1 "?" = op1Cast VBool
214	op1 "int" = op1Cast VInt
215	op1 "+^" = op1Cast (VInt . pred . negate) -- Arbitrary precision complement- 0 ==> -1 / 1 ==> -2
216	op1 "~^" = op1Cast (VStr . mapStr complement)
217	op1 "?^" = op1 "!"
218	op1 "\\" = return . doCapture
219	where
220	doCapture :: Val -> Val
221	doCapture v@(VRef (MkRef IScalar{})) = VRef . scalarRef $ v
222	doCapture v@VRef{} = v
223	doCapture (VList vs) = VRef . arrayRef $ vs
224	doCapture v = VRef . scalarRef $ v
225	op1 "^" = op2RangeExclRight (VNum 0)
226	op1 "post:..." = op1Range
227	op1 "not" = op1 "!"
228	op1 "true" = op1 "?"
229	op1 "any" = op1Cast opJuncAny
230	op1 "all" = op1Cast opJuncAll
231	op1 "one" = op1Cast opJuncOne
232	op1 "none" = op1Cast opJuncNone
233	op1 "perl" = op1Pretty $ MkPrettyPrinter pretty
234	op1 "guts" = op1Pretty $ MkPrettyPrinter priggy
235	op1 "yaml" = dumpYaml
236	op1 "require_haskell" = \v -> do
237	name <- fromVal v
238	externRequire "Haskell" name
239	return $ VBool True
240	op1 "require_parrot" = \v -> do
241	-- name <- fromVal v
242	fail "evalParrotFile has bitrotten." -- io $ evalParrotFile name
243	return $ VBool True
244	op1 "require_perl5" = \v -> do
245	pkg <- fromVal v
246	let requireLine = "require " ++ pkg ++ "; '" ++ pkg ++ "'"
247	val <- evalPerl5WithCurrentEnv requireLine
248	evalExp (_Sym SOur (':':'*':pkg) mempty (Val val) (newMetaType pkg))
249	return val
250	op1 "require_java" = \v -> do
251	pkg <- fromVal v
252	let requireLine = "package main; use Inline (qw( Java STUDY AUTOSTUDY 1 STUDY ), ['" ++ mod ++ "']); '" ++ pkg ++ "'"
253	lastPart = last (split "::" pkg)
254	mod = concat (intersperse "." (split "::" pkg))
255	val <- evalPerl5WithCurrentEnv requireLine
256	evalExp (_Sym SOur (':':'*':pkg) mempty (Val val) (newMetaType pkg))
257	when (lastPart /= pkg) $ do
258	evalExp_ (_Sym SOur (':':'*':lastPart) mempty (Val val) (newMetaType lastPart))
259	return val
260	op1 "Pugs::Internals::eval_parrot" = \v -> do
261	-- code <- fromVal v
262	fail "evalParrot has bitrotten."
263	{-
264	io . evalParrot $ case code of
265	('.':_) -> code
266	_ -> unlines
267	[ ".sub pugs_eval_parrot"
268	-- , "trace 1"
269	, code
270	, ".end"
271	]
272	-}
273	return $ VBool True
274
275	-- XXX - revert these two to Prelude.pm's ::Disabled version once YAML+Closure is working
276	op1 "use" = opRequire True
277	op1 "require" = opRequire False
278
279	op1 "Pugs::Internals::use" = opRequire True
280	op1 "Pugs::Internals::require" = opRequire False
281	op1 "Pugs::Internals::eval_perl6" = \v -> do
282	str <- fromVal v
283	opEval quiet "<eval>" (encodeUTF8 str)
284	where quiet = MkEvalStyle { evalResult = EvalResultLastValue
285	, evalError = EvalErrorUndef }
286	op1 "evalfile" = \v -> do
287	filename <- fromVal v
288	opEvalFile filename
289	op1 "Pugs::Internals::eval_perl5" = \v -> do
290	str <- fromVal v
291	env <- ask
292	lex <- asks envLexical
293	let vars = [ v \| v@MkVar{ v_sigil = SScalar, v_twigil = TNil } <- Set.toList (padKeys lex), v /= varTopic ]
294	code = "sub { " ++ codeSafe ++ codeVar ++ str ++ "\n}"
295	codeSafe \| safeMode = "use ops (':default', 'binmode', 'entereval');"
296	\| otherwise = ""
297	codeVar \| null vars = ""
298	\| otherwise = "my (" ++ (concat $ intersperse ", " (map cast vars)) ++ ") = @_;"
299	vals <- mapM readVar vars
300	rv <- tryIO (Perl5ErrorString "") $ do
301	envSV <- mkEnv env
302	sub <- evalPerl5 code envSV 0
303	args <- mapM newSVval vals
304	invokePerl5 sub nullSV args envSV (enumCxt $ envContext env)
305	case rv of
306	Perl5ReturnValues [x] -> io $ svToVal x
307	Perl5ReturnValues xs -> io $ fmap VList (mapM svToVal xs)
308	Perl5ErrorString str -> fail str
309	Perl5ErrorObject err -> throwError (PerlSV err)
310	op1 "Pugs::Internals::evalfile_p6y" = op1EvalFileP6Y
311	op1 "Pugs::Internals::eval_p6y" = op1EvalP6Y
312	op1 "Pugs::Internals::eval_haskell" = op1EvalHaskell
313	op1 "Pugs::Internals::eval_yaml" = evalYaml
314	op1 "contend" = \v -> do
315	env <- ask
316	guardSTM . runEvalSTM env . evalExp $ App (Val v) Nothing []
317	op1 "try" = \v -> do
318	sub <- fromVal v
319	env <- ask
320	val <- tryT $ case envAtomic env of
321	True -> guardSTM . runEvalSTM env . evalExp $ App (Val $ VCode sub) Nothing []
322	False -> guardIO . runEvalIO env . evalExp $ App (Val $ VCode sub) Nothing []
323	retEvalResult style val
324	where
325	style = MkEvalStyle
326	{ evalResult = EvalResultLastValue
327	, evalError = EvalErrorUndef
328	}
329	-- Tentative implementation of nothingsmuch's lazy proposal.
330	op1 "lazy" = \v -> do
331	sub <- fromVal v
332	memo <- io $ newTVarIO Nothing
333	let exp = App (Val $ VCode sub) Nothing []
334	thunk = do
335	cur <- stm $ readTVar memo
336	maybe eval return cur
337	eval = do
338	res <- evalExp exp
339	stm $ writeTVar memo (Just res)
340	return res
341	typ <- inferExpType exp
342	return . VRef . thunkRef $ MkThunk thunk typ
343
344	op1 "defined" = op1Cast (VBool . defined)
345	op1 "last" = const $ assertFrame FrameLoop $ op1ShiftOut (VControl (ControlLoop LoopLast))
346	op1 "next" = const $ assertFrame FrameLoop $ op1ShiftOut (VControl (ControlLoop LoopNext))
347	op1 "redo" = const $ assertFrame FrameLoop $ op1ShiftOut (VControl (ControlLoop LoopRedo))
348	op1 "continue" = const $ assertFrame FrameWhen $ op1ShiftOut (VControl (ControlWhen WhenContinue))
349	op1 "break" = const $ assertFrame FrameWhen $ op1ShiftOut (VControl (ControlWhen WhenBreak))
350	op1 "return" = op1Return . op1ShiftOut . VControl . ControlLeave (<= SubRoutine) 0
351	op1 "yield" = op1Yield . op1ShiftOut . VControl . ControlLeave (<= SubRoutine) 0
352	op1 "leave" = op1ShiftOut . VControl . ControlLeave (>= SubBlock) 0
353	op1 "take" = \v -> assertFrame FrameGather $ do
354	glob <- askGlobal
355	arr <- findSymRef (cast "$*TAKE") glob
356	push <- doArray (VRef arr) array_push
357	push (listVal v)
358	retEmpty
359	op1 "sign" = \v -> withDefined [v] $
360	op1Cast (VInt . signum) v
361
362	op1 "srand" = \v -> do
363	x <- fromVal v
364	guardSTM . unsafeIOToSTM $ do
365	seed <- if defined v
366	then return x
367	else randomRIO (0, 2^(31::Int))
368	setStdGen $ mkStdGen seed
369	return (castV True)
370	op1 "rand" = \v -> do
371	x <- fromVal v
372	rand <- guardSTM . unsafeIOToSTM
373	$ getStdRandom (randomR (0, if x == 0 then 1 else x))
374	return $ VNum rand
375	op1 "say" = op2 "IO::say" (VHandle stdout)
376	op1 "print" = op2 "IO::print" (VHandle stdout)
377	op1 "IO::say" = \v -> op2 "IO::say" v $ VList []
378	op1 "IO::print" = \v -> op2 "IO::print" v $ VList []
379	op1 "IO::next" = \v -> do
380	fh <- fromVal v
381	guardIO $ fmap (VStr . (++ "\n") . decodeUTF8) (hGetLine fh)
382	op1 "Pugs::Safe::safe_print" = \v -> do
383	str <- fromVal v
384	guardIO . putStr $ encodeUTF8 str
385	return $ VBool True
386	op1 "die" = \v -> do
387	v' <- fromVal $! v
388	poss <- asks envPosStack
389	retShift $! VError (errmsg $! v') poss
390	where
391	errmsg VUndef = VStr "Died"
392	errmsg VType{} = VStr "Died"
393	errmsg (VStr "") = VStr "Died"
394	errmsg (VList []) = VStr "Died"
395	errmsg (VList [x]) = x
396	errmsg x = x
397	op1 "warn" = \v -> do
398	strs <- fromVal v
399	errh <- readVar $ cast "$*ERR"
400	poss <- asks envPosStack
401	op2 "IO::say" errh $ VList [ VStr $ pretty (VError (errmsg strs) poss) ]
402	where
403	errmsg "" = VStr "Warning: something's wrong"
404	errmsg x = VStr x
405	op1 "fail" = op1 "fail_" -- XXX - to be replaced by Prelude later
406	op1 "fail_" = \v -> do
407	throw <- fromVal =<< readVar (cast "$*FAIL_SHOULD_DIE")
408	if throw then op1 "die" (errmsg v) else do
409	poss <- asks envPosStack
410	let die = retShift $ VError (errmsg v) poss
411	dieThunk = VRef . thunkRef $ MkThunk die (mkType "Failure")
412	op1Return (retControl (ControlLeave (<= SubRoutine) 0 dieThunk))
413	where
414	errmsg VUndef = VStr "Failed"
415	errmsg VType{} = VStr "Failed"
416	errmsg (VStr "") = VStr "Failed"
417	errmsg (VList []) = VStr "Failed"
418	errmsg (VList [x]) = x
419	errmsg x = x
420	op1 "exit" = op1Exit
421	op1 "readlink" = \v -> do
422	str <- fromVal v
423	guardIO $ fmap VStr (readSymbolicLink str)
424	op1 "sleep" = \v -> do
425	x <- fromVal v :: Eval VNum
426	guardIO $ do
427	start <- getCurrentTime
428	threadDelay (round $ x * clocksPerSecond)
429	finish <- getCurrentTime
430	return $ VRat (toRational $ diffUTCTime start finish)
431	op1 "mkdir" = guardedIO createDirectory
432	op1 "rmdir" = guardedIO removeDirectory
433	op1 "chdir" = guardedIO setCurrentDirectory
434	op1 "graphs"= op1Cast (VInt . (genericLength :: String -> VInt)) -- XXX Wrong
435	op1 "codes" = op1Cast (VInt . (genericLength :: String -> VInt))
436	op1 "chars" = op1Cast (VInt . (genericLength :: String -> VInt))
437	op1 "bytes" = op1Cast (VInt . (genericLength :: String -> VInt) . encodeUTF8)
438
439	op1 "unlink" = \v -> do
440	vals <- fromVals v
441	rets <- mapM (doBoolIO removeFile) vals
442	return $ VInt $ sum $ map bool2n rets
443	op1 "readdir" = \v -> do
444	path <- fromVal v
445	files <- guardIO $ getDirectoryContents path
446	retSeq (map VStr files)
447	op1 "slurp" = \v -> do
448	ifValTypeIsa v "IO"
449	(do h <- fromVal v
450	ifListContext (strictify $! op1 "=" v) $ do
451	content <- guardIO $ hGetContents h
452	return . VStr $ decodeUTF8 content)
453	(do
454	fileName <- fromVal v
455	ifListContext
456	(slurpList fileName)
457	(slurpScalar fileName))
458	where
459	strictify action = do
460	VList lines <- action
461	return $ VList (length lines `seq` lines)
462	slurpList file = strictify $! op1 "=" (VList [VStr file])
463	slurpScalar file = do
464	content <- guardIO $ readFile file
465	return . VStr $ decodeUTF8 content
466	op1 "opendir" = \v -> do
467	str <- fromVal v
468	dir <- guardIO $ openDirStream str
469	obj <- createObject (mkType "IO::Dir") []
470	return . VObject $ obj{ objOpaque = Just $ toDyn dir }
471	op1 "IO::Dir::close" = op1 "IO::Dir::closedir"
472	op1 "IO::Dir::closedir" = guardedIO (closeDirStream . fromObject)
473	op1 "IO::Dir::rewind" = op1 "IO::Dir::rewinddir"
474	op1 "IO::Dir::rewinddir" = guardedIO (rewindDirStream . fromObject)
475	op1 "IO::Dir::read" = op1 "IO::Dir::readdir"
476	op1 "IO::Dir::readdir" = \v -> do
477	dir <- fmap fromObject (fromVal v)
478	ifListContext
479	(retSeq =<< readDirStreamList dir)
480	(guardIO $ fmap (\x -> if null x then undef else castV x) $ readDirStream dir)
481	where
482	readDirStreamList dir = do
483	this <- tryIO "" $ readDirStream dir
484	if null this then return [] else do
485	rest <- readDirStreamList dir
486	return (VStr this:rest)
487	op1 "Pugs::Internals::runShellCommand" = \v -> do
488	str <- fromVal v
489	cxt <- asks envContext
490	(res, exitCode) <- tryIO ("", ExitFailure (-1)) $ do
491	(inp,out,_,pid) <- runInteractiveCommand (encodeUTF8 str)
492	hClose inp
493	res <- fmap (decodeUTF8 . deCRLF) $ hGetContents out
494	exitCode <- waitForProcess pid
495	return (res, exitCode)
496	handleExitCode exitCode
497	return $ case cxt of
498	CxtSlurpy{} -> VList (map VStr $ lines res)
499	_ -> VStr res
500	where
501	-- XXX - crude CRLF treatment
502	deCRLF [] = []
503	deCRLF ('\r':xs@('\n':_)) = xs
504	deCRLF (x:xs) = (x:deCRLF xs)
505	op1 "Pugs::Internals::runInteractiveCommand" = \v -> do
506	str <- fromVal v
507	guardIO $ do
508	(inp,out,err,pid) <- runInteractiveCommand str
509	return $ VList [ VHandle inp
510	, VHandle out
511	, VHandle err
512	, VProcess (MkProcess pid)
513	]
514	op1 "Pugs::Internals::check_for_io_leak" = \v -> do
515	rv <- evalExp (App (Val v) Nothing [])
516	leaked <- fromVal =<< op2Match rv (VType $ mkType "IO")
517	when leaked $ do
518	fail $ "BEGIN and CHECK blocks may not return IO handles,\n" ++
519	"as they would be invalid at runtime."
520	return rv
521	op1 "run" = \v -> do
522	cmd <- fromVal v
523	exitCode <- tryIO (ExitFailure (-1)) $ system (encodeUTF8 cmd)
524	handleExitCode exitCode
525	op1 "accept" = \v -> do
526	socket <- fromVal v
527	(h, _, _) <- guardIO $ accept socket
528	return $ VHandle h
529	op1 "detach" = \v -> do
530	case v of
531	VThread thr -> do
532	stm $ tryPutTMVar (threadLock thr) undef
533	return $ VBool True
534	_ -> fail $ "Not a thread: " ++ show v
535	op1 "kill" = \v -> do
536	case v of
537	VThread thr -> do
538	guardIO . killThread $ threadId thr
539	return $ VBool True
540	_ -> fail $ "Not a thread: " ++ show v
541	op1 "join" = \v -> do
542	case v of
543	VThread thr -> stm $ takeTMVar (threadLock thr)
544	_ -> op2Join v (VList [])
545	op1 "async" = \v -> do
546	env <- ask
547	code <- fromVal v
548	lock <- stm $ newEmptyTMVar
549	tid <- guardIO . forkIO $ do -- (if rtsSupportsBoundThreads then forkOS else forkIO) $ do
550	val <- runEvalIO env $ do
551	enterEvalContext CxtVoid $ App (Val code) Nothing []
552	stm $ tryPutTMVar lock val
553	return ()
554	return . VThread $ MkThread
555	{ threadId = tid
556	, threadLock = lock
557	}
558	--WV: async should return the thread id! return undef
559	op1 "listen" = \v -> do
560	port <- fromVal v
561	socket <- guardIO $ listenOn (PortNumber $ fromInteger port)
562	return $ VSocket socket
563	op1 "flush" = guardedIO hFlush
564	op1 "IO::close" = guardedIO hClose
565	op1 "Socket::close" = guardedIO sClose
566	op1 "Pair::key" = fmap fst . (fromVal :: Val -> Eval VPair)
567	op1 "Pair::value" = \v -> do
568	ivar <- join $ doPair v pair_fetchElem
569	return . VRef . MkRef $ ivar
570	op1 "pairs" = \v -> do
571	pairs <- pairsFromVal v
572	retSeq pairs
573	op1 "List::kv" = \v -> do
574	pairs <- pairsFromVal v
575	kvs <- forM pairs $ \(VRef ref) -> do
576	pair <- readRef ref
577	fromVal pair
578	retSeq $ concat kvs
579	op1 "Pair::kv" = op1 "List::kv"
580	op1 "keys" = keysFromVal
581	op1 "values" = valuesFromVal
582	-- According to Damian
583	-- (http://www.nntp.perl.org/group/perl.perl6.language/21895),
584	-- =$obj should call $obj.next().
585	op1 "=" = \v -> case v of
586	VObject _ -> evalExp $ App (_Var "&shift") (Just $ Val v) []
587	VRef (MkRef IArray{}) -> do
588	ifListContext
589	(fmap VList (join $ doArray v array_fetch))
590	(join $ doArray v array_shift)
591	_ -> op1 "readline" v
592	op1 "readline" = op1Readline
593	op1 "getc" = op1Getc
594	op1 "WHAT" = fmap VType . evalValType
595	op1 "List::end" = \x -> fmap (castV . pred) (join $ doArray x array_fetchSize) -- monadic join
596	op1 "List::elems" = \x -> fmap castV (join $ doArray x array_fetchSize) -- monadic join
597	op1 "List::pop" = \x -> join $ doArray x array_pop -- monadic join
598	op1 "List::shift" = \x -> join $ doArray x array_shift -- monadic join
599	op1 "pick" = op1Pick
600	op1 "sum" = op1Sum
601	op1 "min" = op1Min
602	op1 "max" = op1Max
603	op1 "uniq" = op1Uniq
604	op1 "chr" = op1Cast (VStr . (:[]) . chr)
605	op1 "ord" = op1Cast $ \str -> if null str then undef else (castV . ord . head) str
606	op1 "hex" = fail "hex() is not part of Perl 6 - use :16() instead."
607	op1 "oct" = fail "oct() is not part of Perl 6 - use :8() instead."
608	op1 "log" = op1Floating log
609	op1 "log10" = op1Floating (logBase 10)
610	op1 "from" = op1Cast (castV . matchFrom)
611	op1 "to" = op1Cast (castV . matchTo)
612	op1 "matches" = op1Cast (VList . matchSubPos)
613	op1 "gather" = \v -> do
614	evl <- asks envEval
615	evl (Syn "gather" [Val v])
616	op1 "Thread::yield" = const $ do
617	guardSTM . unsafeIOToSTM $ yield
618	return $ VBool True
619	op1 "DESTROYALL" = \x -> cascadeMethod id "DESTROY" x VUndef
620	-- [,] is a noop -- It simply returns the input list
621	op1 "prefix:[,]" = return
622	op1 "prefix:$<<" = op1SigilHyper SScalar
623	op1 "prefix:@<<" = op1SigilHyper SArray
624	op1 "prefix:%<<" = op1SigilHyper SHash
625	op1 "prefix:&<<" = op1SigilHyper SCode
626	op1 "Code::assoc" = op1CodeAssoc
627	op1 "Code::name" = op1CodeName
628	op1 "Code::arity" = op1CodeArity
629	op1 "Code::body" = op1CodeBody
630	op1 "Code::pos" = op1CodePos
631	op1 "Code::signature" = op1CodeSignature
632	op1 "IO::tell" = \v -> do
633	h <- fromVal v
634	res <- guardIO $ hTell h
635	return $ VInt res
636	op1 "Rat::numerator" = \(VRat t) -> return . VInt $ numerator t
637	op1 "Rat::denominator" = \(VRat t) -> return . VInt $ denominator t
638	op1 "TEMP" = \v -> do
639	ref <- fromVal v
640	val <- readRef ref
641	return . VCode $ mkPrim
642	{ subBody = Prim . const $ do
643	writeRef ref val
644	retEmpty
645	}
646	op1 "Pugs::Internals::hIsOpen" = op1IO hIsOpen
647	op1 "Pugs::Internals::hIsClosed" = op1IO hIsClosed
648	op1 "Pugs::Internals::hIsReadable" = op1IO hIsReadable
649	op1 "Pugs::Internals::hIsWritable" = op1IO hIsWritable
650	op1 "Pugs::Internals::hIsSeekable" = op1IO hIsSeekable
651	op1 "Pugs::Internals::reduceVar" = \v -> do
652	str <- fromVal v
653	evalExp (_Var str)
654	op1 "Pugs::Internals::rule_pattern" = \v -> do
655	case v of
656	VRule MkRulePGE{rxRule=re} -> return $ VStr re
657	VRule MkRulePCRE{rxRuleStr=re} -> return $ VStr re
658	_ -> fail $ "Not a rule: " ++ show v
659	op1 "Pugs::Internals::rule_adverbs" = \v -> do
660	case v of
661	VRule MkRulePGE{rxAdverbs=hash} -> return hash
662	VRule MkRulePCRE{rxAdverbs=hash} -> return hash
663	_ -> fail $ "Not a rule: " ++ show v
664	op1 "Pugs::Internals::current_pragma_value" = \v -> do
665	name <- fromVal v
666	prags <- asks envPragmas
667	return $ findPrag name prags
668	where
669	findPrag :: String -> [Pragma] -> Val
670	findPrag _ [] = VUndef
671	findPrag n (this:rest)
672	\| n == pragName this = VInt $ toInteger $ pragDat this
673	\| otherwise = findPrag n rest
674	op1 "Pugs::Internals::caller_pragma_value" = \v -> do
675	caller <- asks envCaller
676	case caller of
677	Just env -> local (const env) (op1 "Pugs::Internals::current_pragma_value" v)
678	_ -> return $ VUndef
679	op1 "eager" = \v -> do
680	vlist <- fromVal v
681	return $! length (map valType vlist) `seq` VList vlist
682	op1 "Pugs::Internals::emit_yaml" = \v -> do
683	glob <- filterPrim =<< asks envGlobal
684	yml <- io $ showYaml (filterUserDefinedPad glob, v)
685	return $ VStr yml
686	op1 "Object::HOW" = \v -> do
687	typ <- evalValType v
688	evalExp $ _Var (':':'*':showType typ)
689	op1 "Class::name" = \v -> do
690	cls <- fromVal v
691	meta <- readRef =<< fromVal cls
692	fetch <- doHash meta hash_fetchVal
693	str <- fromVal =<< fetch "name"
694	return str
695	op1 "Class::traits" = \v -> do
696	cls <- fromVal v
697	meta <- readRef =<< fromVal cls
698	fetch <- doHash meta hash_fetchVal
699	str <- fromVal =<< fetch "is"
700	return str
701	op1 "vv" = op1Cast VV
702	op1 "stat" = \x -> opPerl5 "require File::stat; File::stat::stat" [x]
703	op1 "lstat" = \x -> opPerl5 "require File::stat; File::stat::lstat" [x]
704	op1 "Pugs::Internals::localtime" = \x -> do
705	tz <- io getCurrentTimeZone
706	tm <- fromVal x -- seconds since Perl's epoch
707	let utc = posixSecondsToUTCTime (fromInteger tm + offset)
708	local = utcToLocalTime tz utc
709	day = localDay local
710	tod = localTimeOfDay local
711	(year, month, dayOfMonth) = toGregorian day
712	(sec, pico) = properFraction $ todSec tod
713	(_, dayOfWeek) = sundayStartWeek day
714	-- if wantString then return . VStr $ formatTime "%c" (ZonedTime local tz) else
715	retSeq [ vI $ year
716	, vI $ month
717	, vI $ dayOfMonth
718	, vI $ todHour tod
719	, vI $ todMin tod
720	, VInt $ sec
721	, vI $ fromEnum (pico * 1000000000000)
722	, vI $ dayOfWeek + 1
723	, vI $ (monthAndDayToDayOfYear (isLeapYear year) month dayOfMonth) - 1
724	, VStr $ timeZoneName tz
725	, vI $ timeZoneMinutes tz * 60
726	, VBool $ timeZoneSummerOnly tz
727	]
728	where
729	offset :: NominalDiffTime
730	offset = 946684800 -- diff between Haskell and Perl epochs (seconds)
731	vI :: Integral a => a -> Val
732	vI = VInt . toInteger
733
734	op1 other = \_ -> fail ("Unimplemented unaryOp: " ++ other)
735
736	op1IO :: Value a => (Handle -> IO a) -> Val -> Eval Val
737	op1IO = \fun v -> do
738	val <- fromVal v
739	fmap castV (guardIO $ fun val)
740
741	op1SigilHyper :: VarSigil -> Val -> Eval Val
742	op1SigilHyper sig val = do
743	vs <- fromVal val
744	evalExp $ Syn "," (map (\x -> Syn (shows sig "{}") [Val x]) vs)
745
746	retSeq :: VList -> Eval Val
747	retSeq xs = length xs `seq` return (VList xs)
748
749	handleExitCode :: ExitCode -> Eval Val
750	handleExitCode exitCode = do
751	glob <- askGlobal
752	errSV <- findSymRef (cast "$!") glob
753	writeRef errSV $ case exitCode of
754	ExitFailure x -> VInt $ toInteger x
755	ExitSuccess -> VUndef
756	return (VBool $ exitCode == ExitSuccess)
757
758	cascadeMethod :: ([VStr] -> [VStr]) -> VStr -> Val -> Val -> Eval Val
759	cascadeMethod f meth v args = do
760	typ <- evalValType v
761	pkgs <- fmap f (pkgParents $ showType typ)
762	named <- case args of
763	VUndef -> return Map.empty
764	VType{}-> return Map.empty
765	_ -> join $ doHash args hash_fetch
766
767	-- Here syms is a list of (sym, tvar) tuples where tvar is the physical coderef
768	-- The monad in the "do" below is List.
769	syms <- forM pkgs $ \pkg -> do
770	let sym = cast $ ('&':pkg) ++ "::" ++ meth
771	maybeM (fmap (lookupPad sym) askGlobal) $ \ref -> do
772	return (sym, ref)
773
774	forM_ (nubBy (\(_, x) (_, y) -> x == y) (catMaybes syms)) $ \(sym, _) -> do
775	enterEvalContext CxtVoid $
776	App (Var sym) (Just $ Val v)
777	[ Syn "named" [Val (VStr key), Val val]
778	\| (key, val) <- Map.assocs named
779	]
780	return undef
781
782	op1Return :: Eval Val -> Eval Val
783	op1Return action = assertFrame FrameRoutine $ do
784	sub <- fromVal =<< readVar (cast "&?ROUTINE")
785	-- If this is a coroutine, reset the entry point
786	case subCont sub of
787	Nothing -> action
788	Just tvar -> do
789	let thunk = (`MkThunk` anyType) . fix $ \redo -> do
790	evalExp $ subBody sub
791	stm $ writeTVar tvar thunk
792	redo
793	stm $ writeTVar tvar thunk
794	action
795
796	op1Yield :: Eval Val -> Eval Val
797	op1Yield action = assertFrame FrameRoutine $ do
798	sub <- fromVal =<< readVar (cast "&?ROUTINE")
799	case subCont sub of
800	Nothing -> fail $ "cannot yield() from a " ++ pretty (subType sub)
801	Just tvar -> callCC $ \esc -> do
802	stm $ writeTVar tvar (MkThunk (esc undef) anyType)
803	action
804
805	op1ShiftOut :: Val -> Eval Val
806	op1ShiftOut v = retShift =<< do
807	evl <- asks envEval
808	evl $ case v of
809	VList [x] -> Val x
810	_ -> Val v
811
812	op1Exit :: Val -> Eval a
813	op1Exit v = do
814	rv <- fromVal v
815	retControl . ControlExit $ if rv /= 0
816	then ExitFailure rv else ExitSuccess
817
818	op1StrFirst :: (Char -> Char) -> Val -> Eval Val
819	op1StrFirst f = op1Cast $ VStr .
820	\str -> case str of
821	[] -> []
822	(c:cs) -> (f c:cs)
823
824	-- op1Readline and op1Getc are precisely the implementation of op1 "readline"
825	-- and op1 "getc", but those may be hidden in safe mode. We still want to use
826	-- the functionality with the safe variants, hence these functions.
827	op1Readline :: Val -> Eval Val
828	op1Readline = \v -> op1Read v (io . getLines) getLine
829	where
830	getLines :: VHandle -> IO Val
831	getLines fh = unsafeInterleaveIO $ do
832	line <- doGetLine fh
833	case line of
834	Just str -> do
835	~(VList rest) <- getLines fh
836	return $ VList (VStr str:rest)
837	_ -> return (VList [])
838	getLine :: VHandle -> Eval Val
839	getLine fh = do
840	line <- io $! doGetLine fh
841	case line of
842	Just str -> return $! VStr $! (length str `seq` str)
843	_ -> return undef
844	doGetLine :: VHandle -> IO (Maybe VStr)
845	doGetLine fh = guardIOexcept [(isEOFError, Nothing)] $ do
846	line <- hGetLine fh
847	return . Just . decodeUTF8 $ line
848
849	op1Getc :: Val -> Eval Val
850	op1Getc = \v -> op1Read v (getChar) (getChar)
851	where
852	getChar :: VHandle -> Eval Val
853	getChar fh = guardIOexcept [(isEOFError, undef)] $ do
854	char <- hGetChar fh
855	str <- getChar' fh char
856	return $ VStr $ decodeUTF8 str
857	-- We may have to read more than one byte, as one utf-8 char can span
858	-- multiple bytes.
859	getChar' :: VHandle -> Char -> IO String
860	getChar' fh char
861	\| ord char < 0x80 = return [char]
862	\| ord char < 0xE0 = readNmore 1
863	\| ord char < 0xEE = readNmore 2
864	\| ord char < 0xF5 = readNmore 3
865	\| otherwise = fail "Invalid utf-8 read by getc()"
866	where
867	readNmore :: Int -> IO String
868	readNmore n = do
869	new <- sequence $ replicate n (hGetChar fh)
870	return $ char:new
871
872	{-\|
873	Read a char or a line from a handle.
874	-}
875	op1Read :: Val -- ^ The handle to read from (packed in a 'Val')
876	-> (VHandle -> Eval Val) -- ^ The function to call in list context
877	-> (VHandle -> Eval Val) -- ^ The function to call in item context
878	-> Eval Val -- ^ The return value (a list of strings or a
879	-- string, packed in a 'Val')
880	op1Read v fList fScalar = do
881	fh <- handleOf v
882	ifListContext
883	(fList fh)
884	(fScalar fh)
885	where
886	handleOf x \| safeMode, (VHandle h) <- x, h /= stdin = fail "Evil handle detected"
887	handleOf _ \| safeMode = return stdin
888	handleOf VUndef = handleOf (VList [])
889	handleOf (VList []) = do
890	argsGV <- readVar (cast "$*ARGS")
891	gv <- fromVal argsGV
892	if defined gv
893	then handleOf gv
894	else do
895	args <- readVar (cast "@*ARGS")
896	files <- fromVal args
897	if null files
898	then return stdin
899	else do
900	hdl <- handleOf (VStr (head files)) -- XXX wrong
901	writeVar (cast "$*ARGS") (VHandle hdl)
902	return hdl
903	handleOf (VStr x) = do
904	return =<< guardIO $ openFile x ReadMode
905	handleOf (VList [x]) = handleOf x
906	handleOf v = fromVal v
907
908	bool2n :: Bool -> VInt
909	bool2n v = if v
910	then 1
911	else 0
912
913	doBoolIO :: Value a => (a -> IO b) -> Val -> Eval Bool
914	doBoolIO f v = do
915	x <- fromVal v
916	tryIO False $ do
917	f x
918	return True
919
920	guardedIO :: Value a => (a -> IO b) -> Val -> Eval Val
921	guardedIO f v = do
922	x <- fromVal v
923	guardIO $ f x
924	return $ VBool True
925
926	guardedIO2 :: (Value a, Value b)
927	=> (a -> b -> IO c) -> Val -> Val -> Eval Val
928	guardedIO2 f u v = do
929	x <- fromVal u
930	y <- fromVal v
931	guardIO $ f x y
932	return $ VBool True
933
934	mapStr :: (Word8 -> Word8) -> [Word8] -> String
935	mapStr f = map (chr . fromEnum . f)
936
937	mapStr2 :: (Word8 -> Word8 -> Word8) -> [Word8] -> [Word8] -> String
938	mapStr2 f x y = map (chr . fromEnum . uncurry f) $ x `zip` y
939
940	mapStr2Fill :: (Word8 -> Word8 -> Word8) -> [Word8] -> [Word8] -> String
941	mapStr2Fill f x y = map (chr . fromEnum . uncurry f) $ x `zipFill` y
942	where
943	zipFill [] [] = []
944	zipFill as [] = zip as (repeat 0)
945	zipFill [] bs = zip (repeat 0) bs
946	zipFill (a:as) (b:bs) = (a,b) : zipFill as bs
947
948	op1Chomp :: VStr -> Val
949	op1Chomp "" = VStr ""
950	op1Chomp str
951	\| last str == '\n' = VStr (init str)
952	\| otherwise = VStr str
953
954	perlReplicate :: VInt -> a -> [a]
955	perlReplicate = genericReplicate . max 0
956
957	-- XXX only used at op2 "?^" because my Haskell is too poor - ferreira
958	neBool :: VBool -> VBool -> VBool
959	neBool = (==) . not
960
961	-- \|Implementation of 2-arity primitive operators and functions
962	op2 :: String -> Val -> Val -> Eval Val
963	op2 "rename" = guardedIO2 rename
964	op2 "symlink" = guardedIO2 createSymbolicLink
965	op2 "link" = guardedIO2 createLink
966	op2 "" = op2Numeric ()
967	op2 "/" = op2Divide
968	op2 "%" = op2Modulus
969	op2 "x" = op2Cast (\x y -> VStr . concat $ (y :: VInt) `perlReplicate` x)
970	op2 "xx" = op2Cast (\x y -> VList . concat $ (y :: VInt) `perlReplicate` x)
971	op2 "+&" = op2Int (.&.)
972	op2 "+<" = op2Int shiftL
973	op2 "+>" = op2Int shiftR
974	op2 "~&" = op2Str $ mapStr2 (.&.)
975	op2 "~<" = op2Cast (\x y -> VStr $ mapStr (`shiftL` y) x)
976	op2 "~>" = op2Cast (\x y -> VStr $ mapStr (`shiftR` y) x)
977	op2 "**" = op2Exp
978	op2 "+" = op2Numeric (+)
979	op2 "-" = op2Numeric (-)
980	op2 "atan" = op2Num atan2
981	op2 "~" = op2Str (++)
982	op2 "+\|" = op2Int (.\|.)
983	op2 "+^" = op2Int xor
984	op2 "~\|" = op2Str $ mapStr2Fill (.\|.)
985	op2 "?\|" = op2Bool (\|\|)
986	op2 "?&" = op2Bool (&&)
987	op2 "~^" = op2Str $ mapStr2Fill xor
988	op2 "?^" = op2Bool neBool -- for bools, 'xor' is the same as '!=='
989	op2 "=>" = \x y -> return $ castV (x, y)
990	op2 "=" = \x y -> evalExp (Syn "=" [Val x, Val y])
991	op2 "cmp"= op2OrdNumStr
992	op2 "leg"= op2Ord vCastStr
993	op2 "<=>"= op2OrdNumeric compare
994	op2 ".." = op2Range
995	op2 "..^" = op2RangeExclRight
996	op2 "^.." = op2RangeExclLeft
997	op2 "^..^" = op2RangeExclBoth
998	op2 "!=" = op2OrdNumeric (/=)
999	op2 "==" = op2OrdNumeric (==)
1000	op2 "<" = op2OrdNumeric (<)
1001	op2 "<=" = op2OrdNumeric (<=)
1002	op2 ">" = op2OrdNumeric (>)
1003	op2 ">=" = op2OrdNumeric (>=)
1004	op2 "ne" = op2Cmp vCastStr (/=)
1005	op2 "eq" = op2Cmp vCastStr (==)
1006	op2 "lt" = op2Cmp vCastStr (<)
1007	op2 "le" = op2Cmp vCastStr (<=)
1008	op2 "gt" = op2Cmp vCastStr (>)
1009	op2 "ge" = op2Cmp vCastStr (>=)
1010	op2 "~~" = op2Match
1011	op2 "=:=" = \x y -> do
1012	return $ castV $ case x of
1013	VRef xr \| VRef yr <- y ->
1014	-- Take advantage of the pointer address built-in with (Show VRef)
1015	show xr == show yr
1016	_ ->
1017	W# (unsafeCoerce# x :: Word#) == W# (unsafeCoerce# y :: Word#)
1018	op2 "===" = \x y -> do
1019	return $ castV (x == y)
1020	op2 "eqv" = op2Identity -- XXX wrong, needs to compare full objects
1021	op2 "&&" = op2Logical (fmap not . fromVal)
1022	op2 "\|\|" = op2Logical (fmap id . fromVal)
1023	op2 "^^" = \x y -> do
1024	let xor True True = VBool False
1025	xor True False = x
1026	xor False True = y
1027	xor False False = VBool False
1028	op2Cast xor x y
1029	op2 "//" = op2Logical (return . defined)
1030	op2 ".[]" = \x y -> do
1031	evl <- asks envEval
1032	evl $ Syn "[]" [Val x, Val y]
1033	op2 ".{}" = \x y -> do
1034	evl <- asks envEval
1035	evl $ Syn "{}" [Val x, Val y]
1036	-- XXX pipe forward XXX
1037	op2 "and"= op2 "&&"
1038	op2 "or" = op2 "\|\|"
1039	op2 "xor"= op2 "^^"
1040	op2 "orelse"= op2 "//" -- XXX wrong
1041	op2 "andthen"= op2 "&&" -- XXX even wronger
1042	op2 "pick" = op2Pick
1043	op2 "grep" = op2Grep
1044	op2 "first" = op2First
1045	op2 "map" = op2Map
1046	op2 "join" = op2Join
1047	op2 "reduce" = op2ReduceL False
1048	op2 "produce" = op2ReduceL True
1049	op2 "reverse" = op2MaybeListop (VList . reverse) (VStr . reverse)
1050	op2 "chomp" = op2MaybeListop (VList . map op1Chomp) op1Chomp
1051	op2 "kill" = \s v -> do
1052	sig <- fromVal s
1053	pids <- fromVals v
1054	sig' <- fromVal sig
1055	pids'<- mapM fromVal pids
1056	let doKill pid = do
1057	signalProcess (toEnum sig') (toEnum pid)
1058	return 1
1059	rets <- mapM (tryIO 0 . doKill) pids'
1060	return . VInt $ sum rets
1061	op2 "isa" = \x y -> do
1062	typY <- case y of
1063	VStr str -> return $ mkType str
1064	_ -> fromVal y
1065	typX <- fromVal x -- XXX consider line 224 of Pugs.Prim.Match case too
1066	typs <- pkgParentClasses (showType typX)
1067	return . VBool $ showType typY `elem` (showType typX:typs)
1068	op2 "does" = \x y -> do
1069	typY <- case y of
1070	VStr str -> return $ mkType str
1071	_ -> fromVal y
1072	op2Match x (VType typY)
1073	op2 "delete" = \x y -> do
1074	ref <- fromVal x
1075	rv <- deleteFromRef ref y
1076	-- S29: delete always returns the full list regardless of context.
1077	return $ case rv of
1078	VList [x] -> x
1079	_ -> rv
1080	op2 "exists" = \x y -> do
1081	ref <- fromVal x
1082	fmap VBool (existsFromRef ref y)
1083	op2 "unshift" = op2Array array_unshift
1084	op2 "push" = op2Array array_push
1085	op2 "split" = op2Split
1086	op2 "Str::split" = flip op2Split
1087	op2 "connect" = \x y -> do
1088	host <- fromVal x
1089	port <- fromVal y
1090	hdl <- guardIO $ connectTo host (PortNumber $ fromInteger port)
1091	return $ VHandle hdl
1092	op2 "Pugs::Internals::hSetBinaryMode" = \x y -> do
1093	fh <- fromVal x
1094	mode <- fromVal y
1095	guardIO $ hSetBinaryMode fh mode
1096	return $ VBool True
1097	op2 "Pugs::Internals::openFile" = \x y -> do
1098	filename <- fromVal x
1099	mode <- fromVal y
1100	hdl <- guardIO $ do
1101	h <- openFile filename (modeOf mode)
1102	hSetBuffering h NoBuffering
1103	return h
1104	return $ VHandle hdl
1105	where
1106	modeOf "r" = ReadMode
1107	modeOf "w" = WriteMode
1108	modeOf "a" = AppendMode
1109	modeOf "rw" = ReadWriteMode
1110	modeOf m = error $ "unknown mode: " ++ m
1111	op2 "exp" = \x y -> if defined y
1112	then op2Num (**) x y
1113	else op1Floating exp x
1114	op2 "Pugs::Internals::sprintf" = \x y -> do
1115	-- a single argument is all Haskell can really handle.
1116	-- XXX printf should be wrapped in a catch so a mis-typed argument
1117	-- doesnt kill pugs with a runtime exception.
1118	-- XXX fail... doesnt?!
1119	str <- fromVal x
1120	arg <- fromVal y
1121	return $ VStr $ case arg of
1122	VNum n -> printf str n
1123	VRat r -> printf str ((fromRational r)::Double)
1124	VInt i -> printf str i
1125	VStr s -> printf str s
1126	_ -> fail "should never be reached given the type declared below"
1127	op2 "run" = \x y -> do
1128	prog <- fromVal x
1129	args <- fromVals y
1130	exitCode <- tryIO (ExitFailure (-1)) $
1131	rawSystem (encodeUTF8 prog) (map encodeUTF8 args)
1132	handleExitCode exitCode
1133	op2 "crypt" = \x y -> opPerl5 "crypt" [x, y]
1134	op2 "chmod" = \x y -> do
1135	mode <- fromVal x
1136	files <- fromVals y
1137	rets <- mapM (doBoolIO . flip setFileMode $ toEnum mode) files
1138	return . VInt . sum $ map bool2n rets
1139	op2 "splice" = \x y -> do
1140	fetchSize <- doArray x array_fetchSize
1141	len' <- fromVal y
1142	sz <- fetchSize
1143	let len = if len' < 0 then if sz > 0 then (len' `mod` sz) else 0 else len'
1144	op4 "splice" x y (castV (sz - len)) (VList [])
1145	op2 "sort" = \x y -> do
1146	xs <- fromVals x
1147	ys <- fromVals y
1148	op1 "sort" . VList $ xs ++ ys
1149	op2 "IO::say" = op2Print True
1150	op2 "IO::print" = op2Print False
1151	op2 "printf" = op3 "IO::printf" (VHandle stdout)
1152	op2 "BUILDALL" = cascadeMethod reverse "BUILD"
1153	op2 "Pugs::Internals::install_pragma_value" = \x y -> do
1154	name <- fromVal x
1155	val <- fromVal y
1156	idat <- asks envInitDat
1157	idatval <- stm $ readTVar idat
1158	--trace ("installing " ++ name ++ "/" ++ (show val)) $ return ()
1159	let prag = initPragmas idatval
1160	stm $ writeTVar idat idatval{initPragmas =
1161	MkPrag{ pragName=name, pragDat=val } : prag }
1162	return (VBool True)
1163	op2 "Pugs::Internals::base" = \x y -> do
1164	base <- fromVal x
1165	case y of
1166	VRef{} -> op2BasedDigits base =<< fromVal y
1167	VList{} -> op2BasedDigits base =<< fromVal y
1168	_ -> do
1169	str <- fromVal y
1170	op2BasedDigits base [ s \| Just s <- map baseDigit str ]
1171	op2 "HOW::does" = \t p -> do
1172	meta <- readRef =<< fromVal t
1173	fetch <- doHash meta hash_fetchVal
1174	name <- fromVal =<< fetch "name"
1175	roles <- fromVals p
1176	mixinRoles name roles
1177	return undef
1178
1179	op2 ('!':name) = \x y -> op1Cast (VBool . not) =<< op2 name x y
1180	op2 other = \_ _ -> fail ("Unimplemented binaryOp: " ++ other)
1181
1182	baseDigit :: Char -> Maybe Val
1183	baseDigit '.' = return (VStr ".")
1184	baseDigit ch \| ch >= '0' && ch <= '9' = return (castV (ord ch - ord '0'))
1185	baseDigit ch \| ch >= 'a' && ch <= 'z' = return (castV (ord ch - ord 'a' + 10))
1186	baseDigit ch \| ch >= 'A' && ch <= 'Z' = return (castV (ord ch - ord 'A' + 10))
1187	baseDigit _ = Nothing
1188
1189	op2BasedDigits :: VInt -> [Val] -> Eval Val
1190	op2BasedDigits base vs
1191	\| null post = do
1192	pre' <- mapM fromVal pre
1193	return $ VInt (asIntegral pre')
1194	\| otherwise = do
1195	pre' <- mapM fromVal pre
1196	post' <- mapM fromVal $ tail post
1197	return $ VRat (asFractional (0:post') + (asIntegral pre' % 1))
1198	where
1199	(pre, post) = break (== VStr ".") $ filter (/= VStr "_") vs
1200	asIntegral = foldl (\x d -> base * x + d) 0
1201	asFractional :: [VInt] -> VRat
1202	asFractional = foldr (\d x -> (x / (base % 1)) + (d % 1)) (0 % 1)
1203
1204	op2Print :: Bool -> Val -> Val -> Eval Val
1205	op2Print wantNewline h v = do
1206	handle <- fromVal h
1207	strs <- mapM fromVal =<< case v of
1208	VList vs -> return vs
1209	_ -> return [v]
1210	guardIO $ do
1211	forM_ strs (hPutStr handle . encodeUTF8)
1212	when wantNewline (hPutStr handle "\n")
1213	return $ VBool True
1214
1215	op2Split :: Val -> Val -> Eval Val
1216	op2Split x y = do
1217	val <- fromVal x
1218	str <- fromVal y
1219	case val of
1220	VRule rx -> do
1221	chunks <- rxSplit rx str
1222	return $ VList chunks
1223	_ -> do
1224	delim <- fromVal val
1225	return $ split' delim str
1226	where
1227	split' :: VStr -> VStr -> Val
1228	split' [] xs = VList $ map (VStr . (:[])) xs
1229	split' glue xs = VList $ map VStr $ split glue xs
1230
1231	op2MaybeListop :: forall tlist titem. (Value tlist, Value [tlist], Value titem) =>
1232	([tlist] -> Val) -> (titem -> Val) -> Val -> Val -> Eval Val
1233	op2MaybeListop flist fitem lead rest = case lead of
1234	VList{} -> do
1235	lead' <- fromVal lead
1236	rest' <- fromVal rest
1237	return (flist $ lead' ++ rest')
1238	VRef ref -> do
1239	vs <- fromVal =<< readRef ref
1240	vlist <- fromVal rest
1241	return (flist $ vs ++ vlist)
1242	_ \| VList [] <- rest -> do
1243	-- Probably a single item.
1244	item <- fromVal lead
1245	return (fitem item)
1246	_ -> do
1247	lead' <- fromVal lead
1248	rest' <- fromVal rest
1249	return (flist (lead':rest'))
1250
1251	-- \|Implementation of 3-arity primitive operators and functions
1252	op3 :: String -> Val -> Val -> Val -> Eval Val
1253	op3 "Pugs::Internals::exec" = \x y z -> do
1254	prog <- fromVal x
1255	shell <- fromVal y
1256	args <- fromVals z
1257	exitCode <- guardIO $ executeFile' prog shell args Nothing
1258	rv <- handleExitCode exitCode
1259	when (rv == VBool True) $ do
1260	guardIO $ exitWith ExitSuccess
1261	return rv
1262	op3 "Pugs::Internals::caller" = \x y z -> do
1263	--kind <- fromVal =<< op1 "WHAT" x
1264	kind <- case x of
1265	VStr str -> return $ mkType str
1266	_ -> fromVal x
1267	skip <- fromVal y
1268	when (skip < 0) $ do
1269	fail "Pugs::Internals::caller called with negative skip"
1270	label <- fromVal z
1271	op3Caller kind skip label
1272	op3 "index" = \x y z -> do
1273	str <- fromVal x
1274	sub <- fromVal y
1275	pos <- fromVal z
1276	return . VInt $ doIndex 0 str sub pos
1277	where
1278	doIndex :: VInt -> VStr -> VStr -> VInt -> VInt
1279	doIndex n a b p
1280	\| p > 0, null a = doIndex n a b 0
1281	\| p > 0 = doIndex (n+1) (tail a) b (p-1)
1282	\| b `isPrefixOf` a = n
1283	\| null a = -1
1284	\| otherwise = doIndex (n+1) (tail a) b 0
1285	op3 "rindex" = \x y z -> do
1286	str <- fromVal x
1287	sub <- fromVal y
1288	pos <- fromVal z
1289	let skip \| defined z = length str - pos - length sub
1290	\| otherwise = 0
1291	return . VInt $ doRindex str sub skip
1292	where
1293	doRindex :: VStr -> VStr -> Int -> VInt
1294	doRindex a b skip
1295	\| skip > 0 = doRindex (init a) b (skip-1)
1296	\| b `isSuffixOf` a = toInteger $ length a - length b
1297	\| null a = -1
1298	\| otherwise = doRindex (init a) b 0
1299
1300	op3 "splice" = \x y z -> do
1301	op4 "splice" x y z (VList [])
1302	op3 "split" = op3Split
1303	op3 "Str::split" = \x y z -> do
1304	op3 "split" y x z
1305	op3 "HOW::new" = \t n p -> do
1306	cls <- op3 "Object::new" t n p
1307	meta <- readRef =<< fromVal cls
1308	fetch <- doHash meta hash_fetchVal
1309
1310	attrs <- fetch "attrs"
1311
1312	name <- fromVal =<< fetch "name" :: Eval String
1313	roles <- fromVals =<< fetch "does" :: Eval [String]
1314	supers <- fromVals =<< fetch "is" :: Eval [String]
1315
1316	-- Role flattening -- copy over things there and put it to symbol table
1317	-- XXX - also do renaming of concrete types mentioned in roles
1318	-- XXX - also, rewrite subEnv mentioned in the subs
1319	-- XXX - also, copy over the inheritance chain from role's metaobject
1320	mixinRoles name roles
1321
1322	-- Merge in slot definitions in "attrs"
1323	defs <- join $ doHash attrs hash_fetch
1324	parentAttrs <- forM (roles ++ supers) $ fetchMetaInfo "attrs"
1325	store <- doHash attrs hash_store
1326	store $ Map.unions (defs:parentAttrs)
1327
1328	return cls
1329
1330	op3 "Object::new" = \t n p -> do
1331	positionals <- fromVal p
1332	typ <- fromVal t
1333	named <- fromVal n
1334
1335	defs <- fetchMetaInfo "attrs" (showType typ)
1336	attrs <- io $ H.new (==) H.hashString
1337	writeIVar (IHash attrs) (named `Map.union` defs)
1338	uniq <- newObjectId
1339	unless (positionals == VList []) (fail "Must only use named arguments to new() constructor\nBe sure to use bareword keys.")
1340	let obj = VObject $ MkObject
1341	{ objType = typ
1342	, objAttrs = attrs
1343	, objId = uniq
1344	, objOpaque = Nothing
1345	}
1346	-- Now start calling BUILD for each of parent classes (if defined)
1347	op2 "BUILDALL" obj $ (VRef . hashRef) named
1348	-- Register finalizers by keeping weakrefs somehow
1349	setFinalization obj
1350
1351	op3 "Object::clone" = \t n _ -> do
1352	named <- fromVal n
1353	(VObject o) <- fromVal t
1354	attrs <- readIVar (IHash $ objAttrs o)
1355	attrs' <- io $ H.new (==) H.hashString
1356	uniq <- newObjectId
1357	writeIVar (IHash attrs') (named `Map.union` attrs)
1358	return $ VObject o{ objAttrs = attrs', objId = uniq }
1359
1360	op3 "Pugs::Internals::hSeek" = \x y z -> do
1361	handle <- fromVal x
1362	pos <- fromVal y
1363	mode <- fromVal z
1364	guardIO $ hSeek handle (modeOf mode) pos
1365	retEmpty
1366	where
1367	modeOf :: Int -> SeekMode
1368	modeOf 0 = AbsoluteSeek
1369	modeOf 1 = RelativeSeek
1370	modeOf 2 = SeekFromEnd
1371	modeOf m = error ("Unknown seek mode: " ++ (show m))
1372	op3 "IO::printf" = \x y z -> do
1373	rv <- evalExp $ App (_Var "&sprintf") Nothing [Val y, Val z]
1374	op2Print False x rv
1375	op3 other = \_ _ _ -> fail ("Unimplemented 3-ary op: " ++ other)
1376
1377	mixinRoles :: String -> [String] -> Eval ()
1378	mixinRoles name roles = do
1379	glob <- asks envGlobal
1380	let rolePkgs = map cast roles
1381	thisPkg = cast name
1382
1383	stm . modifyMPad glob $ \(MkPad entries) ->
1384	MkPad . Map.unionWith mergePadEntry entries . Map.fromList $
1385	[ (k{ v_package = thisPkg }, v)
1386	\| (k, v) <- Map.assocs entries
1387	, v_package k `elem` rolePkgs
1388	]
1389
1390	op3Split :: Val -> Val -> Val -> Eval Val
1391	op3Split x y z = do
1392	val <- fromVal x
1393	str <- fromVal y
1394	limit <- fromVal z
1395	case val of
1396	VRule rx -> do
1397	chunks <- rxSplit_n rx str limit
1398	return $ VList chunks
1399	_ -> do
1400	delim <- fromVal val
1401	return $ split' delim str limit
1402	where
1403	split' :: VStr -> VStr -> Int -> Val
1404	split' [] xs n = VList $ (map (VStr . (:[])) (take (n-1) xs)) ++ [ VStr $ drop (n-1) xs ]
1405	split' glue xs n = VList $ map VStr $ split_n glue xs n
1406
1407	-- XXX - The "String" below wants to be Type.
1408	fetchMetaInfo :: Value a => String -> [Char] -> Eval a
1409	fetchMetaInfo key typ = do
1410	meta <- readRef =<< fromVal =<< evalExp (_Var (':':'*':typ))
1411	fetch <- doHash meta hash_fetchVal
1412	fromVal =<< fetch key
1413
1414	-- \|Implementation of 4-arity primitive operators and functions.
1415	-- Only substr and splice
1416	op4 :: String -> Val -> Val -> Val -> Val -> Eval Val
1417	op4 "substr" = \x y z w -> do
1418	str <- fromVal x
1419	pos <- fromVal y
1420	lenP <- fromVal z
1421	let len \| defined z = lenP
1422	\| otherwise = length str
1423	(pre, result, post) = doSubstr str pos len
1424	let change = \new -> do
1425	var <- fromVal x
1426	rep <- fromVal new
1427	writeRef var (VStr $ concat [pre, rep, post])
1428	-- If the replacement is given in w, change the str.
1429	when (defined w && not (defined result)) $ change w
1430	-- Return a proxy which will modify the str if assigned to.
1431	return $ VRef . MkRef $ proxyScalar (return result) change
1432	where
1433	doSubstr :: VStr -> Int -> Int -> (VStr, Val, VStr)
1434	doSubstr str pos len
1435	\| abs pos > length str = ("", VUndef, "")
1436	\| pos < 0 = doSubstr str (length str + pos) len
1437	\| len < 0 = doSubstr str pos (length str - pos + len)
1438	\| otherwise = ((take pos str), VStr (take len $ drop pos str), (drop (pos + len) str))
1439
1440	-- op4 "splice" = \x y z w-> do
1441	op4 "splice" = \x y z w -> do
1442	splice <- doArray x array_splice
1443	start <- fromVal y
1444	count <- fromVal z
1445	vals <- fromVals w
1446	vals' <- splice start count vals
1447	return $ VList vals'
1448
1449	op4 other = \_ _ _ _ -> fail ("Unimplemented 4-ary op: " ++ other)
1450
1451	op1Range :: Val -> Eval Val
1452	op1Range (VStr s) = return . VList $ map VStr $ strRangeInf s
1453	op1Range (VRat n) = return . VList $ map VRat [n ..]
1454	op1Range (VNum n) = return . VList $ map VNum [n ..]
1455	op1Range (VInt n) = return . VList $ map VInt [n ..]
1456	op1Range x = do
1457	int <- fromVal x
1458	op1Range (VInt int)
1459
1460	{- In the four op2Range* functions below, rationals
1461	have to be handled separately because Haskell ranges
1462	are different from Perl 6 ranges. For example,
1463	in Haskell, [1.1 .. 2] will return [1.1,2.1]. So, we
1464	run the elements through a filter to ensure that the
1465	upper bound is satisfied
1466	-}
1467	op2Range :: Val -> Val -> Eval Val
1468	op2Range (VStr s) y = do
1469	y' <- fromVal y
1470	return . VList $ map VStr $ strRange s y'
1471	op2Range (VNum n) y = do
1472	y' <- fromVal y
1473	return . VList $ map VNum [n .. y']
1474	op2Range x (VNum n) = do
1475	x' <- fromVal x
1476	return . VList $ map VNum [x' .. n]
1477	op2Range (VRat n) y = do
1478	y' <- fromVal y
1479	return . VList $ map VRat (filter (<= y') [n .. y'])
1480	op2Range x (VRat n) = do
1481	x' <- fromVal x
1482	return . VList $ map VRat (filter (<= n) [x' .. n])
1483	op2Range x y = do
1484	x' <- fromVal x
1485	y' <- fromVal y
1486	return . VList $ map VInt [x' .. y']
1487
1488	-- because the right-exclusivity of a range can leave it
1489	-- with no remaining elements, we need to check before
1490	-- removing an element when enforcing left-exclusivity
1491	removeRangeFirst :: [Val] -> [Val]
1492	removeRangeFirst vals = if null vals then vals else init vals
1493
1494	op2RangeExclRight :: Val -> Val -> Eval Val
1495	op2RangeExclRight (VRat n) y = do
1496	y' <- fromVal y
1497	return . VList $ map VRat (filter (< y') [n .. y'])
1498	op2RangeExclRight x (VRat n) = do
1499	x' <- fromVal x
1500	return . VList $ map VRat (filter (< n) [x' .. n])
1501	op2RangeExclRight x y = do
1502	VList vals <- op2Range x y
1503	return . VList $ removeRangeFirst vals
1504
1505	op2RangeExclLeft :: Val -> Val -> Eval Val
1506	op2RangeExclLeft (VRat n) y = do
1507	y' <- fromVal y
1508	return . VList $ map VRat (filter (\v -> n < v && v <= y') [n .. y'])
1509	op2RangeExclLeft x (VRat n) = do
1510	x' <- fromVal x
1511	return . VList $ map VRat (filter (\v -> x' < v && v <= n) [x' .. n])
1512	op2RangeExclLeft x y = do
1513	VList vals <- op2Range x y
1514	return . VList $ tail vals
1515
1516	op2RangeExclBoth :: Val -> Val -> Eval Val
1517	op2RangeExclBoth (VRat n) y = do
1518	y' <- fromVal y
1519	return . VList $ map VRat (filter (\v -> n < v && v < y') [n .. y'])
1520	op2RangeExclBoth x (VRat n) = do
1521	x' <- fromVal x
1522	return . VList $ map VRat (filter (\v -> x' < v && v < n) [x' .. n])
1523	op2RangeExclBoth x y = do
1524	VList vals <- op2Range x y
1525	return . VList $ removeRangeFirst (tail vals)
1526
1527	op2ChainedList :: Val -> Val -> Val
1528	op2ChainedList x y
1529	\| VList xs <- x, VList ys <- y = VList $ xs ++ ys
1530	\| VList xs <- x = VList $ xs ++ [y]
1531	\| VList ys <- y = VList (x:ys)
1532	\| otherwise = VList [x, y]
1533
1534	op2Logical :: (Val -> Eval Bool) -> Val -> Val -> Eval Val
1535	op2Logical f x y = do
1536	ok <- f x
1537	if ok then return x else do
1538	ref <- fromVal y
1539	forceRef ref
1540
1541	op2Identity :: Val -> Val -> Eval Val
1542	op2Identity (VObject x) (VObject y) = return $ VBool (objId x == objId y)
1543	op2Identity (VRef ref) y = do
1544	x <- readRef ref
1545	op2Identity x y
1546	op2Identity x (VRef ref) = do
1547	y <- readRef ref
1548	op2Identity x y
1549	op2Identity x y = do
1550	return $ VBool (x == y)
1551
1552	op2Cmp :: (a -> Eval b) -> (b -> b -> VBool) -> a -> a -> Eval Val
1553	op2Cmp f cmp x y = do
1554	x' <- f x
1555	y' <- f y
1556	return $ VBool $ x' `cmp` y'
1557
1558	op2Ord :: (Ord ord) => (Val -> Eval ord) -> Val -> Val -> Eval Val
1559	op2Ord f x y = withDefined [x, y] $ do
1560	x' <- f x
1561	y' <- f y
1562	return $ VInt $ case x' `compare` y' of
1563	LT -> -1
1564	EQ -> 0
1565	GT -> 1
1566
1567	isNumeric :: Val -> Bool
1568	isNumeric (VNum {}) = True
1569	isNumeric (VRat {}) = True
1570	isNumeric (VInt {}) = True
1571	isNumeric _ = False
1572
1573	op2OrdNumStr :: Val -> Val -> Eval Val
1574	op2OrdNumStr x y
1575	\| isNumeric x && isNumeric y = op2Ord vCastRat x y
1576	\| otherwise = op2Ord vCastStr x y
1577
1578	op3Caller :: Type -> Int -> Val -> Eval Val
1579	--op3Caller kind skip label = do
1580	op3Caller kind skip _ = do -- figure out label
1581	chain <- callChain =<< ask
1582	formatFrame $ filter labelFilter $ drop skip $ filter kindFilter chain
1583	where
1584	formatFrame :: [(Env, Maybe VCode)] -> Eval Val
1585	formatFrame [] = retEmpty
1586	formatFrame ((env, Just sub):_) = retSeq
1587	[ VStr $ cast (envPackage env) -- .package
1588	, VStr $ cast (posName $ envPos env) -- .file
1589	, VInt $ toInteger $ posBeginLine $ envPos env -- .line
1590	, VStr $ cast (subName sub) -- .subname
1591	, VStr $ show $ subType sub -- .subtype
1592	, VCode $ sub -- .sub
1593	-- TODO: add more things as they are specced.
1594	]
1595	formatFrame ((env, _):_) = retSeq
1596	[ VStr $ cast (envPackage env) -- .package
1597	, VStr $ cast (posName $ envPos env) -- .file
1598	, VInt $ toInteger $ posBeginLine $ envPos env -- .line
1599	]
1600	kindFilter :: (Env, Maybe VCode) -> Bool
1601	kindFilter (_, Just sub) =
1602	case (showType kind, subType sub) of
1603	("Any", _) -> True -- I hope this is optimized
1604	("Method", SubMethod) -> True
1605	("Sub", SubRoutine) -> True
1606	("Block", SubBlock) -> True
1607	("Block", SubPointy) -> True
1608	(_, _) -> False
1609	kindFilter _ = kind == anyType
1610	labelFilter _ = True -- TODO: figure out how
1611	callChain :: Env -> Eval [(Env, Maybe VCode)]
1612	callChain cur =
1613	case envCaller cur of
1614	Just caller -> do
1615	val <- local (const caller) (readVar $ cast "&?ROUTINE")
1616	if (val == undef) then return [(caller, Nothing)] else do
1617	sub <- fromVal val
1618	rest <- callChain caller
1619	return ((caller, Just sub) : rest)
1620	_ -> return []
1621
1622
1623	opPerl5 :: String -> [Val] -> Eval Val
1624	opPerl5 sub args = do
1625	env <- ask
1626	envSV <- io $ mkEnv env
1627	let prms = map (\i -> "$_[" ++ show i ++ "]") [0 .. (length args - 1)]
1628	subSV <- io $ evalPerl5 ("sub { " ++ sub ++ "(" ++ (concat $ intersperse ", " prms) ++ ") }") envSV (enumCxt cxtItemAny)
1629	argsSV <- mapM fromVal args
1630	runInvokePerl5 subSV nullSV argsSV
1631
1632	evalPerl5WithCurrentEnv :: String -> Eval Val
1633	evalPerl5WithCurrentEnv code = do
1634	env <- ask
1635	guardIO $ do
1636	envSV <- mkEnv env
1637	sv <- evalPerl5 code envSV $ enumCxt cxtItemAny
1638	return (PerlSV sv)
1639
1640	atomicEval :: Eval Val -> Eval Val
1641	atomicEval action = do
1642	env <- ask
1643	if envAtomic env then action else do
1644	rv <- guardSTM (runEvalSTM env action)
1645	case rv of
1646	VError{} -> retShift rv
1647	VControl{} -> retShift rv
1648	_ -> return rv
1649
1650	{-\| Assert that a list of Vals is all defined.
1651	This should 'fail' (in the Perl sense).
1652
1653	TOTHINK: report which element in the input list was the one
1654	triggering the failure. Just zipping with [1 ..] may not be
1655	enough because our caller may not be passing through its own
1656	input args in the same order and position to us.
1657
1658	-}
1659	withDefined :: (Monad m) => [Val] -> m a -> m a
1660	withDefined [] c = c
1661	withDefined (VUndef:_) _ = fail "use of uninitialized value"
1662	withDefined (VType{}:_) _ = fail "use of uninitialized value"
1663	withDefined (_:xs) c = withDefined xs c
1664
1665	-- \|Returns a transaction to install a primitive operator using
1666	-- 'Pugs.AST.genMultiSym'.
1667	-- The associativity determines the arity and fixity of ops.
1668	-- The primitive\'s subBody is defined in 'op0', 'op1', etc depending on arity,
1669	-- the default is 'op0'.
1670	-- The Pad symbol name is prefixed with \"&*\" for functions and
1671	-- \"&*\" ~ fixity ~ \":\" for operators.
1672	primOp :: String -> String -> Params -> String -> Bool -> Bool -> Bool -> STM PadMutator
1673	primOp sym assoc prms ret isSafe isMacro isExport = fullEval $ do
1674	prim <- genMultiSym var (sub (isSafe \|\| not safeMode)) mempty
1675	case assoc of
1676	-- Manufacture &infix:<!===> from &infix:<===>.
1677	"chain" \| head sym /= '!' -> do
1678	prim' <- primOp ('!':sym) assoc prms ret isSafe isMacro isExport
1679	return (prim . prim')
1680	_ \| isExport -> do
1681	-- Here we rewrite a multi form that redispatches into the method form.
1682	prim' <- genMultiSym (var{ v_package = emptyPkg }) (sub (isSafe \|\| not safeMode)) mempty
1683	return (prim . prim')
1684	_ -> return prim
1685	where
1686	-- It is vital that we generate the ID for the Var for all the primitives at once,
1687	-- otherwise they'll be generated unpredictably during runtime with an as-needed basis,
1688	-- which may introduce race conditions under e.g. anotmer atomic block.
1689	fullEval x = idKey (v_name var) `seq` x
1690
1691	-- In safemode, we filter all prims marked as "unsafe".
1692	var \| isAlpha (head sym)
1693	, fixity == "prefix"
1694	= cast ("&*" ++ sym)
1695	\| otherwise
1696	= cast ("&*" ++ fixity ++ (':':sym))
1697
1698	pkg = do
1699	(_, pre) <- breakOnGlue "::" (reverse sym)
1700	return $ dropWhile (not . isAlphaNum) (reverse pre)
1701
1702	sub safe = codeRef $! mkPrim
1703	{ subName = cast sym
1704	, subType = case pkg of
1705	Nothing \| isMacro -> SubMacro
1706	\| otherwise -> SubPrim
1707	Just "Pugs::Internals" -> SubPrim
1708	_ -> SubMethod
1709	, subAssoc = case assoc of
1710	"left" -> A_left
1711	"right" -> A_right
1712	"non" -> A_non
1713	"chain" -> A_chain
1714	"list" -> A_list
1715	"spre" -> AIrrelevantToParsing -- XXX HACK
1716	_ -> ANil
1717	, subParams = prms
1718	, subReturns = mkType ret
1719	, subBody = Prim $! if safe then f else unsafe
1720	}
1721	unsafe :: [Val] -> Eval Val
1722	unsafe _ = fail $ "Unsafe function '" ++ sym ++ "' called under safe mode"
1723	f :: [Val] -> Eval Val
1724	f = case arity of
1725	Arity0 -> op0 sym
1726	Arity1 -> \x -> case x of
1727	[a] -> op1 symName a
1728	[a,b] -> op2 sym a b
1729	[a,b,c] -> op3 sym a b c
1730	[a,b,c,d] -> op4 sym a b c d
1731	a -> op0 sym a
1732	Arity2 -> \[x,y] -> op2 sym x y
1733	symName = if modify then assoc ++ ":" ++ sym else sym
1734	-- prefix symName with post, circum or other (not yet used)
1735	-- to disambiguate, for example, &prefix:++ and &postfix:++ in 'op0'
1736	(arity, fixity, modify) = case assoc of
1737	"pre" -> (Arity1, "prefix", False)
1738	"spre" -> (Arity1, "prefix", False)
1739	"post" -> (Arity1, "postfix", True)
1740	"circum" -> (Arity1, "circumfix", True)
1741	"left" -> (Arity2, "infix", False)
1742	"right" -> (Arity2, "infix", False)
1743	"non" -> (Arity2, "infix", False)
1744	"chain" -> (Arity2, "infix", False)
1745	"list" -> (Arity0, "infix", False)
1746	other -> (Arity0, other, True)
1747
1748	data Arity = Arity0 \| Arity1 \| Arity2
1749	deriving (Show, Eq, Ord, Typeable)
1750
1751	-- \|Produce a Pad update transaction with 'primOp' from a string description
1752	primDecl :: String -> STM PadMutator
1753	primDecl str = length str `seq` rv `seq` rv
1754	where
1755	rv = primOp sym assoc params ret
1756	("safe" `isPrefixOf` traits)
1757	("macro" `isSuffixOf` traits)
1758	("export" `isSuffixOf` traits)
1759	(ret:assoc:sym:traits:prms) = words str
1760	takeWord = takeWord' . dropWhile (not . isWord)
1761	takeWord' "" = ""
1762	takeWord' (':':':':xs) = (':':':':takeWord' xs)
1763	takeWord' (x:xs) \| isWord x = (x:takeWord' xs)
1764	takeWord' _ = ""
1765	isWord = not . (`elem` "(),:")
1766	prms' = map takeWord prms
1767	prms'' = foldr foldParam [] prms'
1768	params = map (\p -> p{ isWritable = isLValue p }) prms''
1769
1770	setFinalization :: Val -> Eval Val
1771	setFinalization obj = do
1772	env <- ask
1773	-- XXX - Not sure if this can break guarantees in STM or not; disable for now
1774	if envAtomic env
1775	then return obj -- stm $ unsafeIOToSTM (obj `setFinalization` env)
1776	else io $ obj `setFinalizationIn` env
1777	where
1778	setFinalizationIn obj env = do
1779	objRef <- mkWeakPtr obj . Just $ do
1780	runEvalIO env $ do
1781	evalExp $ App (_Var "&DESTROYALL") (Just $ Val obj) []
1782	return ()
1783	modifyIORef _GlobalFinalizer (>> finalize objRef)
1784	return obj
1785
1786	-- A "box" to put our polymorphic printer in
1787	newtype PrettyPrinter = MkPrettyPrinter { runPrinter :: forall a. Pretty a => a -> String }
1788
1789	-- op1 "perl"
1790	op1Pretty :: PrettyPrinter -> Val -> Eval Val
1791	op1Pretty printer v = do
1792	recur <- io (newTVarIO False)
1793	let ?seen = IntSet.empty
1794	?recur = recur
1795	?printer = printer
1796	rv <- prettyVal v
1797	isRecur <- stm (readTVar recur)
1798	return $ VStr $ decodeUTF8 $ if isRecur then "$_ := " ++ rv else rv
1799
1800	prettyVal :: (?seen :: IntSet.IntSet, ?recur :: TVar Bool, ?printer :: PrettyPrinter) => Val -> Eval VStr
1801	prettyVal v@(VRef r) = do
1802	ptr <- io (stableAddressOf r)
1803	if IntSet.member ptr ?seen
1804	then do
1805	stm $ writeTVar ?recur True
1806	return "\\$_"
1807	else let ?seen = IntSet.insert ptr ?seen in doPrettyVal v
1808	prettyVal v = doPrettyVal v
1809
1810	doPrettyVal :: (?seen :: IntSet.IntSet, ?recur :: TVar Bool, ?printer :: PrettyPrinter) => Val -> Eval VStr
1811	doPrettyVal v@(VRef r) = do
1812	v' <- readRef r
1813	ifValTypeIsa v "Pair"
1814	(case v' of
1815	VList [ks, vs] -> do
1816	kStr <- prettyVal ks
1817	vStr <- prettyVal vs
1818	return $ "(" ++ kStr ++ " => " ++ vStr ++ ")"
1819	_ -> prettyVal v'
1820	)
1821	(do str <- prettyVal v'
1822	ifValTypeIsa v "Array"
1823	(return $ ('[':(init (tail str))) ++ "]")
1824	(ifValTypeIsa v "Hash"
1825	(return $ ('{':(init (tail str))) ++ "}")
1826	(return ('\\':str)))
1827	)
1828	doPrettyVal (VList vs) = do
1829	vs' <- mapM prettyVal vs
1830	-- (3,) should dump as (3,), not a (3), which would be the same as 3.
1831	return $ case vs' of
1832	[] -> "()"
1833	[x] -> "(" ++ x ++ ",)"
1834	_ -> "(" ++ concat (intersperse ", " vs') ++ ")"
1835	doPrettyVal v@(VObject obj) = do
1836	-- ... dump the objAttrs
1837	-- XXX this needs fixing WRT demagicalized pairs:
1838	-- currently, this'll return Foo.new((attr => "value)), with the inner
1839	-- parens, which is, of course, wrong.
1840	hash <- fromVal v :: Eval VHash
1841	str <- prettyVal (VRef (hashRef hash))
1842	return $ showType (objType obj)
1843	++ ".new(" ++ init (tail str) ++ ")"
1844	doPrettyVal v = return (runPrinter ?printer v)
1845
1846	-- XXX -- Junctive Types -- XXX --
1847
1848	-- spre is "symbolic pre", that is, operators for which a precedence has
1849	-- already been assigned in Parser.hs
1850
1851	-- \|Initial set global symbols to populate the evaluation environment
1852	-- in the form of Pad mutating transactions built with 'primDecl'.
1853	--
1854	-- The source string format is:
1855	--
1856	-- > ret_val assoc op_name [safe\|unsafe] args
1857	initSyms :: STM [PadMutator]
1858	initSyms = seq (length syms) $ do
1859	rv <- mapM primDecl syms
1860	length rv `seq` return (length rv `seq` rv)
1861	where
1862	syms = filter (not . null) . lines $ "\
1863	\\n Bool spre ! safe (Bool)\
1864	\\n Num spre + safe (Num)\
1865	\\n Num pre abs safe (Num)\
1866	\\n Int pre Pugs::Internals::truncate safe (Num)\
1867	\\n Int pre Pugs::Internals::round safe (Num)\
1868	\\n Int pre Pugs::Internals::floor safe (Num)\
1869	\\n Int pre Pugs::Internals::ceiling safe (Num)\
1870	\\n Num pre atan safe (Num)\
1871	\\n Num pre atan safe (Num, Num)\
1872	\\n Num pre cos safe (Num)\
1873	\\n Num pre sin safe (Num)\
1874	\\n Num pre tan safe (Num)\
1875	\\n Any pre Pugs::Internals::pi safe ()\
1876	\\n Any pre self safe,macro ()\
1877	\\n Bool pre nothing safe ()\
1878	\\n Num pre exp safe (Num, ?Num)\
1879	\\n Num pre sqrt safe (Num)\
1880	\\n Num spre - safe (Num)\
1881	\\n Str spre ~ safe (Str)\
1882	\\n Bool spre ? safe (Bool)\
1883	\\n Str spre = unsafe (?IO)\
1884	\\n List spre = unsafe (?IO)\
1885	\\n Str pre readline unsafe (?IO)\
1886	\\n List pre readline unsafe (?IO)\
1887	\\n Str pre getc unsafe (?IO)\
1888	\\n Str pre Pugs::Safe::safe_getc safe ()\
1889	\\n Str pre Pugs::Safe::safe_readline safe ()\
1890	\\n Int pre int safe (Int)\
1891	\\n List pre list safe (List)\
1892	\\n Hash pre hash safe (List)\
1893	\\n List pre pair safe (List)\
1894	\\n Scalar pre item safe (Scalar)\
1895	\\n Str pre Scalar::reverse safe (Scalar)\
1896	\\n Any pre List::reverse safe (Array)\
1897	\\n Any pre reverse safe (Scalar, List)\
1898	\\n Any pre reverse safe ()\
1899	\\n List pre eager safe (List)\
1900	\\n Int spre +^ safe (Int)\
1901	\\n Int spre ~^ safe (Str)\
1902	\\n Bool spre ?^ safe (Bool)\
1903	\\n Ref spre \\ safe (rw!Any)\
1904	\\n List spre ^ safe (Scalar)\
1905	\\n List post ... safe (Str)\
1906	\\n List post ... safe (Scalar)\
1907	\\n Any pre undef safe ()\
1908	\\n Any pre undefine safe (?rw!Any)\
1909	\\n Str pre chop safe (Str)\
1910	\\n Str pre Scalar::chomp safe (Scalar)\
1911	\\n Any pre chomp safe (Scalar, List)\
1912	\\n Any pre chomp safe ()\
1913	\\n Any right = safe (rw!Any, Any)\
1914	\\n Int pre index safe (Str, Str, ?Int=0)\
1915	\\n Int pre rindex safe (Str, Str, ?Int)\
1916	\\n Int pre substr safe (rw!Str, Int, ?Int, ?Str)\
1917	\\n Str pre lc safe (Str)\
1918	\\n Str pre quotemeta safe (Str)\
1919	\\n Str pre lcfirst safe (Str)\
1920	\\n Str pre uc safe (Str)\
1921	\\n Str pre ucfirst safe (Str)\
1922	\\n Str pre capitalize safe (Str)\
1923	\\n Str pre crypt safe (Str, Str)\
1924	\\n Str post ++ safe (rw!Str)\
1925	\\n Str post -- safe (rw!Str)\
1926	\\n Num post ++ safe (rw!Num)\
1927	\\n Num post -- safe (rw!Num)\
1928	\\n Complex post i safe (Num)\
1929	\\n Str spre ++ safe (rw!Str)\
1930	\\n Str spre -- safe (rw!Str)\
1931	\\n Num spre ++ safe (rw!Num)\
1932	\\n Num spre -- safe (rw!Num)\
1933	\\n Bool pre not safe (Bool)\
1934	\\n Bool pre true safe (Bool)\
1935	\\n List spre gather safe (Code)\
1936	\\n List pre map safe (Code, List)\
1937	\\n List pre grep safe (Code, List)\
1938	\\n Scalar pre first safe (Code, List)\
1939	\\n List pre sort safe (Code, List)\
1940	\\n List pre reduce safe (Code, List)\
1941	\\n List pre produce safe (Code, List)\
1942	\\n List pre sort safe (Array)\
1943	\\n List pre map safe (Array: Code)\
1944	\\n List pre grep safe (Array: Code)\
1945	\\n Scalar pre first safe (Array: Code)\
1946	\\n List pre sort safe (Array: Code)\
1947	\\n List pre reduce safe (Array: Code)\
1948	\\n List pre produce safe (Array: Code)\
1949	\\n Any pre splice safe (rw!Array, ?Int=0)\
1950	\\n Any pre splice safe (rw!Array, Int, Int)\
1951	\\n Any pre splice safe (rw!Array, Int, Int, List)\
1952	\\n Int pre push safe (rw!Array, List)\
1953	\\n Int pre unshift safe (rw!Array, List)\
1954	\\n Scalar pre List::pop safe (rw!Array)\
1955	\\n Scalar pre List::shift safe (rw!Array)\
1956	\\n Scalar pre sum safe (List)\
1957	\\n Scalar pre min safe (List)\
1958	\\n Scalar pre max safe (List)\
1959	\\n List pre uniq safe (List)\
1960	\\n Str pre join safe (Array: Str)\
1961	\\n Str pre join safe (Str, List)\
1962	\\n Any pre join safe (Thread)\
1963	\\n Bool pre detach safe (Thread)\
1964	\\n List pre cat safe (List)\
1965	\\n List pre zip safe (List)\
1966	\\n List pre each safe (List)\
1967	\\n List pre roundrobin safe (List)\
1968	\\n List pre keys safe (rw!Hash)\
1969	\\n List pre values safe (rw!Hash)\
1970	\\n List pre List::kv safe,export (rw!Hash)\
1971	\\n List pre pairs safe (rw!Hash)\
1972	\\n List pre keys safe (rw!Array)\
1973	\\n List pre values safe (rw!Array)\
1974	\\n List pre List::kv safe,export (rw!Array)\
1975	\\n List pre pairs safe (rw!Array)\
1976	\\n Scalar pre delete safe (rw!Hash: List)\
1977	\\n Scalar pre delete safe (rw!Array: List)\
1978	\\n Bool pre exists safe (rw!Hash: Str)\
1979	\\n Bool pre exists safe (rw!Array: Int)\
1980	\\n Str pre perl safe (rw!Any\|Junction)\
1981	\\n Str pre guts safe (rw!Any\|Junction)\
1982	\\n Any pre try safe (Code)\
1983	\\n Any pre lazy safe (Code)\
1984	\\n Any pre contend safe (Code)\
1985	\\n Void pre defer safe ()\
1986	\\n Any pre Pugs::Internals::eval_perl6 safe (Str)\
1987	\\n Any pre evalfile unsafe (Str)\
1988	\\n Any pre Pugs::Internals::eval_parrot unsafe (Str)\
1989	\\n Any pre Pugs::Internals::eval_perl5 safe (Str)\
1990	\\n Any pre Pugs::Internals::eval_haskell unsafe (Str)\
1991	\\n Any pre Pugs::Internals::eval_p6y unsafe (Str)\
1992	\\n Any pre Pugs::Internals::evalfile_p6y unsafe (Str)\
1993	\\n Any pre Pugs::Internals::eval_yaml safe (Str)\
1994	\\n Any pre Pugs::Internals::emit_yaml unsafe (rw!Any)\
1995	\\n Str pre yaml safe (rw!Any\|Junction)\
1996	\\n Any pre Pugs::Internals::require unsafe (Str)\
1997	\\n Any pre Pugs::Internals::use unsafe (Str)\
1998	\\n Any pre require unsafe (Str)\
1999	\\n Any pre use unsafe (Str)\
2000	\\n Any pre require_haskell unsafe (Str)\
2001	\\n Any pre require_parrot unsafe (Str)\
2002	\\n Any pre require_perl5 unsafe (Str)\
2003	\\n Any pre require_java unsafe (Str)\
2004	\\n Any pre last safe (?Int=1)\
2005	\\n Any pre next safe (?Int=1)\
2006	\\n Any pre redo safe (?Int=1)\
2007	\\n Any pre continue safe (?Int=1)\
2008	\\n Any pre break safe (?Int=1)\
2009	\\n Any pre exit safe (?Int=0)\
2010	\\n Any pre srand safe (?Num)\
2011	\\n Num pre rand safe (?Num=1)\
2012	\\n Bool pre defined safe (Any)\
2013	\\n Str pre WHAT safe (rw!Any\|Junction)\
2014	\\n Str pre isa safe (rw!Any\|Junction, Str)\
2015	\\n Str pre does safe (rw!Any\|Junction, Str)\
2016	\\n Num pre time safe ()\
2017	\\n List pre times safe ()\
2018	\\n List pre Pugs::Internals::localtime safe (Num)\
2019	\\n Str pre want safe ()\
2020	\\n Str pre File::Spec::cwd unsafe ()\
2021	\\n Str pre File::Spec::tmpdir unsafe ()\
2022	\\n Str pre IO::next unsafe (IO)\
2023	\\n Bool pre IO::print unsafe (IO)\
2024	\\n Bool pre IO::print unsafe (IO: List)\
2025	\\n Bool pre print safe ()\
2026	\\n Bool pre print safe (List)\
2027	\\n Bool pre IO::printf unsafe (IO: Str, List)\
2028	\\n Bool pre printf safe (Str, List)\
2029	\\n Str pre Pugs::Internals::sprintf safe (Str, Num\|Rat\|Int\|Str)\
2030	\\n Bool pre IO::say unsafe (IO)\
2031	\\n Bool pre IO::say unsafe (IO: List)\
2032	\\n Bool pre say safe ()\
2033	\\n Bool pre say safe (List)\
2034	\\n Bool pre Pugs::Safe::safe_print safe (Str)\
2035	\\n Bool pre flush unsafe (IO)\
2036	\\n Bool pre IO::close unsafe,export (IO:)\
2037	\\n Bool pre Socket::close unsafe,export (Socket:)\
2038	\\n Bool pre die safe (?Object)\
2039	\\n Bool pre warn safe (List)\
2040	\\n Bool pre fail_ safe (?Object)\
2041	\\n Bool pre fail safe (?Object)\
2042	\\n Socket pre listen unsafe (Int)\
2043	\\n Socket pre connect unsafe (Str, Int)\
2044	\\n Any pre accept unsafe (Any)\
2045	\\n List pre slurp unsafe (Str)\
2046	\\n List pre slurp unsafe (Handle)\
2047	\\n List pre readdir unsafe (Str)\
2048	\\n Bool pre Pugs::Internals::exec unsafe (Str, Bool, List)\
2049	\\n Int pre run unsafe (Str)\
2050	\\n Int pre run unsafe (Str: List)\
2051	\\n Bool pre binmode unsafe (IO: ?Int=1)\
2052	\\n Void pre return safe ()\
2053	\\n Void pre return safe (rw!Any)\
2054	\\n Void pre return safe (List)\
2055	\\n Void pre leave safe ()\
2056	\\n Void pre leave safe (rw!Any)\
2057	\\n Void pre leave safe (List)\
2058	\\n Void pre yield safe ()\
2059	\\n Void pre yield safe (rw!Any)\
2060	\\n Void pre yield safe (List)\
2061	\\n Void pre take safe ()\
2062	\\n Void pre take safe (rw!Any)\
2063	\\n Void pre take safe (List)\
2064	\\n Junction pre any safe (List)\
2065	\\n Junction pre all safe (List)\
2066	\\n Junction pre one safe (List)\
2067	\\n Junction pre none safe (List)\
2068	\\n Bool pre sleep unsafe (Int)\
2069	\\n Bool pre rmdir unsafe (Str)\
2070	\\n Bool pre mkdir unsafe (Str)\
2071	\\n Bool pre chdir unsafe (Str)\
2072	\\n Int pre List::elems safe,export (rw!Array)\
2073	\\n Int pre List::end safe,export (Array)\
2074	\\n Int pre graphs safe (Str)\
2075	\\n Int pre codes safe (Str)\
2076	\\n Int pre chars safe (Str)\
2077	\\n Int pre bytes safe (Str)\
2078	\\n Int pre chmod unsafe (Int, List)\
2079	\\n Scalar pre Pair::key safe (rw!Pair)\
2080	\\n Scalar pre Pair::value safe (rw!Pair)\
2081	\\n List pre keys safe (rw!Pair)\
2082	\\n List pre values safe (Pair\|Junction)\
2083	\\n List pre Pair::kv safe,export (rw!Pair)\
2084	\\n List pre pairs safe (rw!Pair)\
2085	\\n Any pre pick safe (Any\|Junction)\
2086	\\n List pre pick safe (Any\|Junction: Int)\
2087	\\n Bool pre rename unsafe (Str, Str)\
2088	\\n Bool pre symlink unsafe (Str, Str)\
2089	\\n Bool pre link unsafe (Str, Str)\
2090	\\n Int pre unlink unsafe (List)\
2091	\\n Str pre readlink unsafe (Str)\
2092	\\n List pre Str::split safe (Str)\
2093	\\n List pre Str::split safe (Str: Str)\
2094	\\n List pre Str::split safe (Str: Regex)\
2095	\\n List pre Str::split safe (Str: Str, Int)\
2096	\\n List pre Str::split safe (Str: Regex, Int)\
2097	\\n List pre split safe (Str, Str)\
2098	\\n List pre split safe (Str, Str, Int)\
2099	\\n List pre split safe (Regex, Str)\
2100	\\n List pre split safe (Regex, Str, Int)\
2101	\\n Str spre = safe (Any)\
2102	\\n List spre = safe (Any)\
2103	\\n Junction list \| safe (Any\|Junction)\
2104	\\n Junction list & safe (Any\|Junction)\
2105	\\n Junction list ^ safe (Any\|Junction)\
2106	\\n Num left * safe (Num, Num)\
2107	\\n Num left / safe (Num, Num)\
2108	\\n Num left % safe (Num, Num)\
2109	\\n Str left x safe (Str, Int)\
2110	\\n List left xx safe (Any, Int)\
2111	\\n Int left +& safe (Int, Int)\
2112	\\n Int left +< safe (Int, Int)\
2113	\\n Int left +> safe (Int, Int)\
2114	\\n Str left ~& safe (Str, Str)\
2115	\\n Str left ~< safe (Str, Str)\
2116	\\n Str left ~> safe (Str, Str)\
2117	\\n Num right ** safe (Num, Num)\
2118	\\n Num left + safe (Num, Num)\
2119	\\n Num left - safe (Num, Num)\
2120	\\n Str left ~ safe (Str, Str)\
2121	\\n Int left +\| safe (Int, Int)\
2122	\\n Int left +^ safe (Int, Int)\
2123	\\n Str left ~\| safe (Str, Str)\
2124	\\n Str left ~^ safe (Str, Str)\
2125	\\n Bool left ?\| safe (Bool, Bool)\
2126	\\n Bool left ?^ safe (Bool, Bool)\
2127	\\n Bool left ?& safe (Bool, Bool)\
2128	\\n Pair right => safe (Any, Any)\
2129	\\n Int non cmp safe (Any, Any)\
2130	\\n Int non leg safe (Str, Str)\
2131	\\n Int non <=> safe (Num, Num)\
2132	\\n List non .. safe (Scalar, Scalar)\
2133	\\n List non ..^ safe (Scalar, Scalar)\
2134	\\n List non ^.. safe (Scalar, Scalar)\
2135	\\n List non ^..^ safe (Scalar, Scalar)\
2136	\\n Bool chain != safe (Num, Num)\
2137	\\n Bool chain == safe (Num, Num)\
2138	\\n Bool chain =:= safe (rw!Any, rw!Any)\
2139	\\n Bool chain === safe (Any, Any)\
2140	\\n Bool chain eqv safe (Any, Any)\
2141	\\n Bool chain ~~ safe (rw!Any, Any)\
2142	\\n Bool chain < safe (Num, Num)\
2143	\\n Bool chain <= safe (Num, Num)\
2144	\\n Bool chain > safe (Num, Num)\
2145	\\n Bool chain >= safe (Num, Num)\
2146	\\n Bool chain ne safe (Str, Str)\
2147	\\n Bool chain eq safe (Str, Str)\
2148	\\n Bool chain lt safe (Str, Str)\
2149	\\n Bool chain le safe (Str, Str)\
2150	\\n Bool chain gt safe (Str, Str)\
2151	\\n Bool chain ge safe (Str, Str)\
2152	\\n Scalar left && safe (Bool, ~Bool)\
2153	\\n Scalar left \|\| safe (Bool, ~Bool)\
2154	\\n Scalar left ^^ safe (Bool, Bool)\
2155	\\n Scalar left // safe (Bool, ~Bool)\
2156	\\n Scalar left .[] safe (Array, Int)\
2157	\\n Scalar left .{} safe (Hash, Str)\
2158	\\n List list Z safe (Array)\
2159	\\n List list X safe (Array)\
2160	\\n List spre <== safe (List)\
2161	\\n List left ==> safe (List, Code)\
2162	\\n Scalar left and safe (Bool, ~Bool)\
2163	\\n Scalar left or safe (Bool, ~Bool)\
2164	\\n Scalar left xor safe (Bool, Bool)\
2165	\\n Scalar left orelse safe (Bool, ~Bool)\
2166	\\n Scalar left andthen safe (Bool, ~Bool)\
2167	\\n Str pre chr safe (Int)\
2168	\\n Int pre ord safe (Str)\
2169	\\n Str pre oct safe (Str)\
2170	\\n Object pre stat unsafe (Str)\
2171	\\n Object pre lstat unsafe (Str)\
2172	\\n Int pre from safe (Match)\
2173	\\n Int pre to safe (Match)\
2174	\\n List pre matches safe (Match)\
2175	\\n Str pre oct safe (Int)\
2176	\\n Num pre log safe (Int)\
2177	\\n Num pre log safe (Num)\
2178	\\n Num pre log10 safe (Num)\
2179	\\n Thread pre async safe (Code)\
2180	\\n Thread pre fork unsafe ()\
2181	\\n Int pre sign safe (Num)\
2182	\\n Bool pre kill safe (Thread)\
2183	\\n Int pre kill unsafe (Int, List)\
2184	\\n Object pre Object::new safe,export (Object: Named)\
2185	\\n Object pre BUILDALL safe (Object)\
2186	\\n Object pre DESTROYALL safe (Object)\
2187	\\n Code pre TEMP safe (rw!Any)\
2188	\\n Object pre Object::clone safe (Object: Named)\
2189	\\n Class pre Object::HOW safe,export (Object)\
2190	\\n Object pre HOW::new safe (Object: Named)\
2191	\\n Object pre HOW::does safe (Object: List)\
2192	\\n Str pre Class::name safe (Class)\
2193	\\n Hash pre Class::traits safe (Class)\
2194	\\n Object pre WHICH safe (Any)\
2195	\\n Int pre Rat::numerator safe (Rat:)\
2196	\\n Int pre Rat::denominator safe (Rat:)\
2197	\\n Bool pre Thread::yield safe (Thread)\
2198	\\n List pre Pugs::Internals::runShellCommand unsafe (Str)\
2199	\\n List pre Pugs::Internals::runInteractiveCommand unsafe (Str)\
2200	\\n Bool pre Pugs::Internals::hSetBinaryMode unsafe (IO, Str)\
2201	\\n Void pre Pugs::Internals::hSeek unsafe (IO, Int, Int)\
2202	\\n Int pre IO::tell unsafe,export (IO)\
2203	\\n Bool pre Pugs::Internals::hIsOpen unsafe (IO)\
2204	\\n Bool pre Pugs::Internals::hIsClosed unsafe (IO)\
2205	\\n Bool pre Pugs::Internals::hIsReadable unsafe (IO)\
2206	\\n Bool pre Pugs::Internals::hIsWritable unsafe (IO)\
2207	\\n Bool pre Pugs::Internals::hIsSeekable unsafe (IO)\
2208	\\n IO pre Pugs::Internals::openFile unsafe (Str, Str)\
2209	\\n List pre Pugs::Internals::caller safe (Any, Int, Str)\
2210	\\n Any pre Pugs::Internals::check_for_io_leak safe (Code)\
2211	\\n Bool pre Bool::True safe ()\
2212	\\n Bool pre Bool::False safe ()\
2213	\\n Bool pre True safe,macro ()\
2214	\\n Bool pre False safe,macro ()\
2215	\\n List spre prefix:[,] safe (List)\
2216	\\n List spre prefix:@<< safe (List)\
2217	\\n List spre prefix:$<< safe (List)\
2218	\\n List spre prefix:&<< safe (List)\
2219	\\n List spre prefix:%<< safe (List)\
2220	\\n Str pre Code::name safe (Code:)\
2221	\\n Int pre Code::arity safe (Code:)\
2222	\\n Str pre Code::assoc safe (Code:)\
2223	\\n Code::Exp pre Code::body safe (Code:)\
2224	\\n Str pre Code::pos safe (Code:)\
2225	\\n Any pre Code::signature safe (Code:)\
2226	\\n IO::Dir pre opendir unsafe (Str)\
2227	\\n Str pre IO::Dir::read unsafe,export (IO::Dir:)\
2228	\\n List pre IO::Dir::read unsafe,export (IO::Dir:)\
2229	\\n Str pre IO::Dir::readdir unsafe,export (IO::Dir:)\
2230	\\n List pre IO::Dir::readdir unsafe,export (IO::Dir:)\
2231	\\n Bool pre IO::Dir::close unsafe,export (IO::Dir:)\
2232	\\n Bool pre IO::Dir::closedir unsafe,export (IO::Dir:)\
2233	\\n Bool pre IO::Dir::rewind unsafe,export (IO::Dir:)\
2234	\\n Bool pre IO::Dir::rewinddir unsafe,export (IO::Dir:)\
2235	\\n Any pre Pugs::Internals::reduceVar unsafe (Str)\
2236	\\n Str pre Pugs::Internals::rule_pattern safe (Regex)\
2237	\\n Hash pre Pugs::Internals::rule_adverbs safe (Regex)\
2238	\\n Int pre Pugs::Internals::install_pragma_value safe (Str, Int)\
2239	\\n Bool pre Pugs::Internals::current_pragma_value safe (Str)\
2240	\\n Bool pre Pugs::Internals::caller_pragma_value safe (Str)\
2241	\\n Num pre Pugs::Internals::base safe (Int, Any)\
2242	\\n Any pre vv safe (Any)\
2243	\\n"

Note: See TracBrowser for help on using the browser.

Context Navigation

root/src/Pugs/Prim.hs

Download in other formats: