Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 09702d8bb9
Fetching contributors…

Cannot retrieve contributors at this time

283 lines (242 sloc) 6.798 kb
(* Ferret scripting language
*
* Copyright (c) 2012 by Jeffrey Massung
*
* This file is provided to you under the Apache License,
* Version 2.0 (the "License"); you may not use this file
* except in compliance with the License. You may obtain
* a copy of the License at
*
* http://www.apache.org/licenses/LICENSE-2.0
*
* Unless required by applicable law or agreed to in writing,
* software distributed under the License is distributed on an
* "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
* KIND, either express or implied. See the License for the
* specific language governing permissions and limitations
* under the License.
*)
open Cell
open Core
open Interp
(* primitive exceptions *)
exception Empty_list
(* terminate the script *)
let prim_bye st xs =
exit 0
(* early-out of a closure *)
let prim_return st xs =
let (x,_) = reduce st xs in
raise (Return x)
(* attempt a block, if it fails, do the next one *)
let prim_try st xs =
let (block,xs') = reduce_block st xs in
let (catch,xs') = reduce_block st xs' in
(* TODO: pass the exception to the catch block *)
try does st [] block with _ -> does st [] catch
(* conditionally execute one block or another *)
let prim_if st xs =
let (test,xs') = reduce_bool st xs in
let (true_block,xs') = reduce_block st xs' in
let (false_block,xs') = reduce_block st xs' in
let branch = if test then true_block else false_block in
(fst (does st [] branch),xs')
(* conditionally execute a block *)
let prim_when st xs =
let (test,xs') = reduce_bool st xs in
let (block,xs') = reduce_block st xs' in
if test
then (fst (does st [] block),xs')
else (Nil,xs')
(* conditionally execute a block *)
let prim_unless st xs =
let (test,xs') = reduce_bool st xs in
let (block,xs') = reduce_block st xs' in
if test
then (Nil,xs')
else (fst (does st [] block),xs')
(* iterative for loop *)
let prim_for st xs =
let (limit,xs') = reduce_int st xs in
let (block,xs') = reduce_block st xs' in
for i = 0 to limit - 1 do
ignore (does st [Literal (Num (Int i))] block)
done;
(Nil,xs')
(* loop forever *)
let prim_loop st xs =
let (block,xs') = reduce_block st xs in
try
while true do
ignore (does st [] block)
done;
(Nil,xs')
with Break -> (Nil,xs')
(* conditional loop *)
let prim_while st xs =
let (test,xs') = reduce_block st xs in
let (block,xs') = reduce_block st xs' in
try
while true do
let (flag,_) = does st [] test in
if bool_of_cell flag
then ignore (does st [] block)
else raise Break
done;
(Nil,xs')
with Break -> (Nil,xs')
(* terminate a loop *)
let prim_break st xs =
raise Break
(* lift a block into the previous frame *)
let prim_lift st xs =
let (block,xs') = reduce_block st xs in
let (x,frame') = does st st.frame block in
st.frame <- frame';
(x,xs')
(* create a new lexical scope, passing a value to it *)
let prim_with st xs =
let (slice,xs') = reduce_slice st xs in
let (block,xs') = reduce_block st xs' in
let frame = List.map (fun x -> Literal x) slice in
let (x',_) = does st frame block in
(x',xs')
(* wait to execute a block until leaving scope *)
let prim_defer st xs =
let (block,xs') = reduce_block st xs in
st.defers <- block::st.defers;
(Nil,xs')
(* create an does closure *)
let prim_does st xs =
let (block,xs') = reduce_block st xs in
(Does block,xs')
(* evaluate a block *)
let prim_do st xs =
let (block,xs') = reduce_block st xs in
does st xs' block
(* spawn a process *)
let prim_spawn st xs =
let (block,xs') = reduce_block st xs in
let (args,xs') = reduce_slice st xs' in
let frame = List.map (fun x -> Literal x) args in
Process.fork_thread st frame block;
(Nil,xs')
(* sleep a process *)
let prim_sleep st xs =
let (secs,xs') = reduce_float st xs in
Thread.delay secs;
(Nil,xs')
(* create a new communication channel *)
let prim_chan st xs =
(Channel (Event.new_channel ()), xs)
(* send a value to a channel *)
let prim_send st xs =
let (chan,xs') = reduce_channel st xs in
let (x,xs') = reduce st xs' in
let event = Event.send chan x in
Event.sync event;
(Nil,xs')
(* receive a value from a channel *)
let prim_recv st xs =
let (chan,xs') = reduce_channel st xs in
let event = Event.receive chan in
let x = Event.sync event in
(x,xs')
(* coerce a term to a string *)
let prim_form st xs =
let (x,xs') = reduce st xs in
(String (form x),xs')
(* print a string to stdout *)
let prim_print st xs =
let (x,xs') = reduce st xs in
let s =
match x with
| String s -> s
| _ -> form x
in
print_string s;
(Nil,xs')
(* print a newline to stdout *)
let prim_cr st xs =
print_newline ();
(Nil,xs)
(* true if a list is empty *)
let prim_null st xs =
let (slice,xs') = reduce_slice st xs in
(Bool (slice = []),xs')
(* head of a list *)
let prim_hd st xs =
let (slice,xs') = reduce_slice st xs in
match slice with
| [] -> raise Empty_list
| x::_ -> (x,xs')
(* tail of a list *)
let prim_tl st xs =
let (slice,xs') = reduce_slice st xs in
match slice with
| [] -> raise Empty_list
| _::x -> (Slice x,xs')
(* unary math operations where ints will upcast to floats *)
let unary_num_op i f =
fun st xs ->
let (x,xs') = reduce_num st xs in
match x with
| Int n -> (Num (Int (i n)),xs')
| Float n -> (Num (Float (f n)),xs')
(* unary floating-point function *)
let unary_float_op f =
fun st xs -> let (x,xs') = reduce_float st xs in (Num (Float (f x)),xs')
(* native functions *)
let prims =
[ ("bye", prim_bye)
(* flow functions *)
; ("return", prim_return)
; ("try", prim_try)
; ("if", prim_if)
; ("when", prim_when)
; ("unless", prim_unless)
; ("for", prim_for)
; ("loop", prim_loop)
; ("while", prim_while)
; ("break", prim_break)
(* block functions *)
; ("lift", prim_lift)
; ("with", prim_with)
; ("defer", prim_defer)
; ("does", prim_does)
; ("do", prim_do)
(* process functions *)
; ("spawn", prim_spawn)
; ("sleep", prim_sleep)
(* channel functions *)
; ("chan", prim_chan)
; ("send", prim_send)
; ("recv", prim_recv)
(* string functions *)
; ("form", prim_form)
(* stdout functions *)
; ("print", prim_print)
; ("cr", prim_cr)
(* list functions *)
; ("null", prim_null)
; ("hd", prim_hd)
; ("tl", prim_tl)
(* math functions *)
; ("neg", unary_num_op ( ~- ) ( ~-. ))
; ("abs", unary_num_op abs abs_float)
; ("sqrt", unary_float_op sqrt)
; ("exp", unary_float_op exp)
; ("log", unary_float_op log)
; ("log10", unary_float_op log10)
; ("sin", unary_float_op sin)
; ("cos", unary_float_op cos)
; ("tan", unary_float_op tan)
; ("asin", unary_float_op asin)
; ("acos", unary_float_op acos)
; ("atan", unary_float_op atan)
; ("sinh", unary_float_op sinh)
; ("cosh", unary_float_op cosh)
; ("tanh", unary_float_op tanh)
; ("ceil", unary_float_op ceil)
; ("floor", unary_float_op floor)
]
Jump to Line
Something went wrong with that request. Please try again.