2 people like it.

Mini SNOBOL Interpreter

Minimal SNOBOL abstract syntax tree (AST), interpreter and internal DSL (but no parser), just enough to run some simple samples from Wikipedia's SNOBOL page: http://en.wikipedia.org/wiki/SNOBOL and most of the pattern matching examples from the SNOBOL 4 Tutorial http://www.snobol4.org/docs/burks/tutorial/ch4.htm

Abstract Syntax Tree

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
type value = String of string | Integer of int
type label = string
type name = string
type arithmetic = Add | Subtract | Multiply | Divide | Power
type expression = 
   | Literal of value
   | Variable of name
   | Concat of expression list
   | Arithmetic of expression * arithmetic * expression
   | Len of int 
type transferOn = Success | Failure | Any
type transfer = { On:transferOn; Goto:label }
type command =
   | Assign of name * expression
   | Match of expression * expression
   | Unit
type line = {
    Label : label option
    Command : command
    Transfer : transfer option
    }

Interpereter

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
53: 
54: 
55: 
56: 
57: 
58: 
59: 
60: 
61: 
62: 
63: 
64: 
65: 
let toString = function | String s -> s | Integer n -> n.ToString()
let variables = System.Collections.Generic.Dictionary<name, value>()
let (|AsInteger|_|) s =
   match System.Int32.TryParse(s) with
   | true, n -> Some n
   | false, _ -> None
let run input output (lines:line list) =
   let rec evaluate expression =      
      match expression with
      | Literal(value) -> value
      | Variable("INPUT") -> input () |> String
      | Variable(subject) -> variables.[subject]
      | Concat(expressions) ->
         System.String.Concat([for e in expressions -> evaluate e |> toString])
         |> String
      | Arithmetic(lhs,op,rhs) ->
         match evaluate lhs, evaluate rhs with
         | Integer l, Integer r -> Integer(arithmetic op l r)
         | Integer l, String (AsInteger r) -> Integer(arithmetic op l r)
         | _ -> invalidOp "Illegal data type"
      | Len(n) -> invalidOp ""
   and arithmetic op l r =
      match op with
      | Add -> l + r
      | Subtract -> l - r
      | Multiply -> l * r
      | Divide -> l / r
      | Power -> pown l r
   let rec nextLine i =
      let line = lines.[i]
      let result =
         match line.Command with
         | Assign("OUTPUT", expression) ->
            evaluate expression |> toString |> output
            true
         | Assign(subject, expression) ->
            let value = evaluate expression
            variables.[subject] <- value
            true
         | Match(subject, Len(count)) ->
            let s = evaluate subject |> toString
            s.Length >= count
         | Match(subject, pattern) ->
            match evaluate subject, evaluate pattern with
            | String subject, String pattern -> subject.Contains pattern
            | Integer subject, Integer pattern -> subject = pattern
            | _, _ -> invalidOp ""
         | Unit -> true  
      match line.Transfer with
      | None -> 
         if i < lines.Length-1 then nextLine (i+1)
      | Some(transfer) ->
         let j = 
            lines 
            |> List.findIndex (fun line -> 
                  match line.Label with 
                  | Some label -> label = transfer.Goto 
                  | None -> false)                        
         match transfer.On, result with
         | Success, true -> nextLine j
         | Failure, false -> nextLine j
         | Any, _ -> nextLine j
         | _ when i < lines.Length-1 -> nextLine (i+1)
         | _ -> ()         
   nextLine 0

Hello World

1: 
2: 
3: 
4: 
5: 
6: 
7: 
8: 
(*
          OUTPUT = "Hello world"
*)
let input () = ""
let output = printfn "%s"
[{Label=None; Command=Assign("OUTPUT",Literal(String("Hello World")));Transfer=None}]
|> run input output
// > Hello World

Input

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
(*
          OUTPUT = "What is your name?"
          Username = INPUT
          OUTPUT = "Thank you, " Username
*)
[{Label=None; Command=Assign("OUTPUT",Literal(String("What is your name?")));Transfer=None}
 {Label=None; Command=Assign("Username",Variable("INPUT"));Transfer=None}
 {Label=None; Command=Assign("OUTPUT",Concat [Literal(String("Thank you, "));Variable("Username")]);
                                      Transfer=None}]
|> run (fun () -> "Doctor") output
// > What is your name?
// > Thank you, Doctor

Control flow

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
(*
          OUTPUT = "What is your name?"
          Username = INPUT
          Username "Jay"                                           :S(LOVE)
          Username "Kay"                                           :S(HATE)
MEH       OUTPUT = "Hi, " Username                                 :(END)
LOVE      OUTPUT = "How nice to meet you, " Username               :(END)
HATE      OUTPUT = "Oh. It's you, " Username
END
*)
let program =
   [
   {Label=None; Command=Assign("OUTPUT",Literal(String("What is your name?")));Transfer=None}
   {Label=None; Command=Assign("Username",Variable("INPUT"));Transfer=None}
   {Label=None; Command=Match(Variable("Username"),Literal(String "J"));
                Transfer=Some {On=Success;Goto="LOVE"}}
   {Label=None; Command=Match(Variable("Username"),Literal(String "K"));
                Transfer=Some {On=Success;Goto="HATE"}}
   {Label=Some "MEH"; 
    Command=Assign("OUTPUT",Concat [Literal(String "Hi, ");Variable("Username")]);
    Transfer=Some {On=Success;Goto="END"}}
   {Label=Some "LOVE"; 
    Command=Assign("OUTPUT",Concat [Literal(String "How nice to meet you, ");Variable("Username")]);
    Transfer=Some {On=Success;Goto="END"}}
   {Label=Some "HATE"; 
    Command=Assign("OUTPUT",Concat [Literal(String "Oh. It's you, ");Variable("Username")]);
    Transfer=Some {On=Success;Goto="END"}}
   {Label=Some "END"; Command=Unit;Transfer=None}
   ]

program |> run (fun () -> "Jay") output
// > What is your name?
// > How nice to meet you, Jay
program |> run (fun () -> "Kay") output
// > What is your name?
// > Oh. It's you, Kay
program |> run (fun () -> "Bob") output
// > What is your name?
// > Hi, Bob

Input Loop

 1: 
 2: 
 3: 
 4: 
 5: 
 6: 
 7: 
 8: 
 9: 
10: 
11: 
12: 
13: 
14: 
15: 
16: 
17: 
18: 
19: 
20: 
21: 
22: 
23: 
24: 
25: 
26: 
27: 
28: 
29: 
30: 
31: 
32: 
33: 
34: 
35: 
36: 
37: 
38: 
39: 
40: 
41: 
42: 
43: 
44: 
45: 
46: 
47: 
48: 
49: 
50: 
51: 
52: 
(*
          OUTPUT = "This program will ask you for personal names"
          OUTPUT = "until you press return without giving it one"
          NameCount = 0                                            :(GETINPUT)
AGAIN     NameCount = NameCount + 1
          OUTPUT = "Name " NameCount ": " PersonalName
GETINPUT  OUTPUT = "Please give me name " NameCount + 1 
          PersonalName = INPUT
          PersonalName LEN(1)                                      :S(AGAIN)
          OUTPUT = "Finished. " NameCount " names requested."
END
*)

let loop =
   [
   {Label=None; 
    Command=Assign("OUTPUT",Literal(String("This program will ask you for personal names")));
    Transfer=None}
   {Label=None; 
    Command=Assign("OUTPUT",Literal(String("until you press return without giving it one")));
    Transfer=None}
   {Label=None; 
    Command=Assign("NameCount",Literal(Integer(0)));
    Transfer=Some {On=Any;Goto="GETINPUT"}}
   {Label=Some "AGAIN"; 
    Command=Assign("NameCount",Arithmetic(Variable("NameCount"),Add,Literal(Integer(1))));
    Transfer=None}
   {Label=None; 
    Command=Assign("OUTPUT",Concat [Literal(String("Name ")); Variable("NameCount");
                                    Literal(String(": "));Variable("PersonalName")]);
    Transfer=None}      
   {Label=Some "GETINPUT"; Command=Assign("PersonalName",Variable("INPUT")); Transfer=None}
   {Label=None; 
    Command=Match(Variable("PersonalName"),Len(1)); 
    Transfer=Some {On=Success;Goto="AGAIN"}}
   {Label=None; 
    Command=Assign("OUTPUT", Concat [Literal(String("Finished. ")); Variable("NameCount");
                                     Literal(String(" names requested."))])
    Transfer=None}
   ]

let names =
   let names = seq ["Billy"; "Bob"; "Thornton"]
   let e = names.GetEnumerator()
   fun () -> if e.MoveNext() then e.Current else ""
loop |> run names output
// > This program will ask you for personal names
// > until you press return without giving it one
// > Name 1: Billy
// > Name 2: Bob
// > Name 3: Thornton
// > Finished. 3 names requested.
Multiple items
union case value.String: string -> value

--------------------
module String

from Microsoft.FSharp.Core
Multiple items
val string : value:'T -> string

Full name: Microsoft.FSharp.Core.Operators.string

--------------------
type string = System.String

Full name: Microsoft.FSharp.Core.string
union case value.Integer: int -> value
Multiple items
val int : value:'T -> int (requires member op_Explicit)

Full name: Microsoft.FSharp.Core.Operators.int

--------------------
type int = int32

Full name: Microsoft.FSharp.Core.int

--------------------
type int<'Measure> = int

Full name: Microsoft.FSharp.Core.int<_>
type label = string

Full name: Script.label
type name = string

Full name: Script.name
type arithmetic =
  | Add
  | Subtract
  | Multiply
  | Divide
  | Power

Full name: Script.arithmetic
union case arithmetic.Add: arithmetic
union case arithmetic.Subtract: arithmetic
union case arithmetic.Multiply: arithmetic
union case arithmetic.Divide: arithmetic
union case arithmetic.Power: arithmetic
type expression =
  | Literal of value
  | Variable of name
  | Concat of expression list
  | Arithmetic of expression * arithmetic * expression
  | Len of int

Full name: Script.expression
Multiple items
union case expression.Literal: value -> expression

--------------------
type LiteralAttribute =
  inherit Attribute
  new : unit -> LiteralAttribute

Full name: Microsoft.FSharp.Core.LiteralAttribute

--------------------
new : unit -> LiteralAttribute
type value =
  | String of string
  | Integer of int

Full name: Script.value
union case expression.Variable: name -> expression
union case expression.Concat: expression list -> expression
type 'T list = List<'T>

Full name: Microsoft.FSharp.Collections.list<_>
union case expression.Arithmetic: expression * arithmetic * expression -> expression
union case expression.Len: int -> expression
type transferOn =
  | Success
  | Failure
  | Any

Full name: Script.transferOn
union case transferOn.Success: transferOn
Multiple items
union case transferOn.Failure: transferOn

--------------------
active recognizer Failure: exn -> string option

Full name: Microsoft.FSharp.Core.Operators.( |Failure|_| )
union case transferOn.Any: transferOn
type transfer =
  {On: transferOn;
   Goto: label;}

Full name: Script.transfer
transfer.On: transferOn
transfer.Goto: label
type command =
  | Assign of name * expression
  | Match of expression * expression
  | Unit

Full name: Script.command
union case command.Assign: name * expression -> command
union case command.Match: expression * expression -> command
union case command.Unit: command
type line =
  {Label: label option;
   Command: command;
   Transfer: transfer option;}

Full name: Script.line
line.Label: label option
type 'T option = Option<'T>

Full name: Microsoft.FSharp.Core.option<_>
line.Command: command
line.Transfer: transfer option
val toString : _arg1:value -> string

Full name: Script.toString
val s : string
val n : int
System.Int32.ToString() : string
System.Int32.ToString(provider: System.IFormatProvider) : string
System.Int32.ToString(format: string) : string
System.Int32.ToString(format: string, provider: System.IFormatProvider) : string
val variables : System.Collections.Generic.Dictionary<name,value>

Full name: Script.variables
namespace System
namespace System.Collections
namespace System.Collections.Generic
Multiple items
type Dictionary<'TKey,'TValue> =
  new : unit -> Dictionary<'TKey, 'TValue> + 5 overloads
  member Add : key:'TKey * value:'TValue -> unit
  member Clear : unit -> unit
  member Comparer : IEqualityComparer<'TKey>
  member ContainsKey : key:'TKey -> bool
  member ContainsValue : value:'TValue -> bool
  member Count : int
  member GetEnumerator : unit -> Enumerator<'TKey, 'TValue>
  member GetObjectData : info:SerializationInfo * context:StreamingContext -> unit
  member Item : 'TKey -> 'TValue with get, set
  ...
  nested type Enumerator
  nested type KeyCollection
  nested type ValueCollection

Full name: System.Collections.Generic.Dictionary<_,_>

--------------------
System.Collections.Generic.Dictionary() : unit
System.Collections.Generic.Dictionary(capacity: int) : unit
System.Collections.Generic.Dictionary(comparer: System.Collections.Generic.IEqualityComparer<'TKey>) : unit
System.Collections.Generic.Dictionary(dictionary: System.Collections.Generic.IDictionary<'TKey,'TValue>) : unit
System.Collections.Generic.Dictionary(capacity: int, comparer: System.Collections.Generic.IEqualityComparer<'TKey>) : unit
System.Collections.Generic.Dictionary(dictionary: System.Collections.Generic.IDictionary<'TKey,'TValue>, comparer: System.Collections.Generic.IEqualityComparer<'TKey>) : unit
type Int32 =
  struct
    member CompareTo : value:obj -> int + 1 overload
    member Equals : obj:obj -> bool + 1 overload
    member GetHashCode : unit -> int
    member GetTypeCode : unit -> TypeCode
    member ToString : unit -> string + 3 overloads
    static val MaxValue : int
    static val MinValue : int
    static member Parse : s:string -> int + 3 overloads
    static member TryParse : s:string * result:int -> bool + 1 overload
  end

Full name: System.Int32
System.Int32.TryParse(s: string, result: byref<int>) : bool
System.Int32.TryParse(s: string, style: System.Globalization.NumberStyles, provider: System.IFormatProvider, result: byref<int>) : bool
union case Option.Some: Value: 'T -> Option<'T>
union case Option.None: Option<'T>
val run : input:(unit -> string) -> output:(string -> unit) -> lines:line list -> unit

Full name: Script.run
val input : (unit -> string)
val output : (string -> unit)
val lines : line list
val evaluate : (expression -> value)
Multiple items
val expression : expression

--------------------
type expression =
  | Literal of value
  | Variable of name
  | Concat of expression list
  | Arithmetic of expression * arithmetic * expression
  | Len of int

Full name: Script.expression
Multiple items
val value : value

--------------------
type value =
  | String of string
  | Integer of int

Full name: Script.value
val subject : name
val expressions : expression list
Multiple items
type String =
  new : value:char -> string + 7 overloads
  member Chars : int -> char
  member Clone : unit -> obj
  member CompareTo : value:obj -> int + 1 overload
  member Contains : value:string -> bool
  member CopyTo : sourceIndex:int * destination:char[] * destinationIndex:int * count:int -> unit
  member EndsWith : value:string -> bool + 2 overloads
  member Equals : obj:obj -> bool + 2 overloads
  member GetEnumerator : unit -> CharEnumerator
  member GetHashCode : unit -> int
  ...

Full name: System.String

--------------------
System.String(value: nativeptr<char>) : unit
System.String(value: nativeptr<sbyte>) : unit
System.String(value: char []) : unit
System.String(c: char, count: int) : unit
System.String(value: nativeptr<char>, startIndex: int, length: int) : unit
System.String(value: nativeptr<sbyte>, startIndex: int, length: int) : unit
System.String(value: char [], startIndex: int, length: int) : unit
System.String(value: nativeptr<sbyte>, startIndex: int, length: int, enc: System.Text.Encoding) : unit
System.String.Concat([<System.ParamArray>] values: string []) : string
   (+0 other overloads)
System.String.Concat(values: System.Collections.Generic.IEnumerable<string>) : string
   (+0 other overloads)
System.String.Concat<'T>(values: System.Collections.Generic.IEnumerable<'T>) : string
   (+0 other overloads)
System.String.Concat([<System.ParamArray>] args: obj []) : string
   (+0 other overloads)
System.String.Concat(arg0: obj) : string
   (+0 other overloads)
System.String.Concat(str0: string, str1: string) : string
   (+0 other overloads)
System.String.Concat(arg0: obj, arg1: obj) : string
   (+0 other overloads)
System.String.Concat(str0: string, str1: string, str2: string) : string
   (+0 other overloads)
System.String.Concat(arg0: obj, arg1: obj, arg2: obj) : string
   (+0 other overloads)
System.String.Concat(str0: string, str1: string, str2: string, str3: string) : string
   (+0 other overloads)
val e : expression
val lhs : expression
val op : arithmetic
val rhs : expression
val l : int
val r : int
Multiple items
val arithmetic : (arithmetic -> int -> int -> int)

--------------------
type arithmetic =
  | Add
  | Subtract
  | Multiply
  | Divide
  | Power

Full name: Script.arithmetic
active recognizer AsInteger: string -> int option

Full name: Script.( |AsInteger|_| )
val invalidOp : message:string -> 'T

Full name: Microsoft.FSharp.Core.Operators.invalidOp
val pown : x:'T -> n:int -> 'T (requires member get_One and member ( * ) and member ( / ))

Full name: Microsoft.FSharp.Core.Operators.pown
val nextLine : (int -> unit)
val i : int
Multiple items
val line : line

--------------------
type line =
  {Label: label option;
   Command: command;
   Transfer: transfer option;}

Full name: Script.line
val result : bool
val subject : expression
val count : int
property System.String.Length: int
val pattern : expression
val subject : string
val pattern : string
val subject : int
val pattern : int
property List.Length: int
Multiple items
val transfer : transfer

--------------------
type transfer =
  {On: transferOn;
   Goto: label;}

Full name: Script.transfer
val j : int
Multiple items
module List

from Microsoft.FSharp.Collections

--------------------
type List<'T> =
  | ( [] )
  | ( :: ) of Head: 'T * Tail: 'T list
  interface IEnumerable
  interface IEnumerable<'T>
  member Head : 'T
  member IsEmpty : bool
  member Item : index:int -> 'T with get
  member Length : int
  member Tail : 'T list
  static member Cons : head:'T * tail:'T list -> 'T list
  static member Empty : 'T list

Full name: Microsoft.FSharp.Collections.List<_>
val findIndex : predicate:('T -> bool) -> list:'T list -> int

Full name: Microsoft.FSharp.Collections.List.findIndex
Multiple items
val label : label

--------------------
type label = string

Full name: Script.label
union case transferOn.Failure: transferOn
val input : unit -> string

Full name: Script.input
val output : (string -> unit)

Full name: Script.output
val printfn : format:Printf.TextWriterFormat<'T> -> 'T

Full name: Microsoft.FSharp.Core.ExtraTopLevelOperators.printfn
val program : line list

Full name: Script.program
val loop : line list

Full name: Script.loop
val names : (unit -> string)

Full name: Script.names
val names : seq<string>
Multiple items
val seq : sequence:seq<'T> -> seq<'T>

Full name: Microsoft.FSharp.Core.Operators.seq

--------------------
type seq<'T> = System.Collections.Generic.IEnumerable<'T>

Full name: Microsoft.FSharp.Collections.seq<_>
val e : System.Collections.Generic.IEnumerator<string>
System.Collections.Generic.IEnumerable.GetEnumerator() : System.Collections.Generic.IEnumerator<string>
System.Collections.IEnumerator.MoveNext() : bool
property System.Collections.Generic.IEnumerator.Current: string

More information

Link:http://fssnip.net/oV
Posted:10 years ago
Author:Phillip Trelford
Tags: snobol , language , ast , interpreter