livescript/step9_try.ls

   1 readline = require './node_readline'
   2 {id, map, each, last, all, unique, zip, Obj, elem-index} = require 'prelude-ls'
   3 {read_str} = require './reader'
   4 {pr_str} = require './printer'
   5 {Env} = require './env'
   6 {runtime-error, ns, unpack-tco} = require './core'
   7 {list-to-pairs} = require './utils'
   8
   9
  10 defer-tco = (env, ast) ->
  11     type: \tco
  12     env: env
  13     ast: ast
  14     eval: -> eval_ast env, ast
  15
  16
  17 is-thruthy = ({type, value}) ->
  18     type != \const or value not in [\nil \false]
  19
  20
  21 fmap-ast = (fn, {type, value}: ast) -->
  22     {type: type, value: fn value}
  23
  24
  25 make-symbol = (name) -> {type: \symbol, value: name}
  26 make-list = (value) -> {type: \list, value: value}
  27 make-call = (name, params) -> make-list [make-symbol name] ++ params
  28 is-symbol = (ast, name) -> ast.type == \symbol and ast.value == name
  29
  30
  31 eval_simple = (env, {type, value}: ast) ->
  32     switch type
  33     | \symbol => env.get value
  34     | \list, \vector => ast |> fmap-ast map eval_ast env
  35     | \map => ast |> fmap-ast Obj.map eval_ast env
  36     | otherwise => ast
  37
  38
  39 eval_ast = (env, ast) -->
  40     loop
  41         if ast.type != \list
  42             return eval_simple env, ast
  43
  44         ast = macroexpand env, ast
  45         if ast.type != \list
  46             return eval_simple env, ast
  47         else if ast.value.length == 0
  48             return ast
  49
  50         result = if ast.value[0].type == \symbol
  51             params = ast.value[1 to]
  52             switch ast.value[0].value
  53             | 'def!'        => eval_def env, params
  54             | 'let*'        => eval_let env, params
  55             | 'do'          => eval_do env, params
  56             | 'if'          => eval_if env, params
  57             | 'fn*'         => eval_fn env, params
  58             | 'quote'       => eval_quote env, params
  59             | 'quasiquote'  => eval_quasiquote env, params
  60             | 'defmacro!'   => eval_defmacro env, params
  61             | 'macroexpand' => eval_macroexpand env, params
  62             | 'try*'        => eval_try env, params
  63             | otherwise     => eval_apply env, ast.value
  64         else
  65             eval_apply env, ast.value
  66
  67         if result.type == \tco
  68             {env, ast} = result
  69         else
  70             return result
  71
  72
  73 check_params = (name, params, expected) ->
  74     if params.length != expected
  75         runtime-error "'#{name}' expected #{expected} parameters,
  76                        got #{params.length}"
  77
  78
  79 eval_def = (env, params) ->
  80     check_params 'def!', params, 2
  81
  82     # Name is in the first parameter, and is not evaluated.
  83     name = params[0]
  84     if name.type != \symbol
  85         runtime-error "expected a symbol for the first parameter
  86                        of def!, got a #{name.type}"
  87
  88     # Evaluate the second parameter and store
  89     # it under name in the env.
  90     env.set name.value, (eval_ast env, params[1])
  91
  92
  93 eval_let = (env, params) ->
  94     check_params 'let*', params, 2
  95
  96     binding_list = params[0]
  97     if binding_list.type not in [\list \vector]
  98         runtime-error "expected 1st parameter of 'let*' to
  99                        be a binding list (or vector),
 100                        got a #{binding_list.type}"
 101     else if binding_list.value.length % 2 != 0
 102         runtime-error "binding list of 'let*' must have an even
 103                        number of parameters"
 104
 105     # Make a new environment with the
 106     # current environment as outer.
 107     let_env = new Env env
 108
 109     # Evaluate all binding values in the
 110     # new environment.
 111     binding_list.value
 112     |> list-to-pairs
 113     |> each ([binding_name, binding_value]) ->
 114         if binding_name.type != \symbol
 115             runtime-error "expected a symbol as binding name,
 116                            got a #{binding_name.type}"
 117
 118         let_env.set binding_name.value, (eval_ast let_env, binding_value)
 119
 120     # Defer evaluation of let* body with TCO.
 121     defer-tco let_env, params[1]
 122
 123
 124 eval_do = (env, params) ->
 125     if params.length == 0
 126         runtime-error "'do' expected at least one parameter"
 127
 128     [...rest, last-param] = params
 129     rest |> each eval_ast env
 130     defer-tco env, last-param
 131
 132
 133 eval_if = (env, params) ->
 134     if params.length < 2
 135         runtime-error "'if' expected at least 2 parameters"
 136     else if params.length > 3
 137         runtime-error "'if' expected at most 3 parameters"
 138
 139     cond = eval_ast env, params[0]
 140     if is-thruthy cond
 141         defer-tco env, params[1]
 142     else if params.length > 2
 143         defer-tco env, params[2]
 144     else
 145         {type: \const, value: \nil}
 146
 147
 148 eval_fn = (env, params) ->
 149     check_params 'fn*', params, 2
 150
 151     if params[0].type not in [\list \vector]
 152         runtime-error "'fn*' expected first parameter to be a list or vector."
 153
 154     if not all (.type == \symbol), params[0].value
 155         runtime-error "'fn*' expected only symbols in the parameters list."
 156
 157     binds = params[0].value |> map (.value)
 158     vargs = null
 159
 160     # Parse variadic bind.
 161     if binds.length >= 2
 162         [...rest, amper, name] = binds
 163         if amper == '&' and name != '&'
 164             binds = rest
 165             vargs = name
 166
 167     if elem-index '&', binds
 168         runtime-error "'fn*' invalid usage of variadic parameters."
 169
 170     if (unique binds).length != binds.length
 171         runtime-error "'fn*' duplicate symbols in parameters list."
 172
 173     body = params[1]
 174
 175     fn_instance = (...values) ->
 176         if not vargs and values.length != binds.length
 177             runtime-error "function expected #{binds.length} parameters,
 178                            got #{values.length}"
 179         else if vargs and values.length < binds.length
 180             runtime-error "function expected at least
 181                            #{binds.length} parameters,
 182                            got #{values.length}"
 183
 184         # Set binds to values in the new env.
 185         fn_env = new Env env
 186
 187         for [name, value] in (zip binds, values)
 188             fn_env.set name, value
 189
 190         if vargs
 191             fn_env.set vargs,
 192                 make-list values.slice binds.length
 193
 194         # Defer evaluation of the function body to TCO.
 195         defer-tco fn_env, body
 196
 197     {type: \function, value: fn_instance, is_macro: false}
 198
 199
 200 eval_apply = (env, list) ->
 201     [fn, ...args] = list |> map eval_ast env
 202     if fn.type != \function
 203         runtime-error "#{fn.value} is not a function, got a #{fn.type}"
 204
 205     fn.value.apply env, args
 206
 207
 208 eval_quote = (env, params) ->
 209     if params.length != 1
 210         runtime-error "quote expected 1 parameter, got #{params.length}"
 211
 212     params[0]
 213
 214
 215 is-pair = (ast) -> ast.type in [\list \vector] and ast.value.length != 0
 216
 217
 218 eval_quasiquote = (env, params) ->
 219     if params.length != 1
 220         runtime-error "quasiquote expected 1 parameter, got #{params.length}"
 221
 222     ast = params[0]
 223     new-ast = if not is-pair ast
 224         make-call 'quote', [ast]
 225     else if is-symbol ast.value[0], 'unquote'
 226         ast.value[1]
 227     else if is-pair ast.value[0] and \
 228             is-symbol ast.value[0].value[0], 'splice-unquote'
 229         make-call 'concat', [
 230             ast.value[0].value[1]
 231             make-call 'quasiquote', [make-list ast.value[1 to]]
 232         ]
 233     else
 234         make-call 'cons', [
 235             make-call 'quasiquote', [ast.value[0]]
 236             make-call 'quasiquote', [make-list ast.value[1 to]]
 237         ]
 238
 239     defer-tco env, new-ast
 240
 241
 242 eval_defmacro = (env, params) ->
 243     check_params 'def!', params, 2
 244
 245     # Name is in the first parameter, and is not evaluated.
 246     name = params[0]
 247     if name.type != \symbol
 248         runtime-error "expected a symbol for the first parameter
 249                        of defmacro!, got a #{name.type}"
 250
 251     # Evaluate the second parameter.
 252     fn = eval_ast env, params[1]
 253     if fn.type != \function
 254         runtime-error "expected a function for the second parameter
 255                        of defmacro!, got a #{fn.type}"
 256
 257     # Copy fn and mark the function as a macro.
 258     macro_fn = fn with is_macro: true
 259     env.set name.value, macro_fn
 260
 261
 262 get-macro-fn = (env, ast) ->
 263     if ast.type == \list and
 264             ast.value.length != 0 and
 265             ast.value[0].type == \symbol
 266         fn = env.try-get ast.value[0].value
 267         if fn and fn.type == \function and fn.is_macro
 268         then fn
 269
 270
 271 macroexpand = (env, ast) ->
 272     loop # until ast is not a macro function call.
 273         macro_fn = get-macro-fn env, ast
 274         if not macro_fn then return ast
 275         ast = unpack-tco <| macro_fn.value.apply env, ast.value[1 to]
 276
 277
 278 eval_macroexpand = (env, params) ->
 279     if params.length != 1
 280         runtime-error "'macroexpand' expected 1 parameter,
 281                        got #{params.length}"
 282
 283     macroexpand env, params[0]
 284
 285
 286 eval_try = (env, params) ->
 287     if params.length > 2
 288         runtime-error "'try*' expected 1 or 2 parameters,
 289                        got #{params.length}"
 290     try-form = params[0]
 291     if params.length == 1
 292         return eval_ast env, try-form
 293
 294     catch-clause = params[1]
 295     if catch-clause.type != \list or
 296             catch-clause.value.length != 3 or
 297             not (is-symbol catch-clause.value[0], 'catch*') or
 298             catch-clause.value[1].type != \symbol
 299         runtime-error "'try*' expected the second parameter to be
 300                        of the form (catch* A B)"
 301
 302     try
 303         eval_ast env, try-form
 304     catch error
 305         error-symbol = catch-clause.value[1].value
 306         error-value = \
 307             if error.message
 308             then {type: \string, value: error.message}
 309             else error
 310
 311         catch-env = new Env env
 312         catch-env.set error-symbol, error-value
 313         eval_ast catch-env, catch-clause.value[2]
 314
 315
 316 repl_env = new Env
 317 for symbol, value of ns
 318     repl_env.set symbol, value
 319
 320 # Evil eval.
 321 repl_env.set 'eval', do
 322     type: \function
 323     value: (ast) -> eval_ast repl_env, ast  # or use current env? (@ = this).
 324
 325 # Read, Evaluate, Print
 326 rep = (line) ->
 327     line
 328     |> read_str
 329     |> eval_ast repl_env
 330     |> (ast) -> pr_str ast, print_readably=true
 331
 332
 333 # Define not.
 334 rep '(def! not (fn* (x) (if x false true)))'
 335
 336 # Define load-file.
 337 rep '
 338 (def! load-file
 339   (fn* (f)
 340     (eval
 341       (read-string
 342         (str "(do " (slurp f) "\nnil)")))))'
 343
 344 # Define cond.
 345 rep '
 346 (defmacro! cond
 347   (fn* (& xs)
 348     (if (> (count xs) 0)
 349       (list \'if (first xs)
 350         (if (> (count xs) 1)
 351           (nth xs 1)
 352           (throw "odd number of forms to cond"))
 353         (cons \'cond (rest (rest xs)))))))'
 354
 355 # Parse program arguments.
 356 # The first two (exe and core-file) are, respectively,
 357 # the interpreter executable (nodejs or lsc) and the
 358 # source file being executed (stepX_*.(ls|js)).
 359 [exe, core-file, mal-file, ...argv] = process.argv
 360
 361 repl_env.set '*ARGV*', do
 362     type: \list
 363     value: argv |> map (arg) ->
 364         type: \string
 365         value: arg
 366
 367
 368 if mal-file
 369     rep "(load-file \"#{mal-file}\")"
 370 else
 371     # REPL.
 372     loop
 373         line = readline.readline 'user> '
 374         break if not line? or line == ''
 375         try
 376             console.log rep line
 377         catch error
 378             if error.message
 379             then console.error error.message
 380             else console.error "Error:", pr_str error, print_readably=true