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