languages/lazy-k/lazy.pir

   1 # $Id$
   2
   3 =head1 DESCRIPTION
   4
   5 This is a Lazy K interpreter - basically a rewrite of lazy.cpp in PIR.
   6 Lazy K is a pure functional programming language following the SKI calculus.
   7
   8 =head1 AUTHOR
   9
  10 leo
  11
  12 =head1 SEE ALSO
  13
  14 L<http://en.wikipedia.org/wiki/Lazy_K_programming_language>
  15
  16 =head1 TODO
  17
  18  - (S(K ...)) syntax
  19  - iota/Jot syntax
  20  - chained commandline args and -e, -b
  21
  22 And a lot of comments in the source - sorry.
  23
  24 =cut
  25
  26
  27 .sub _main :main
  28     .param pmc argv
  29
  30     .local int argc
  31     .local pmc in
  32
  33     # define constants for he various kinds of expressions
  34     .globalconst int expA   =  1
  35     .globalconst int expI   =  2
  36     .globalconst int expI1  =  3
  37     .globalconst int expK   =  4
  38     .globalconst int expK1  =  5
  39     .globalconst int expS   =  6
  40     .globalconst int expS1  =  7
  41     .globalconst int expS2  =  8
  42     .globalconst int expLR  =  9
  43     .globalconst int expInc = 10
  44     .globalconst int expNum = 11
  45
  46     argc = argv
  47     # TODO -e, chained arguments
  48     if argc > 1 goto open_file
  49     in = getstdin
  50     goto run
  51 open_file:
  52     $S0 = argv[1]
  53     in = open $S0, "<"
  54     $I0 = defined in
  55     if $I0 goto run
  56     printerr "can't open '"
  57     printerr $S0
  58     printerr "' for reading."
  59     exit 1
  60 run:
  61     .local pmc prog, e
  62
  63     create_globals()
  64     e = global "I"
  65     prog = parse(in)
  66     ## _dumper( prog, "prog" )
  67     e = append(e, prog)
  68
  69     .local pmc lr, NUL
  70     null NUL
  71     lr = new_expr(expLR, NUL, NUL)
  72     e = new_apply(e, lr)
  73     ## deparse_e(e)
  74     ## trace 15
  75
  76     # convert results from a list of church numbers to 8-bit chars
  77     # cchar >= 256 means exit = ccchar - 256
  78 loop:
  79     $P0 = car(e)
  80     $I0 = church2int($P0)
  81     if $I0 < 256 goto put
  82         exit $I0
  83 put:
  84     $S0 = chr $I0
  85     print $S0
  86     e = cdr(e)
  87     goto loop
  88 .end
  89
  90 # append expressions so that they are run in sequence
  91 .sub run_in_sequence
  92     .param pmc f
  93     .param pmc g
  94
  95     .local pmc k1f,  NUL
  96     null NUL
  97     k1f = new_expr(expK1, f, NUL)
  98
  99     .return  new_expr(expS2, k1f, g)
 100 .end
 101
 102 .sub append
 103     .param pmc old
 104     .param pmc n
 105
 106     .return run_in_sequence(n, old)
 107 .end
 108
 109 # convert expression (which sould be a churn numeral to a native int
 110 # this is done by evaluating lambda (n) (Inc n 0)
 111 .sub church2int
 112     .param pmc church
 113
 114     .local pmc e, Zero, Inc, result
 115     Inc = global "Inc"
 116     Zero = global "Zero"
 117     e = new_apply(church, Inc)
 118     e = new_apply(e, Zero)
 119     result = eval(e)
 120     $I0 = to_number(result)
 121     if $I0 == -1 goto err
 122         .return($I0)
 123 err:
 124     printerr "invalid output format - not a number\n"
 125     exit 3
 126 .end
 127
 128 # get head of list
 129 .sub car
 130     .param pmc list
 131     .local pmc k
 132     k = global "K"
 133     .return new_apply(list, k)
 134 .end
 135
 136 # get tail of list
 137 .sub cdr
 138     .param pmc list
 139     .local pmc ki
 140     ki = global "KI"
 141     .return new_apply(list, ki)
 142 .end
 143
 144 # create globals for commonly used expressions and
 145 # initialize the first 2 church numerals
 146 .sub create_globals
 147     .local pmc e, NUL, K, S, KS, I, KI
 148     null NUL
 149     K = new_expr(expK, NUL, NUL)
 150     global "K" = K
 151     S = new_expr(expS, NUL, NUL)
 152     global "S" = S
 153     I = new_expr(expI, NUL, NUL)
 154     global "I" = I
 155     KI = new_expr(expK1, I, NUL)
 156     global "KI" = KI
 157     e = new_expr(expS1, I, NUL)
 158     global "SI" = e
 159     KS = new_expr(expK1, S, NUL)
 160     global "KS" = KS
 161     e = new_expr(expK1, K, NUL)
 162     global "KK" = e
 163     e = new_expr(expS2, KS, K)
 164     global "SKSK" = e
 165     e = new_expr(expS2, I, KS)
 166     global "SIKS" = e
 167
 168     e = new_expr(expInc, NUL, NUL)
 169     global "Inc" = e
 170     $P0 = new 'Integer'
 171     e = new_expr(expNum, $P0, NUL)
 172     global "Zero" = e
 173
 174     .local pmc cache
 175     cache = new 'FixedPMCArray'
 176     cache = 257
 177     cache[0] = KI
 178     cache[1] = I
 179     global "church_cache" = cache
 180
 181 .end
 182
 183 # create a new expression of the given type
 184 .sub new_expr
 185     .param int type
 186     .param pmc lhs
 187     .param pmc rhs
 188
 189     .local pmc expr
 190     expr = new 'FixedPMCArray'
 191     expr = 3
 192     expr[0] = type
 193     expr[1] = lhs
 194     expr[2] = rhs
 195
 196     .return (expr)
 197 .end
 198
 199 # create a new apply expr
 200 .sub new_apply
 201     .param pmc lhs
 202     .param pmc rhs
 203
 204     .return new_expr(expA, lhs, rhs)
 205 .end
 206
 207 # parse from an IO handle
 208 # only 'ski currently
 209 .sub parse
 210     .param pmc io
 211
 212     .local string ch
 213     .local pmc op, arg, NUL
 214     .local pmc I, K, S
 215     I = global "I"
 216     K = global "K"
 217     S = global "S"
 218     null NUL
 219 loop:
 220     ch = read io, 1
 221     unless ch == '`' goto not_bq
 222         op = parse(io)
 223         arg = parse(io)
 224         .return new_apply(op, arg)
 225 not_bq:
 226     unless ch == 'i' goto not_i
 227         .return (I)
 228 not_i:
 229     unless ch == 'k' goto not_k
 230         .return (K)
 231 not_k:
 232     unless ch == 's' goto not_s
 233         .return (S)
 234 not_s:
 235     unless ch == '#' goto not_comment
 236     swallow:
 237         ch = read io, 1
 238         if ch != "\n" goto swallow
 239         goto loop
 240 not_comment:
 241     if ch == ' ' goto loop
 242     if ch == "\t" goto loop
 243     if ch == "\n" goto loop
 244     if ch == "\r" goto loop
 245     printerr "unrecogniced char in program '"
 246     printerr ch
 247     printerr "'\n"
 248     exit 1
 249 .end
 250
 251 # apply identy which just returns it's rhs
 252 # this can be done in a loop, if we have a sequence of I1
 253 .sub drop_i1
 254     .param pmc expr
 255     .local int type
 256 loop:
 257     type = expr[0]
 258     if type != expI1 goto ret_e
 259         expr = expr[1]
 260     goto loop
 261 ret_e:
 262     .return (expr)
 263 .end
 264
 265 # convert a native int to a church numeral expression
 266 # the first 2 are pregenerated, the next ones are created
 267 # recursively by prepending ``s``s`ksk
 268 # we could of course create short sequences with multiplication
 269 # and powers of n
 270 .sub int2church
 271     .param int i
 272
 273     .local pmc cached, e
 274     cached = global "church_cache"
 275     if i < 0 goto i256
 276     if i > 256 goto i256
 277     goto ok
 278 i256:
 279     i = 256
 280 ok:
 281     e = cached[i]
 282     unless_null e,  ret
 283         .local pmc sksk, e, cm1
 284         sksk = global "SKSK"
 285         $I0 = i - 1
 286         cm1 = int2church($I0)
 287         e = new_expr(expS2, sksk, cm1)
 288         cached[i] = e
 289 ret:
 290     .return (e)
 291 .end
 292
 293 # return native integer of a Num expression or -1 on error
 294 .sub to_number
 295     .param pmc expr
 296     .local pmc arg1
 297     .local int type
 298     type = expr[0]
 299     if type != expNum goto ret1
 300     $P0 = expr[1]
 301     $I0 = $P0
 302     .return ($I0)
 303 ret1:
 304     .return (-1)
 305 .end
 306
 307 # apply (f g)
 308 # this works inplace using the fact of referential integrity of Lazy-k
 309 .sub apply
 310     .param pmc expr
 311
 312     .local pmc lhs, rhs, arg1, arg2, NUL
 313     .local int type
 314     arg1 = expr[1]
 315     arg2 = expr[2]
 316     lhs = arg1
 317     rhs = drop_i1(arg2)
 318     null NUL
 319     type = lhs[0]
 320     unless type == expK goto not_k
 321         expr[0] = expK1
 322         expr[1] = rhs
 323         expr[2] = NUL
 324         .return()
 325 not_k:
 326     unless type == expK1 goto not_k1
 327         expr[0] = expI1
 328         $P0 = lhs[1]
 329         expr[1] = $P0
 330         expr[2] = NUL
 331         .return()
 332 not_k1:
 333     unless type == expI goto not_i
 334         expr[0] = expI1
 335         expr[1] = rhs
 336         expr[2] = NUL
 337         .return()
 338 not_i:
 339     unless type == expS goto not_s
 340         expr[0] = expS1
 341         expr[1] = rhs
 342         expr[2] = NUL
 343         .return()
 344 not_s:
 345     unless type == expS1 goto not_s1
 346         expr[0] = expS2
 347         $P0 = lhs[1]
 348         expr[1] = $P0
 349         expr[2] = rhs
 350         .return()
 351 not_s1:
 352     unless type == expLR goto not_lr
 353         lhs[0] = expS2
 354         .local pmc cc, k1c, s2ik1, i, io
 355         .local string s
 356         io = getstdin
 357         $I0 = 256
 358         unless io goto eof
 359         s = read io, 1
 360         if s == '' goto eof
 361         $I0 = ord s
 362     eof:
 363         cc = int2church($I0)
 364         i = global "I"
 365         k1c = new_expr(expK1, cc, NUL)
 366         s2ik1 = new_expr(expS2, i, k1c)
 367         lhs[1] = s2ik1
 368         $P0 = new_expr(expLR, NUL, NUL)
 369         $P1 = new_expr(expK1, $P0, NUL)
 370         lhs[2] = $P1
 371         goto s2
 372 not_lr:
 373     unless type == expS2 goto not_s2
 374 s2:
 375         ## expr[0] = expA
 376         $P0 = lhs[1]
 377         $P1     = new_apply( $P0, rhs)
 378         expr[1] = $P1
 379         $P0 = lhs[2]
 380         $P2     = new_apply( $P0, rhs)
 381         expr[2] = $P2
 382         .return()
 383 not_s2:
 384     unless type == expInc goto not_inc
 385         rhs = eval(rhs)
 386         $I0 = to_number(rhs)
 387         inc $I0
 388         if $I0 goto num_ok
 389             printerr "invalid Inc of non-number\n"
 390             exit 1
 391 num_ok:
 392         $P0 = new 'Integer'
 393         $P0 = $I0
 394         expr[0] = expNum
 395         expr[1] = $P0
 396         expr[2] = NUL
 397         .return()
 398 not_inc:
 399     unless type == expNum goto not_num
 400         printerr "invalid apply of number\n"
 401         exit 1
 402 not_num:
 403     printerr "unknown expression: '"
 404     printerr type
 405     printerr "'\n"
 406     exit 1
 407     .return()
 408 .end
 409
 410 # evaluate expression
 411 # this works inplace using the fact of referential integrity of Lazy-k
 412 .sub eval
 413     .param pmc expr
 414     .local pmc cur, arg1, next, prev, NUL
 415     .local int type
 416     ##deparse_e(expr)
 417     cur = expr
 418     null prev
 419     null NUL
 420 loop:
 421     cur = drop_i1(cur)
 422 lpa:
 423     type = cur[0]
 424     if type != expA goto not_a
 425         next = cur[1]
 426         next = drop_i1(next)
 427         cur[1] = prev
 428         prev = cur
 429         cur = next
 430         goto lpa
 431 not_a:
 432     unless_null prev, isnt_nul
 433         .return (cur)
 434 isnt_nul:
 435     next = cur
 436     cur = prev
 437     prev = cur[1]
 438     cur[1] = next
 439     apply(cur)
 440     goto loop
 441     .return (NUL)
 442 .end
 443
 444 # debug helper - print string rep of expr
 445 .sub deparse
 446     .param pmc expr
 447     .local pmc arg1, arg2
 448     .local int type
 449     type = expr[0]
 450     unless type == expA goto not_a
 451         print "("
 452         arg1 = expr[1]
 453         deparse(arg1)
 454         print " "
 455         arg2 = expr[2]
 456         deparse(arg2)
 457         print ")"
 458         .return()
 459 not_a:
 460     unless type == expK goto not_k
 461         print "K"
 462         .return()
 463 not_k:
 464     unless type == expI goto not_i
 465         print "I"
 466         .return()
 467 not_i:
 468     unless type == expK1 goto not_k1
 469         print "[K"
 470         arg1 = expr[1]
 471         deparse(arg1)
 472         print "]"
 473         .return()
 474 not_k1:
 475     unless type == expI1 goto not_i1
 476         print "[I"
 477         arg1 = expr[1]
 478         deparse(arg1)
 479         print "]"
 480         .return()
 481 not_i1:
 482     unless type == expS goto not_s
 483         print "S"
 484         .return()
 485 not_s:
 486     unless type == expS1 goto not_s1
 487         print "[S"
 488         arg1 = expr[1]
 489         deparse(arg1)
 490         print "]"
 491         .return()
 492
 493 not_s1:
 494     unless type == expS2 goto not_s2
 495         print "[s"
 496         arg1 = expr[1]
 497         deparse(arg1)
 498         print " "
 499         arg2 = expr[2]
 500         deparse(arg2)
 501         print "]"
 502         .return()
 503 not_s2:
 504     unless type == expLR goto not_lr
 505         print "R"
 506         .return()
 507 not_lr:
 508     unless type == expInc goto not_inc
 509         print "I"
 510         .return()
 511 not_inc:
 512     unless type == expNum goto not_num
 513         $I0 = expr[1]
 514         print $I0
 515         .return()
 516 not_num:
 517     printerr "unknown expression: '"
 518     printerr type
 519     printerr "'\n"
 520     exit 1
 521     .return()
 522 .end
 523
 524 # debug print string rep of expr
 525 .sub deparse_e
 526     .param pmc expr
 527     deparse(expr)
 528     print "\n"
 529 .end
 530
 531 .include "library/dumper.pir"
 532
 533 # Local Variables:
 534 #   mode: pir
 535 #   fill-column: 100
 536 # End:
 537 # vim: expandtab shiftwidth=4 ft=pir: