├── .gitignore ├── .travis.yml ├── LICENSE.txt ├── Makefile ├── README.md ├── demo ├── 99bottles.scm ├── bignum.scm ├── brainfuck.scm ├── c1.scm ├── cf.scm ├── cps.scm ├── frb.scm ├── genpi.scm ├── hello.scm ├── kqueue.scm ├── maze │ ├── ascii.scm │ ├── gen.scm │ ├── js.scm │ ├── maze.scm │ ├── solve.scm │ ├── svg.scm │ └── svg2.scm ├── parse │ ├── README.md │ ├── antlr2irken │ │ └── antlr2irken.scm │ ├── antlr2sexp.scm │ ├── irken-lex.sg │ ├── json.scm │ ├── json.sg │ ├── lex2dot.scm │ ├── lexfile.scm │ ├── lexgen.scm │ ├── meta-lex.sg │ ├── meta.sg │ ├── parsetool.scm │ ├── sexp-lex.sg │ ├── sexp.sg │ └── synlight.scm ├── repl │ ├── .gitignore │ ├── README.md │ └── repl.scm ├── rsa.scm └── sha256.scm ├── docs ├── README.md ├── datatypes.md ├── install.md ├── intro.md ├── lib │ ├── README.md │ ├── core.md │ └── derived.md └── types.md ├── doom ├── API.md ├── README ├── dns.scm ├── doom.scm ├── echo.scm ├── fetch.scm ├── http │ ├── h2.scm │ ├── hpack.scm │ ├── html.scm │ └── websocket.scm ├── kqueue.scm ├── s2n.scm ├── scheduler.scm ├── socket.scm ├── sync.scm ├── test │ └── t_websocket.scm ├── timeq.scm └── tls │ ├── codec.scm │ ├── datatypes.scm │ ├── kex.scm │ ├── keysched.scm │ ├── signer.scm │ └── tls13.scm ├── ffi ├── README.md ├── brotli.ffi ├── decaf.ffi ├── dl.ffi ├── gen │ ├── README.md │ ├── c-lex.sg │ ├── c11-lex.sg │ ├── cgram.scm │ ├── clextab.scm │ ├── cparse.scm │ ├── ctype.scm │ ├── genffi.byc │ └── genffi.scm ├── kqueue.ffi ├── libc.ffi ├── libc_ffi.scm ├── posix.ffi ├── s2n.ffi ├── s2n.scm ├── socket.ffi ├── sodium.ffi ├── stdio.ffi ├── stdio_ffi.scm ├── tests │ ├── socktest.scm │ ├── t_halloc.scm │ ├── t_set_int.scm │ ├── t_stdio.scm │ └── timetest.scm ├── uname.ffi └── zlib.ffi ├── include ├── gc1.c ├── header1.c ├── irken.h ├── preamble.ll └── rdtsc.h ├── irken.el ├── irken.svg ├── lang.html ├── lang ├── 0.scm ├── 1.scm ├── 2.scm ├── 3.scm ├── 4.scm └── 5.scm ├── lib ├── aa_map.scm ├── alist.scm ├── asn1 │ └── ber.scm ├── basis.scm ├── cmap.scm ├── codecs │ ├── base64.scm │ ├── base85.scm │ ├── brotli.scm │ ├── hex.scm │ └── zlib.scm ├── combinatorics.scm ├── core.scm ├── counter.scm ├── crypto │ ├── ctbig.scm │ ├── decaf.scm │ ├── dh.scm │ ├── hkdf.scm │ ├── hmac.scm │ ├── pem.scm │ ├── sha1.scm │ ├── sig.scm │ ├── sodium.scm │ └── x509.scm ├── ctype.scm ├── derived.scm ├── dfa │ ├── README.md │ ├── charset.scm │ ├── deriv.scm │ ├── dfa.scm │ ├── emit.scm │ ├── lexicon.scm │ └── rx.scm ├── dl.scm ├── enum.scm ├── exception.scm ├── format.scm ├── frb.scm ├── getopt.scm ├── graph.scm ├── io.scm ├── json.scm ├── libffi.scm ├── lisp_reader.scm ├── malloc.scm ├── map.scm ├── metadata.scm ├── mtwist.scm ├── net │ └── socket.scm ├── os.scm ├── pack.scm ├── pair.scm ├── parse │ ├── earley.scm │ ├── glextab.scm │ ├── gparser.scm │ ├── lexer.scm │ └── parser.scm ├── partial.scm ├── posix.scm ├── queue.scm ├── random.scm ├── reflection.scm ├── rope.scm ├── set.scm ├── sexp.scm ├── stack.scm ├── stack2.scm ├── stdio.scm ├── string.scm ├── symbol.scm ├── time.scm ├── urandom.scm └── vmffi.scm ├── notes ├── classes.txt ├── constants.txt ├── ctypes.txt ├── inline.txt ├── introspection.txt ├── literals.txt ├── literals2.txt ├── log.txt ├── metadata.txt ├── pll.txt ├── primops.txt ├── pxll.txt ├── recursive.txt ├── rows.txt ├── self-hosting.txt ├── serialization.txt ├── thoughts.txt ├── typeargs.txt ├── typing.txt └── vm.txt ├── self ├── HACKING.txt ├── analyze.scm ├── autoffi.scm ├── backend.scm ├── bootstrap.byc ├── bytecode.scm ├── byteops.scm ├── c.scm ├── compile.scm ├── context.scm ├── cps.scm ├── flags.scm ├── graph.scm ├── irkenb.scm ├── llvm.scm ├── match.scm ├── mbe.scm ├── nodes.scm ├── transform.scm ├── types.scm └── typing.scm ├── tests ├── dfa │ ├── t_charset.scm │ ├── t_deriv.scm │ ├── t_dfa.scm │ └── t_rx.scm ├── f0.scm ├── f1.scm ├── f2.scm ├── f3.scm ├── f4.scm ├── f_anno1.scm ├── f_anno2.scm ├── f_arity.scm ├── f_datatype.scm ├── f_datatype0.scm ├── f_datatype6.scm ├── f_gen1.scm ├── f_letpoly.scm ├── f_letpoly0.scm ├── f_match5.scm ├── f_match6.scm ├── f_overexhaustive.scm ├── f_value_rest.scm ├── llvm │ ├── t_ll0.scm │ ├── t_ll1.scm │ ├── t_ll2.scm │ ├── t_ll3.scm │ ├── t_ll4.scm │ ├── t_ll5.scm │ ├── t_ll6.scm │ ├── t_ll7.scm │ ├── t_ll8.scm │ ├── t_ll9.scm │ ├── t_lla.scm │ ├── t_llb.scm │ ├── t_llc.scm │ ├── t_lld.scm │ ├── t_lle.scm │ ├── t_llf.scm │ ├── t_llg.scm │ ├── t_llh.scm │ ├── t_lli.scm │ ├── t_llj.scm │ ├── t_llk.scm │ ├── t_lll.scm │ ├── t_llm.scm │ ├── t_lln.scm │ ├── t_llo.scm │ ├── t_llp.scm │ ├── t_llq.scm │ ├── t_llr.scm │ ├── t_lls.scm │ ├── t_llt.scm │ ├── t_llu.scm │ ├── t_llv.scm │ ├── t_llw.scm │ └── tak20-llvm.scm ├── manboy.exp ├── manboy.scm ├── parse │ ├── t_earley.exp │ └── t_earley.scm ├── parse_0.py ├── parse_2.py ├── t0.exp ├── t0.scm ├── t1.exp ├── t1.scm ├── t10.exp ├── t10.scm ├── t11.exp ├── t11.scm ├── t12.exp ├── t12.scm ├── t13.exp ├── t13.scm ├── t14.exp ├── t14.scm ├── t15.exp ├── t15.scm ├── t16.exp ├── t16.scm ├── t17.scm ├── t18.exp ├── t18.scm ├── t19.exp ├── t19.scm ├── t2.scm ├── t21.scm ├── t22.scm ├── t23.exp ├── t23.scm ├── t24.exp ├── t24.scm ├── t25.exp ├── t25.scm ├── t26.exp ├── t26.scm ├── t27.exp ├── t27.scm ├── t28.exp ├── t28.scm ├── t3.scm ├── t30.exp ├── t30.scm ├── t35.exp ├── t35.scm ├── t37.exp ├── t37.scm ├── t38.exp ├── t38.scm ├── t39.exp ├── t39.scm ├── t4.scm ├── t42.exp ├── t42.scm ├── t43.scm ├── t5.scm ├── t6.scm ├── t6_2.scm ├── t7.scm ├── t8.scm ├── t9.scm ├── t_LIST.scm ├── t_aes256gcm.scm ├── t_alias.scm ├── t_alist.scm ├── t_alist0.exp ├── t_alist0.scm ├── t_alist1.scm ├── t_ambig.scm ├── t_anno.scm ├── t_anno0.scm ├── t_anno1.scm ├── t_anno2.scm ├── t_ansi.scm ├── t_argv.scm ├── t_attr.exp ├── t_attr.scm ├── t_b256.scm ├── t_backend.scm ├── t_backend2.scm ├── t_backquote.scm ├── t_bad_inline.exp ├── t_bad_inline.scm ├── t_base64.exp ├── t_base64.scm ├── t_base85.exp ├── t_base85.scm ├── t_ber.scm ├── t_bignum.scm ├── t_binop.scm ├── t_bitget.scm ├── t_bool.scm ├── t_bug1.exp ├── t_bug1.scm ├── t_bug32.exp ├── t_bug32.scm ├── t_butlast.scm ├── t_callbug.scm ├── t_cexp_wrap.exp ├── t_cexp_wrap.scm ├── t_chacha20poly1305.scm ├── t_clock_gettime.scm ├── t_collect.scm ├── t_combinations.scm ├── t_cond.scm ├── t_constructor.exp ├── t_constructor.scm ├── t_datatype.exp ├── t_datatype.scm ├── t_datatype0.exp ├── t_datatype0.scm ├── t_datatype2.scm ├── t_datatype3.scm ├── t_datatype4.scm ├── t_datatype5.scm ├── t_datatype6.scm ├── t_dtsexp.exp ├── t_dtsexp.scm ├── t_dump_image.exp ├── t_dump_image.scm ├── t_ed448.scm ├── t_empty_vector.exp ├── t_empty_vector.scm ├── t_endian.scm ├── t_endswith.scm ├── t_enum.scm ├── t_enum1.scm ├── t_epmh.scm ├── t_explode.scm ├── t_explode0.scm ├── t_extend.scm ├── t_fficonst.scm ├── t_fib1.scm ├── t_find_burnzieg.scm ├── t_find_karatsuba.scm ├── t_fold0.scm ├── t_fold_alist.scm ├── t_for_range.scm ├── t_format.scm ├── t_frb0.scm ├── t_frb1.exp ├── t_frb1.scm ├── t_gen1.scm ├── t_genutils.scm ├── t_getopt.scm ├── t_graph.exp ├── t_graph.scm ├── t_h2.scm ├── t_halloc.scm ├── t_hex0.scm ├── t_hexenc.scm ├── t_hkdf.scm ├── t_hmac.scm ├── t_hmac0.scm ├── t_hpack.scm ├── t_i31_rsa.scm ├── t_if_maybe.scm ├── t_inline0.scm ├── t_insert0.exp ├── t_insert0.scm ├── t_int0.scm ├── t_karatsuba.scm ├── t_lambda.scm ├── t_length.scm ├── t_letcc.scm ├── t_letpoly.scm ├── t_letreg.exp ├── t_letreg.scm ├── t_letreg0.scm ├── t_letreg_bug.scm ├── t_lex.scm ├── t_lisp_reader.scm ├── t_list_lt.scm ├── t_listdir.scm ├── t_literal.scm ├── t_literal0.scm ├── t_literal1.scm ├── t_literal2.scm ├── t_literal3.scm ├── t_literal4.scm ├── t_literal5.scm ├── t_literal6.scm ├── t_literal7.scm ├── t_literal8.scm ├── t_literal9.scm ├── t_lognot.scm ├── t_macro0.scm ├── t_magic_lt.scm ├── t_make_array.scm ├── t_map.exp ├── t_map.scm ├── t_match0.scm ├── t_match10.scm ├── t_match11.scm ├── t_match12.scm ├── t_match13.scm ├── t_match2.scm ├── t_match3.scm ├── t_match4.scm ├── t_match5.scm ├── t_match6.scm ├── t_match7.scm ├── t_match8.scm ├── t_match9.scm ├── t_match_bool.scm ├── t_match_char.scm ├── t_match_onearm.scm ├── t_match_pvariant.exp ├── t_match_pvariant.scm ├── t_match_pvariant0.scm ├── t_match_record.scm ├── t_match_string.scm ├── t_maze.scm ├── t_mtwist.scm ├── t_multiple.scm ├── t_multiple2.scm ├── t_mutex.scm ├── t_namedlet0.scm ├── t_neg.scm ├── t_nth.exp ├── t_nth.scm ├── t_nvcase0.scm ├── t_nvcase1.scm ├── t_pack.scm ├── t_pack1.exp ├── t_pack1.scm ├── t_parse.exp ├── t_parse.scm ├── t_parse2.scm ├── t_pem.scm ├── t_permutations.scm ├── t_pop.scm ├── t_pow.scm ├── t_pv0.scm ├── t_pv1.scm ├── t_quine1.exp ├── t_quine1.scm ├── t_read_file0.exp ├── t_read_file0.scm ├── t_recmac.scm ├── t_record_literal0.scm ├── t_record_literal1.scm ├── t_recur.scm ├── t_recur0.scm ├── t_recur1.scm ├── t_recursive.scm ├── t_rope.scm ├── t_row0.scm ├── t_row1.scm ├── t_row2.scm ├── t_samefringe0.scm ├── t_set.exp ├── t_set.scm ├── t_set2.scm ├── t_set_ptr.scm ├── t_sexp0.scm ├── t_sha1.scm ├── t_sha256.scm ├── t_sha256_3.scm ├── t_sig_pss.scm ├── t_single_dt.scm ├── t_small.exp ├── t_small.scm ├── t_sodium.scm ├── t_sort.exp ├── t_sort.scm ├── t_sorted_list.exp ├── t_sorted_list.scm ├── t_stack.exp ├── t_stack.scm ├── t_stack0.exp ├── t_stack0.scm ├── t_stack2.scm ├── t_startswith.scm ├── t_stdio.scm ├── t_stl.scm ├── t_string0.scm ├── t_string1.scm ├── t_string2.scm ├── t_string_append.scm ├── t_string_concat.scm ├── t_string_find0.scm ├── t_string_join.exp ├── t_string_join.scm ├── t_string_range.scm ├── t_string_split.scm ├── t_string_split_string.scm ├── t_strlen.scm ├── t_symbols.exp ├── t_symbols.scm ├── t_symbols0.scm ├── t_symbols1.scm ├── t_tail.scm ├── t_tls13.scm ├── t_typealias0.exp ├── t_typealias0.scm ├── t_uimm.scm ├── t_urandom.scm ├── t_utf8.exp ├── t_utf8.scm ├── t_vec16.scm ├── t_vec16_1.scm ├── t_veclit0.scm ├── t_vector.exp ├── t_vector.scm ├── t_vector1.scm ├── t_vm.scm ├── t_while.scm ├── t_y.scm ├── t_zlib.scm ├── t_λ.scm ├── tak20.exp └── tak20.scm ├── util ├── bootstrap.py ├── build_bootstraps.py ├── build_vm.py ├── check_fastcc.py ├── clean.py ├── clean_outputs.py ├── install.py ├── measure_inline_threshold.py ├── pygment.py ├── run_tests.py ├── run_tests_py.py └── safe.py └── vm ├── .gitignore ├── README.md ├── dynamic ├── README ├── bytecomp.py └── vm.scm ├── genopcodes.scm ├── irkvm.c ├── irkvm.h ├── low └── irkvm.scm └── tests ├── .gitignore ├── t0.scm ├── t1.scm ├── t10.scm ├── t11.scm ├── t12.scm ├── t13.scm ├── t14.scm ├── t15.scm ├── t16.scm ├── t17.scm ├── t18.scm ├── t19.scm ├── t2.scm ├── t20.scm ├── t21.scm ├── t22.scm ├── t23.scm ├── t24.scm ├── t25.scm ├── t26.scm ├── t27.scm ├── t28.scm ├── t29.scm ├── t3.scm ├── t30.scm ├── t31.scm ├── t32.scm ├── t33.scm ├── t34.scm ├── t3_2.scm ├── t4.scm ├── t5.scm ├── t6.scm ├── t7.scm ├── t8.scm ├── t9.scm ├── t_alist.scm ├── t_cmp.scm ├── t_ffi.scm ├── t_getc.scm ├── t_heap.scm ├── t_plat.scm ├── t_plat2.scm ├── t_prints.scm ├── t_readf.scm ├── t_samefringe.scm └── t_string.scm /.gitignore: -------------------------------------------------------------------------------- 1 | self/compile.c 2 | self/compile.ll 3 | self/compile.byc 4 | self/compile 5 | self/compile.dSYM/ 6 | self/compile[0-9] 7 | doom/*.c 8 | doom/*.ll 9 | tests/*.c 10 | tests/*.ll 11 | tests/*.byc 12 | /TAGS 13 | /.tramp_history 14 | /self/.tramp_history 15 | /vm/irkvm 16 | /vm/irkc 17 | ffi/*_iface.c 18 | *~ 19 | .tramp_history 20 | .DS_Store 21 | irken.elc 22 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | 3 | compiler: 4 | - clang 5 | - gcc 6 | 7 | script: python util/bootstrap.py 8 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # -*- Mode: Makefile; tab-width: 4 -*- 2 | 3 | all: safe 4 | 5 | # build from bootstrap. 6 | bootstrap: vm 7 | python util/bootstrap.py 8 | 9 | vm: vm/irkvm 10 | 11 | vm/irkvm: vm/irkvm.c include/header1.c include/irken.h 12 | python util/build_vm.py 13 | 14 | test: 15 | python util/run_tests.py 16 | 17 | # remove nearly everything 18 | clean: 19 | python util/clean.py 20 | 21 | # leave self/compile[0-9]? binaries. 22 | semi: 23 | python util/clean.py -s 24 | 25 | tags: 26 | find ./self ./lib -name "*.scm" | etags - 27 | 28 | # build self/compile with binary rotation. 29 | safe: 30 | python util/safe.py 31 | 32 | vmself: 33 | self/compile self/compile.scm -b 34 | 35 | -------------------------------------------------------------------------------- /demo/99bottles.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; http://www.99-bottles-of-beer.net/language-irken-2823.html 4 | 5 | (include "lib/basis.scm") 6 | 7 | (define B 8 | 0 -> "no more bottles" 9 | 1 -> "1 bottle" 10 | x -> (format (int x) " bottles") 11 | ) 12 | 13 | (for-range 14 | i 99 15 | (let ((n (- 99 i))) 16 | (printf (B n) " of beer on the wall, " (B n) " of beer.\n" 17 | "Take one down and pass it around, " 18 | (B (- n 1)) " of beer on the wall.\n\n"))) 19 | 20 | (printf "No more bottles of beer on the wall, no more bottles of beer.\n") 21 | (printf "Go to the store and buy some more, 99 bottles of beer on the wall.\n") 22 | -------------------------------------------------------------------------------- /demo/hello.scm: -------------------------------------------------------------------------------- 1 | ;; Irken's Hello, World! 2 | ;; 3 | ;; To run, compile this file with irken and execute the results 4 | ;; 5 | ;; $ irken demo/hello.scm 6 | ;; $ demo/hello 7 | ;; Hello, World! 8 | ;; 9 | 10 | (require "lib/basis.scm") 11 | (printf "Hello, World!\n") 12 | -------------------------------------------------------------------------------- /demo/parse/antlr2sexp.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/parse/lexer.scm") 6 | (include "lib/parse/glextab.scm") 7 | (include "lib/parse/earley.scm") 8 | (include "lib/parse/gparser.scm") 9 | 10 | (define prod->sexp 11 | (prod:nt name) -> (sexp:symbol name) 12 | (prod:t name) -> (sexp:symbol name) 13 | ) 14 | 15 | (define prods->sexp 16 | (one) -> (prod->sexp one) 17 | prods -> (sexp:list (map prod->sexp prods)) 18 | ) 19 | 20 | (if (< sys.argc 2) 21 | (begin 22 | (printf "\nTranslate an ANTLR-style grammar to s-expression form.\n\n") 23 | (printf "Usage: " sys.argv[0] " c.g\n") 24 | (printf " [note: this library does not understand the full ANTLR syntax, but only\n") 25 | (printf " basic grammar productions (i.e., no lexing, no *?+ etc]\n") 26 | ) 27 | (let ((gram (read-grammar sys.argv[1])) 28 | (r '())) 29 | (alist/iterate 30 | (lambda (name alts) 31 | (push! r (sexp1 name (map prods->sexp alts)))) 32 | gram) 33 | (printf ";; -*- Mode: Irken -*-\n\n") 34 | (printf ";; generated by " sys.argv[0] " from " sys.argv[1] "\n") 35 | (printf ";; -- do not edit --\n\n") 36 | (pp (sexp1 'grammar r) 80) 37 | )) 38 | 39 | -------------------------------------------------------------------------------- /demo/parse/lex2dot.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/basis.scm") 4 | (require "lib/dfa/lexicon.scm") 5 | (require "lib/dfa/emit.scm") 6 | 7 | (if (< sys.argc 2) 8 | (begin (printf "\nGenerate a lexer dfa (in dot format) to stdout.\n\n") 9 | (printf "Usage: " sys.argv[0] " \n") 10 | (printf " example: $ " sys.argv[0] " sexp-lex.sg\n") 11 | (printf " the input lexicon is in s-expression format.\n") 12 | -1) 13 | (let ((lexpath sys.argv[1]) 14 | (lexfile (file/open-read lexpath)) 15 | ;; read the parser spec as an s-expression 16 | (exp (reader lexpath (lambda () (file/read-char lexfile)))) 17 | (lexicon (sexp->lexicon (car exp))) 18 | ;; convert the lexicon to a dfa 19 | (dfa0 (lexicon->dfa lexicon)) 20 | ((labels dfa1) dfa0)) 21 | (dfa->dot dfa1 sys.argv[1]) 22 | 0 23 | )) 24 | -------------------------------------------------------------------------------- /demo/parse/lexfile.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/basis.scm") 4 | (require "lib/dfa/lexicon.scm") 5 | (require "lib/parse/lexer.scm") 6 | 7 | (if (< sys.argc 3) 8 | (begin (printf "\nLex a file, given a lexicon.\n\n") 9 | (printf "Usage: " sys.argv[0] " \n") 10 | (printf " example: $ " sys.argv[0] " sexp-lex.sg sexp-lex.sg\n")) 11 | (let ((lexpath sys.argv[1]) 12 | (lexfile (file/open-read lexpath)) 13 | ;; read the parser spec as an s-expression 14 | (exp (reader lexpath (lambda () (file/read-char lexfile)))) 15 | (lexicon (sexp->lexicon (car exp))) 16 | ;; convert the lexicon to a dfa 17 | (dfa0 (lexicon->dfa lexicon)) 18 | ((labels dfa1) dfa0) 19 | ;; build a lexer from the dfa 20 | (lexer (dfa->lexer dfa0)) 21 | ;; lex the given file 22 | (spath sys.argv[2]) 23 | (sfile (file/open-read spath)) 24 | (gen0 (file-char-generator sfile)) 25 | (gen1 (make-lex-generator lexer gen0))) 26 | (for tok gen1 27 | (printf (sym tok.kind) " " (string tok.val) "\n")) 28 | )) 29 | -------------------------------------------------------------------------------- /demo/parse/meta-lex.sg: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | (lexicon 3 | (WHITESPACE (reg "[ \n\t]+")) 4 | (COMMENT (reg "[ \t]*//[^\n]*\n")) 5 | (COLON (lit ":")) 6 | (VBAR (lit "|")) 7 | (SEMICOLON (lit ";")) 8 | (NAME (reg "[A-Za-z_][A-Za-z_0-9]*")) 9 | ) 10 | -------------------------------------------------------------------------------- /demo/parse/meta.sg: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp -*- 2 | 3 | ;; this is a parser for antlr-style grammars. 4 | 5 | (parser 6 | (lexicon 7 | (WHITESPACE (reg "[ \n\t]+")) 8 | (COMMENT (reg "[ \t]*//[^\n]*\n")) 9 | (COLON (lit ":")) 10 | (VBAR (lit "|")) 11 | (SEMICOLON (lit ";")) 12 | (NAME (reg "[A-Za-z_][A-Za-z_0-9]*")) 13 | (NUMBER (reg "[0-9]+")) 14 | ) 15 | (filter WHITESPACE COMMENT) 16 | (grammar 17 | (syntax (syntax rule) rule) 18 | (rule (NAME COLON exp SEMICOLON)) 19 | (exp (list VBAR exp) list) 20 | (list (list term) term) 21 | (term STRING NAME) 22 | ) 23 | ) 24 | -------------------------------------------------------------------------------- /demo/parse/sexp-lex.sg: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | (lexicon 3 | ;; XXX newlines should be allowed in strings. 4 | (STRING (reg "\"([^\n\"\\\\]|\\\\.)*\"")) 5 | (WHITESPACE (reg "[ \n\t]+")) 6 | (COMMENT (reg ";[^\n]*\n")) 7 | (NUMBER (reg "[0-9]+")) 8 | (BIN (reg "#b[01]+")) 9 | (OCT (reg "#o[0-7]+")) 10 | (DEC (reg "#d[0-9]+")) 11 | (HEX (reg "#x[0-9A-Fa-f]+")) 12 | ;;;(DOTDOTDOT (lit "...")) ;; YOU ARE HERE 13 | (DOT (lit ".")) 14 | (LBRACKET (lit "[")) 15 | (RBRACKET (lit "]")) 16 | (LPAREN (lit "(")) 17 | (RPAREN (lit ")")) 18 | (BOOL (reg "#[tf]")) 19 | (CHAR (reg "(#\\\\.)|(#\\\\newline)|(#\\\\space)|(#\\\\tab)|(#\\\\return)|(#\\\\eof)|(#\\\\nul)")) 20 | ;;(SYMBOL (reg "[^;()\\[\\] \t\n\"\\.]+")) 21 | (SYMBOL (reg "([^;()\\[\\] \t\n\"\\.]+)|(\\.\\.\\.)")) 22 | ) 23 | -------------------------------------------------------------------------------- /demo/parse/sexp.sg: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; parser for Irken. [work in progress] 4 | 5 | (parser 6 | (lexicon 7 | ;; XXX newlines should be allowed in strings. 8 | (STRING (reg "\"([^\n\"\\\\]|\\\\.)*\"")) 9 | (WHITESPACE (reg "[ \n\t]+")) 10 | (COMMENT (reg ";[^\n]*\n")) 11 | (NUMBER (reg "[0-9]+")) 12 | (BIN (reg "#b[01]+")) 13 | (OCT (reg "#o[0-7]+")) 14 | (DEC (reg "#d[0-9]+")) 15 | (HEX (reg "#x[0-9A-Fa-f]+")) 16 | (DOT (lit ".")) 17 | (LBRACKET (lit "[")) 18 | (RBRACKET (lit "]")) 19 | (LPAREN (lit "(")) 20 | (RPAREN (lit ")")) 21 | (BOOL (reg "#[tf]")) 22 | (CHAR (reg "(#\\\\.)|(#\\\\newline)|(#\\\\space)|(#\\\\tab)|(#\\\\return)|(#\\\\eof)|(#\\\\nul)")) 23 | (SYMBOL (reg "([^;()\\[\\] \t\n\"\\.]+)|(\\.\\.\\.)")) 24 | ) 25 | (filter WHITESPACE COMMENT) 26 | (grammar 27 | (exps (exps exp) exp) 28 | (exp atom list attr aref) 29 | (attr (exp DOT SYMBOL)) ;; postfix 30 | (aref (exp LBRACKET exp RBRACKET)) ;; postfix 31 | (atom NUMBER BIN OCT DEC HEX STRING SYMBOL BOOL CHAR) 32 | (list (LPAREN RPAREN) (LPAREN exps RPAREN)) 33 | ) 34 | ) 35 | -------------------------------------------------------------------------------- /demo/repl/.gitignore: -------------------------------------------------------------------------------- 1 | repl 2 | repl.c 3 | -------------------------------------------------------------------------------- /demo/repl/README.md: -------------------------------------------------------------------------------- 1 | 2 | Read-Eval-Print-Loop 3 | -------------------- 4 | 5 | This isn't actually a REPL for Irken, but rather a demonstration of 6 | how to write a simple scheme interpreter using Irken. 7 | 8 | The small amount of code here demonstrates: 9 | 10 | 1) lexical environments 11 | 2) function application 12 | 3) primitives 13 | 14 | ... and can be easily extended to add more functionality. 15 | 16 | Fun exercises: 17 | 18 | 1) add more list-processing functions 19 | 2) add a socket interface (see the `doom` directory). 20 | -------------------------------------------------------------------------------- /demo/rsa.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; https://rosettacode.org/wiki/RSA_code 4 | 5 | (require "lib/basis.scm") 6 | (require "demo/bignum.scm") 7 | 8 | (define (encrypt msg e n) 9 | (big (expmod msg e n))) 10 | 11 | (define (decrypt msg d n) 12 | (big (expmod msg d n))) 13 | 14 | (define (main) 15 | (let ((d (big (dec "5617843187844953170308463622230283376298685"))) 16 | (n (big (dec "9516311845790656153499716760847001433441357"))) 17 | (e (big (I 65537))) 18 | (text "rubber ducky") 19 | (text0 (b256->big text)) 20 | (enc0 (encrypt text0 e n)) 21 | (dec0 (decrypt enc0 d n))) 22 | (printf " plaintext " (string text) "\n") 23 | (printf " as int " (big-repr text0) "\n") 24 | (printf " as txt " (string (big->b256 text0)) "\n") 25 | (printf "encrypted " (big-repr enc0) "\n") 26 | (printf "decrypted " (big-repr dec0) "\n") 27 | (printf " as txt " (string (big->b256 dec0)) "\n") 28 | )) 29 | 30 | (main) 31 | -------------------------------------------------------------------------------- /docs/README.md: -------------------------------------------------------------------------------- 1 | 2 | # The Irken Programming Language 3 | 4 | ## Introduction. 5 | 6 | [Installing Irken](install.md). 7 | 8 | A [gentle introduction](intro.md). 9 | 10 | ## Datatypes. 11 | 12 | How to [create new datatypes](datatypes.md). 13 | 14 | ## Types (and Inference). 15 | 16 | Irken's [type system](types.md). 17 | 18 | ## Library Reference. 19 | 20 | Read about [the library](lib/README.md). 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /docs/install.md: -------------------------------------------------------------------------------- 1 | Installing Irken 2 | ================ 3 | 4 | Irken can be downloaded from its GitHub page. 5 | 6 | Clone the `master` branch of the `irken-compiler` repository 7 | 8 | $ git clone https://github.com/samrushing/irken-compiler.git 9 | 10 | Change to the newly created repository directory and run the python bootstrap script 11 | 12 | $ cd irken-compiler 13 | $ python util/bootstrap.py 14 | 15 | Compilation will take a few minutes. If you don't get any error messages, you should be ready for installation. The installation process will install all files under `/usr/local`. To install: 16 | 17 | $ python util/install.py 18 | 19 | Once complete, you can confirm that Irken is installed and ready to use by compiling a simple demo program. Assuming `/usr/local/bin` is in your path: 20 | 21 | $ irken demo/hello.scm 22 | $ demo/hello 23 | Hello, World! 24 | -------------------------------------------------------------------------------- /docs/lib/README.md: -------------------------------------------------------------------------------- 1 | 2 | # The Irken Library 3 | 4 | * [core](core.md). Low-level functions, macros, integer math. 5 | * [derived expressions](derived.md). Automatically included by the compiler. 6 | * [lists](list.md). 7 | * [maps and sets](mapset.md). 8 | * [I/O](io.md). 9 | * [random](random.md). 10 | -------------------------------------------------------------------------------- /doom/README: -------------------------------------------------------------------------------- 1 | DOOM is a kqueue-based cooperative threading system for Irken. 2 | -------------------------------------------------------------------------------- /doom/doom.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/net/socket.scm") 4 | (require "doom/scheduler.scm") 5 | (require "doom/socket.scm") 6 | 7 | -------------------------------------------------------------------------------- /doom/echo.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/basis.scm") 4 | (require "doom/doom.scm") 5 | 6 | (require-ffi 'kqueue) 7 | 8 | (define (serve ip port) 9 | (let ((sock (doom/make (tcp4-sock))) 10 | (addr (address/make4 ip port))) 11 | (sock.bind addr) 12 | (sock.listen 5) 13 | (printf "starting server...\n") 14 | (let loop () 15 | (printf "accept wait...\n") 16 | (let (((sockfun addr) (sock.accept))) 17 | (printf "client: addr " (address/unparse addr) "\n") 18 | (poller/fork (lambda () (client sockfun))) 19 | (loop))))) 20 | 21 | (define (client sockfun) 22 | (let ((sock (sockfun 8192 8192))) 23 | (print-string "client starting\n") 24 | (let loop () 25 | (let ((data (sock.recv))) 26 | (printf "data = " (string data) "\n") 27 | (when (> (string-length data) 0) 28 | (sock.send data) 29 | (loop)))) 30 | (printf "exiting client...\n") 31 | (sock.close) 32 | )) 33 | 34 | (serve "0.0.0.0" 9999) 35 | (poller/wait-and-schedule) 36 | -------------------------------------------------------------------------------- /doom/fetch.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/basis.scm") 4 | (require "doom/doom.scm") 5 | 6 | (define (fetch-head ip) 7 | (let ((sock (doom/make (tcp4-sock))) 8 | (addr (address/make4 ip 80))) 9 | (sock.connect addr) 10 | (sock.send "HEAD / HTTP/1.0\r\n\r\n") 11 | (printf (string (sock.recv)) "\n") 12 | (sock.close) 13 | )) 14 | 15 | (let ((ip "72.52.84.226")) 16 | (poller/fork (lambda () (fetch-head ip))) 17 | (poller/fork (lambda () (fetch-head ip))) 18 | (poller/fork (lambda () (fetch-head ip))) 19 | (poller/wait-and-schedule) 20 | ) 21 | -------------------------------------------------------------------------------- /doom/sync.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; synchronization primitives go here. 4 | 5 | (define (mutex/make) 6 | (let ((held-by -1) 7 | (fifo (queue/make))) 8 | (define (acquire*) 9 | (let ((k (getcc))) 10 | (queue/add! fifo (poller/make-save k)) 11 | (poller/dispatch))) 12 | (define (acquire) 13 | (when (>= held-by 0) 14 | ;; (debugf "mutex held by " (int held-by) " , waiting...\n") 15 | (acquire*)) 16 | ;; (debugf "acquire by " (int *thread-id*) "\n") 17 | (set! held-by *thread-id*)) 18 | (define (release) 19 | ;; (debugf "release by " (int *thread-id*) "\n") 20 | (cond ((= held-by *thread-id*) 21 | (set! held-by -1) 22 | (when-maybe save (queue/pop! fifo) 23 | ;; (debugf "scheduling...\n") 24 | (poller/schedule save))) 25 | (else 26 | (raise (:Mutex/BadRelease held-by *thread-id*))))) 27 | {acquire=acquire release=release} 28 | )) 29 | 30 | (defmacro with-mutex 31 | (with-mutex m body ...) 32 | -> (begin 33 | (m.acquire) 34 | (try 35 | (begin body ... (m.release)) 36 | except 37 | EXN 38 | -> (begin 39 | (m.release) 40 | (raise EXN))))) 41 | -------------------------------------------------------------------------------- /doom/test/t_websocket.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "doom/doom.scm") 6 | (include "lib/codecs/base64.scm") 7 | (include "lib/crypto/sha1.scm") 8 | (include "doom/http/websocket.scm") 9 | 10 | (define (ws-echo-client sockfun) 11 | (let ((ws (websocket (sockfun 8192 8192)))) 12 | (for pkt ws.pktgen 13 | (match pkt with 14 | (:tuple opcode data fin?) 15 | -> (ws.send-packet opcode data fin?))) 16 | (printf "exiting client...\n") 17 | (ws.close) 18 | )) 19 | 20 | (define (serve ip port) 21 | (let ((sock (doom/make (tcp4-sock))) 22 | (addr (address/make4 ip port))) 23 | (sock.bind addr) 24 | (sock.listen 5) 25 | (printf "starting server...\n") 26 | (let loop () 27 | (printf "accept wait...\n") 28 | (let (((sockfun addr) (sock.accept))) 29 | (printf "client: addr " (address/unparse addr) "\n") 30 | (poller/fork (lambda () (ws-echo-client sockfun))) 31 | (loop))))) 32 | 33 | (serve "0.0.0.0" 9999) 34 | (poller/wait-and-schedule) 35 | -------------------------------------------------------------------------------- /doom/tls/kex.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/crypto/dh.scm") 4 | (require "lib/crypto/decaf.scm") 5 | 6 | (define (make-x25519-kex) 7 | (let ((key {sk="" pk=""})) 8 | (define (gen) 9 | (set! key (x25519-gen-key))) 10 | (define (get-pub) key.pk) 11 | (define (gen-shared pk1) 12 | (x25519-gen-shared-key key.sk pk1)) 13 | {gen=gen get-pub=get-pub gen-shared=gen-shared size=32 group=(named-group:x25519)} 14 | )) 15 | 16 | (define (make-x448-kex) 17 | (let ((key {sk="" pk=""})) 18 | (define (gen) 19 | (set! key (x448-gen-key))) 20 | (define (get-pub) key.pk) 21 | (define (gen-shared pk1) 22 | (x448-gen-shared-key key.sk pk1)) 23 | {gen=gen get-pub=get-pub gen-shared=gen-shared size=56 group=(named-group:x448)} 24 | )) 25 | 26 | (define make-kex 27 | (named-group:x25519) -> (make-x25519-kex) 28 | (named-group:x448) -> (make-x448-kex) 29 | group -> (raise (:TLS/Fatal (tls-alert-desc:hsk-failure) "no shared kex")) 30 | ) 31 | -------------------------------------------------------------------------------- /doom/tls/signer.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/crypto/decaf.scm") 4 | (require "lib/crypto/sig.scm") 5 | 6 | ;; these objects are responsible for signing with the cert's private key. 7 | 8 | (define (make-rsassa-pss-rsae-sha256-signer skey) 9 | (define (sign tbs RNG) 10 | (rsassa-pss-sign skey tbs sha256-hash RNG)) 11 | {sign=sign sigalg=(sigalg:rsa-pss-rsae-sha256)} 12 | ) 13 | 14 | (define (make-ed25519-signer skey) 15 | ;; skey is actually the seed. 16 | ;; see: https://blog.mozilla.org/warner/2011/11/29/ed25519-keys/ 17 | (let (((sk pk) (ed25519-seed-to-keypair skey))) 18 | {sign=(lambda (tbs RNG) (ed25519-sign tbs sk)) sigalg=(sigalg:ed25519)} 19 | )) 20 | 21 | (define (make-ed448-signer skey) 22 | (let ((pkey (ed448-derive-public-key skey))) 23 | (define (sign tbs RNG) 24 | (ed448-sign tbs skey pkey)) 25 | {sign=sign sigalg=(sigalg:ed448)} 26 | )) 27 | 28 | (define make-signer 29 | (skey:rsa skey) -> (make-rsassa-pss-rsae-sha256-signer skey) 30 | (skey:ed25519 skey) -> (make-ed25519-signer skey) 31 | (skey:ed448 skey) -> (make-ed448-signer skey) 32 | ) 33 | 34 | -------------------------------------------------------------------------------- /ffi/brotli.ffi: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: lisp -*- 2 | 3 | (brotli 4 | (includes "brotli/encode.h" "brotli/decode.h") 5 | (cflags "-I/usr/local/include") 6 | (lflags "-L/usr/local/lib/ -lbrotlienc -lbrotlidec") 7 | (enums BrotliEncoderMode BrotliEncoderOperation BrotliEncoderParameter 8 | BrotliDecoderResult BrotliDecoderParameter) 9 | (constants 10 | BROTLI_MAX_WINDOW_BITS 11 | BROTLI_LARGE_MAX_WINDOW_BITS 12 | BROTLI_MIN_INPUT_BLOCK_BITS 13 | BROTLI_MAX_INPUT_BLOCK_BITS 14 | BROTLI_MIN_QUALITY 15 | BROTLI_MAX_QUALITY) 16 | (sigs 17 | BrotliEncoderSetParameter 18 | BrotliEncoderCreateInstance 19 | BrotliEncoderDestroyInstance 20 | BrotliEncoderMaxCompressedSize 21 | BrotliEncoderCompress 22 | BrotliEncoderCompressStream 23 | BrotliEncoderIsFinished 24 | BrotliEncoderHasMoreOutput 25 | BrotliEncoderTakeOutput 26 | BrotliEncoderVersion 27 | ) 28 | ) 29 | -------------------------------------------------------------------------------- /ffi/dl.ffi: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: lisp -*- 2 | 3 | (dl 4 | (lflags (%platform Linux "-ldl" else "")) 5 | (includes "dlfcn.h") 6 | (constants RTLD_LAZY RTLD_NOW RTLD_GLOBAL RTLD_LOCAL RTLD_DEFAULT) 7 | (sigs dlopen dlsym dlerror) 8 | ) 9 | 10 | -------------------------------------------------------------------------------- /ffi/gen/genffi.byc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samrushing/irken-compiler/a36fc2ce3eccd19aa4e524091c44149472846af1/ffi/gen/genffi.byc -------------------------------------------------------------------------------- /ffi/kqueue.ffi: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (kqueue 4 | (includes "sys/types.h" "sys/event.h") 5 | (structs kevent) 6 | (constants 7 | ;; ------------ filters ------------------ 8 | EVFILT_READ EVFILT_WRITE EVFILT_AIO EVFILT_VNODE EVFILT_PROC 9 | EVFILT_SIGNAL 10 | ;; Darwin only 11 | EVFILT_MACHPORT 12 | EVFILT_TIMER EVFILT_SYSCOUNT 13 | ;; ------------- flags ------------------- 14 | EV_ADD EV_ENABLE EV_DISABLE EV_DELETE 15 | EV_RECEIPT EV_ONESHOT EV_CLEAR EV_EOF EV_ERROR 16 | ;; +FreeBSD/-Darwin 17 | EV_DISPATCH 18 | ;; ----- facility-specific constants ----- 19 | ;; for EVFILT_VNODE 20 | NOTE_DELETE NOTE_WRITE NOTE_EXTEND NOTE_ATTRIB NOTE_LINK 21 | NOTE_RENAME NOTE_REVOKE NOTE_FUNLOCK 22 | ;; for EVFILT_PROC 23 | NOTE_EXIT NOTE_EXITSTATUS NOTE_FORK NOTE_EXEC NOTE_SIGNAL 24 | ;; marked deprecated: NOTE_REAP 25 | ;; for EVFILT_TIMER 26 | NOTE_SECONDS NOTE_USECONDS NOTE_NSECONDS 27 | ;; +Darwin 28 | NOTE_MACHTIME 29 | ;; +FreeBSD 30 | NOTE_MSECONDS 31 | ;; +Darwin 32 | NOTE_CRITICAL NOTE_BACKGROUND NOTE_LEEWAY 33 | ) 34 | (sigs kqueue kevent) 35 | ) 36 | -------------------------------------------------------------------------------- /ffi/libc.ffi: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: lisp -*- 2 | 3 | (libc 4 | (includes "string.h" "stdio.h" "stdlib.h") 5 | (constants) 6 | ;; note: can't put errno here because it is often a macro. 7 | (sigs strlen strerror system getenv abort tmpnam 8 | memcpy realloc) 9 | ) 10 | -------------------------------------------------------------------------------- /ffi/libc_ffi.scm: -------------------------------------------------------------------------------- 1 | ;; generated by ffi/gen/genffi for ffi/libc 2 | 3 | (includes "string.h" "stdio.h" "stdlib.h" ) 4 | (cflags ) 5 | (lflags ) 6 | (sig strlen ((* char) -> ulong)) 7 | (sig strerror (int -> (* char))) 8 | (sig system ((* char) -> int)) 9 | (sig getenv ((* char) -> (* char))) 10 | (sig abort ( -> void)) 11 | (sig tmpnam ((* char) -> (* char))) 12 | (sig memcpy ((* void) (* void) ulong -> (* void))) 13 | (sig realloc ((* void) ulong -> (* void))) 14 | -------------------------------------------------------------------------------- /ffi/socket.ffi: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Lisp -*- 2 | (socket 3 | (includes "sys/types.h" "sys/socket.h" "netinet/in.h" 4 | "arpa/inet.h" "unistd.h" "sys/uio.h" "sys/errno.h" 5 | "fcntl.h" ;; for non-blocking mode. 6 | ) 7 | (structs sockaddr sockaddr_in sockaddr_in6 in_addr in6_addr) 8 | (constants 9 | AF_INET AF_INET6 AF_UNIX 10 | SOCK_STREAM SOCK_DGRAM SOCK_RAW 11 | EAGAIN EINPROGRESS EWOULDBLOCK 12 | EISCONN ENOTCONN 13 | ;; minimum needed for fcntl() to set non-blocking mode. 14 | O_NDELAY F_GETFL F_SETFL 15 | ;; socket options 16 | SOL_SOCKET 17 | SO_DEBUG SO_REUSEADDR SO_REUSEPORT SO_KEEPALIVE SO_DONTROUTE 18 | SO_LINGER SO_BROADCAST SO_OOBINLINE SO_SNDBUF SO_RCVBUF SO_SNDLOWAT 19 | SO_RCVLOWAT SO_SNDTIMEO SO_RCVTIMEO SO_TYPE SO_ERROR SO_NOSIGPIPE 20 | SO_NREAD SO_NWRITE SO_LINGER_SEC 21 | ) 22 | (sigs inet_ntop inet_pton socket bind listen accept connect recv send setsockopt getsockopt) 23 | (verbatim 24 | (sig fcntl (int int int -> int)) 25 | ;; this is often a macro *and* a function. 26 | (sig htons (int -> int)) 27 | ) 28 | ) 29 | 30 | -------------------------------------------------------------------------------- /ffi/stdio.ffi: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: lisp -*- 2 | 3 | (stdio 4 | (includes "stdio.h") 5 | (structs) ;; note: FILE is an opaque type. 6 | (constants) 7 | (lflags) 8 | (cflags) 9 | (sigs 10 | fopen fwrite fread fgetc fclose fflush fdopen putchar getchar 11 | stdin stdout stderr 12 | )) 13 | 14 | 15 | -------------------------------------------------------------------------------- /ffi/stdio_ffi.scm: -------------------------------------------------------------------------------- 1 | ;; bootstrap version. 2 | 3 | (includes "stdio.h" ) 4 | (cflags ) 5 | (lflags ) 6 | (sig fopen ((* char) (* char) -> (* FILE))) 7 | (sig fwrite ((* void) int int (* FILE) -> int)) 8 | (sig fread ((* void) int int (* FILE) -> int)) 9 | (sig fgetc ((* FILE) -> int)) 10 | (sig fclose ((* FILE) -> int)) 11 | (sig fflush ((* FILE) -> int)) 12 | (sig fdopen (int (* char) -> (* FILE))) 13 | (sig putchar (int -> int)) 14 | (sig getchar ( -> int)) 15 | -------------------------------------------------------------------------------- /ffi/tests/socktest.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/net/socket.scm") 6 | 7 | (define (test-echo addr0 sock0) 8 | (printf "fd0 = " (int sock0.fd) "\n") 9 | (sock/bind sock0 addr0) 10 | (printf "bind ok.\n") 11 | (sock/listen sock0 5) 12 | (printf "listen ok.\n") 13 | (match (sock/accept sock0) with 14 | (:tuple sock1 addr1) 15 | -> (begin 16 | (printf "accept ok.\n") 17 | (printf "peer address: " (address/unparse addr1) "\n") 18 | (let ((buf (buffer/make 4096))) 19 | (for-range i 5 20 | (sock/recv sock1 buf) 21 | (printf (string (buffer/contents buf)) "\n") 22 | (sock/send sock1 buf) 23 | (buffer/reset! buf) 24 | ) 25 | (sock/close sock1) 26 | ))) 27 | (sock/close sock0) 28 | ) 29 | 30 | (test-echo (address/make4 "127.0.0.1" 9002) (tcp4-sock)) 31 | (test-echo (address/make6 "::1" 9002) (tcp6-sock)) 32 | -------------------------------------------------------------------------------- /ffi/tests/t_halloc.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (require-ffi 'posix) 7 | 8 | (define (get-cstring p) (%cref->string #f p (posix/strlen p))) 9 | 10 | (let ((utsname0 (halloc (struct utsname))) 11 | (utsname1 (malloc (struct utsname)))) 12 | (posix/uname utsname0) 13 | (posix/uname utsname1) 14 | (printf (string (get-cstring (%c-sref utsname.nodename utsname0))) "\n") 15 | (printf (string (get-cstring (%c-sref utsname.nodename utsname1))) "\n") 16 | (printf (string (get-cstring (%c-sref utsname.sysname utsname0))) "\n") 17 | (printf (string (get-cstring (%c-sref utsname.sysname utsname1))) "\n") 18 | (free utsname1) 19 | ) 20 | -------------------------------------------------------------------------------- /ffi/tests/t_set_int.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (require-ffi 'posix) 7 | 8 | (defmacro parray 9 | (parray a n w) ;; array N width 10 | -> (for-range i n 11 | (printf (repeat w " ") 12 | (zpad (* w 2) 13 | (hex (c-get-int (c-aref a i))))))) 14 | 15 | (let ((v (halloc u8 40)) ;; u8[40] 16 | (w (%c-cast (array u16) v)) ;; u16[20] 17 | (x (%c-cast (array u32) v))) ;; u32[10] 18 | 19 | ;; 00 01 02 ... 20 | (for-range i 40 21 | (c-set-int (c-aref v i) i)) 22 | 23 | ;; dump the array in all three interpretations... 24 | (parray v 40 1) 25 | (printf "\n") 26 | (parray w 20 2) 27 | (printf "\n") 28 | (parray x 10 4) 29 | (printf "\n") 30 | 31 | ;; set as u32 values... 32 | (for-range i 10 33 | (c-set-int (c-aref x i) (>> #xdeadbeef i))) 34 | 35 | ;; dump again 36 | (parray v 40 1) 37 | (printf "\n") 38 | (parray w 20 2) 39 | (printf "\n") 40 | (parray x 10 4) 41 | (printf "\n") 42 | 43 | ) 44 | 45 | -------------------------------------------------------------------------------- /ffi/uname.ffi: -------------------------------------------------------------------------------- 1 | (uname 2 | (includes sys/utsname.h) 3 | (structs utsname) 4 | (constants) 5 | (sigs 6 | (uname (* (struct utsname)) -> int) 7 | )) 8 | -------------------------------------------------------------------------------- /ffi/zlib.ffi: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: lisp -*- 2 | 3 | (zlib 4 | (includes "zlib.h") 5 | (cflags "") 6 | (lflags "-lz") 7 | (structs z_stream_s) 8 | (constants Z_NO_FLUSH Z_PARTIAL_FLUSH Z_SYNC_FLUSH Z_FULL_FLUSH Z_FINISH Z_BLOCK Z_TREES 9 | ;; compression levels 10 | Z_NO_COMPRESSION Z_BEST_SPEED Z_BEST_COMPRESSION Z_DEFAULT_COMPRESSION 11 | ;; return values 12 | Z_OK 13 | Z_STREAM_END Z_NEED_DICT Z_ERRNO Z_STREAM_ERROR Z_DATA_ERROR Z_MEM_ERROR 14 | Z_BUF_ERROR Z_VERSION_ERROR 15 | ;; required because of the macro hacks in xxxInit_ 16 | ZLIB_VER_MAJOR ZLIB_VER_MINOR ZLIB_VER_REVISION 17 | ) 18 | (sigs zlibVersion 19 | deflateInit_ deflate deflateEnd 20 | inflateInit_ inflate inflateEnd 21 | ) 22 | ) 23 | -------------------------------------------------------------------------------- /lang/0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (datatype thing 7 | (:int int) 8 | (:str string) 9 | (:sym symbol) 10 | ) 11 | 12 | (list (thing:int 1) (thing:str "two") (thing:sym 'three)) 13 | 14 | -------------------------------------------------------------------------------- /lang/1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (define length 7 | () -> 0 8 | (_ . tl) -> (+ 1 (length tl))) 9 | 10 | (define length1 11 | (list:nil) -> 0 12 | (list:cons _ tl) -> (+ 1 (length1 tl))) 13 | 14 | (define length2 15 | () acc -> acc 16 | (_ . tl) acc -> (length2 tl (+ 1 acc)) 17 | ) 18 | 19 | (define (length3 l) 20 | (length2 l 0)) 21 | 22 | (define (length4 l) 23 | (define recur 24 | () acc -> acc 25 | (_ . tl) acc -> (recur tl (+ 1 acc)) 26 | ) 27 | (recur l 0) 28 | ) 29 | 30 | (length4 '(1 2 3 4 5)) 31 | 32 | -------------------------------------------------------------------------------- /lang/2.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define my-record {f0=#t f1="stringy" f2=1234}) 6 | 7 | (define (fun r) 8 | (+ r.f2 34)) 9 | 10 | (printn my-record.f0) 11 | (printn my-record.f1) 12 | (printn fun) 13 | -------------------------------------------------------------------------------- /lang/3.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define v0 (:pair 3 #t)) 6 | (define v1 (:thingy 12)) 7 | 8 | (define (fun x) 9 | (vcase x 10 | ((:pair n b) n) 11 | ((:thingy n) n) 12 | )) 13 | 14 | (define fun1 15 | (:pair n _) -> n 16 | (:thingy n) -> n 17 | ) 18 | 19 | (printn v0) 20 | (printn (fun v0)) 21 | (printn (fun v1)) 22 | (printn (fun1 v0)) 23 | (printn (fun1 v1)) 24 | -------------------------------------------------------------------------------- /lang/4.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (datatype tree 6 | (:empty) 7 | (:node 'a (tree 'a) (tree 'a)) 8 | ) 9 | 10 | (define indent 11 | 0 -> #f 12 | n -> (begin (print-string " ") (indent (- n 1))) 13 | ) 14 | 15 | (define tree/print 16 | d (tree:empty) -> #f 17 | d (tree:node val left right) -> (begin 18 | (indent d) 19 | (tree/print (+ d 1) left) 20 | (print val) 21 | (print-string "\n") 22 | (tree/print (+ d 1) right))) 23 | 24 | (let ((t (tree:node 25 | 5 26 | (tree:node 7 (tree:empty) (tree:node 12 (tree:empty) (tree:empty))) 27 | (tree:node 9 (tree:empty) (tree:empty)) 28 | ))) 29 | (tree/print 0 t) 30 | ) 31 | -------------------------------------------------------------------------------- /lang/5.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (fun x y) 3 | (match (+ 1 x) y with 4 | 12 z -> (+ z 9) 5 | 15 9 -> 0 6 | x y -> (+ x y) 7 | )) 8 | 9 | (match ... with 10 | ... -> 11 | ... -> 12 | ) 13 | 14 | -------------------------------------------------------------------------------- /lib/basis.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; the kitchen sink 4 | 5 | (require "lib/core.scm") 6 | (require "lib/pair.scm") 7 | (require "lib/symbol.scm") 8 | (require "lib/string.scm") 9 | (require "lib/format.scm") 10 | (require "lib/sexp.scm") 11 | (require "lib/queue.scm") 12 | (require "lib/set.scm") 13 | (require "lib/alist.scm") 14 | (require "lib/stdio.scm") 15 | (%backend bytecode (require "lib/vmffi.scm")) 16 | (require "lib/ctype.scm") ;; needed by os & io. 17 | (require "lib/lisp_reader.scm") ;; needed by ctype 18 | (require "lib/os.scm") 19 | (require "lib/io.scm") 20 | (require "lib/frb.scm") 21 | (require "lib/enum.scm") 22 | (require "lib/metadata.scm") ;; access metadata 23 | (require "lib/reflection.scm") 24 | (require "lib/exception.scm") ;; upgrade the base exception handler. 25 | (require "lib/map.scm") 26 | -------------------------------------------------------------------------------- /lib/cmap.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; 'cmap' captures the common pattern of 'counting unique elements, 4 | ;; giving each an index starting at zero'. It provides forward and 5 | ;; reverse maps, and a counter. 6 | 7 | (define (cmap/make cmp) 8 | {map=(tree/empty) rev=(tree/empty) count=0 cmp=cmp} 9 | ) 10 | 11 | (define (cmap/add m item) 12 | (match (tree/member m.map m.cmp item) with 13 | (maybe:yes index) -> index 14 | (maybe:no) 15 | -> (let ((index m.count)) 16 | (tree/insert! m.map m.cmp item index) 17 | (tree/insert! m.rev int-cmp index item) 18 | (set! m.count (+ 1 m.count)) 19 | index))) 20 | 21 | (define (cmap/keys m) 22 | (tree/keys m.map)) 23 | 24 | (define (cmap/present? m item) 25 | (match (tree/member m.map m.cmp item) with 26 | (maybe:yes _) -> #t 27 | (maybe:no) -> #f 28 | )) 29 | 30 | (define (cmap->index m item) 31 | (match (tree/member m.map m.cmp item) with 32 | (maybe:yes index) -> index 33 | (maybe:no) -> (raise (:Cmap/KeyErrorItem item)) 34 | )) 35 | 36 | (define (cmap->item m index) 37 | (match (tree/member m.rev int-cmp index) with 38 | (maybe:yes item) -> item 39 | (maybe:no) -> (raise (:Cmap/KeyErrorIndex index)) 40 | )) 41 | -------------------------------------------------------------------------------- /lib/counter.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (make-counter init) 4 | (let ((value init)) 5 | 6 | (define (inc) 7 | (let ((r value)) 8 | (set! value (+ 1 value)) 9 | r)) 10 | 11 | (define (get) 12 | value) 13 | 14 | (define (dec) 15 | (let ((r value)) 16 | (set! value (- value 1)) 17 | r)) 18 | 19 | {inc=inc get=get dec=dec} 20 | )) 21 | -------------------------------------------------------------------------------- /lib/crypto/hkdf.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/crypto/hmac.scm") 4 | 5 | ;; RFC 5869 6 | 7 | (define (hkdf/make hash) 8 | 9 | (define (extract salt IKM) 10 | (let ((hmac0 (hmac/make hash)) 11 | (hmac1 (hmac0.make salt))) 12 | (hmac1.update IKM) 13 | (hmac1.final))) 14 | 15 | (define (expand PRK info L) 16 | (let ((N (how-many L hash.size)) 17 | (T '()) 18 | (Tn "")) 19 | (when (> N 255) 20 | (raise (:HKDF/Length-Too-Large))) 21 | (for-range i N 22 | (let ((hmac0 (hmac/make hash)) 23 | (hmac1 (hmac0.make PRK))) 24 | (hmac1.update Tn) 25 | (hmac1.update info) 26 | (hmac1.update (list->string (list (int->char (+ 1 i))))) 27 | (set! Tn (hmac1.final)) 28 | (push! T Tn))) 29 | ;; OKM 30 | (substring (string-concat (reverse T)) 0 L) 31 | )) 32 | 33 | (define (oneshot salt IKM info L) 34 | (expand (extract salt IKM) info L)) 35 | 36 | {extract=extract expand=expand oneshot=oneshot} 37 | ) 38 | 39 | (define hkdf/sha256 (hkdf/make sha256-hash)) 40 | (define hkdf/sha512 (hkdf/make sha512-hash)) 41 | -------------------------------------------------------------------------------- /lib/dfa/README.md: -------------------------------------------------------------------------------- 1 | # Regular Expression to DFA using Derivatives. 2 | 3 | See the paper ["Regular-expression derivatives reexamined"](https://www.mpi-sws.org/~turon/re-deriv.pdf) by Owens/Reppy/Turon. 4 | 5 | The 'derivative' of a regex is a new regex that results from the 6 | feeding of a single character/charset to the original regex. 7 | 8 | For example, if you feed ``a`` to ``abc``, you get ``bc``. 9 | If you feed ``a`` to ``a*b`` you get ``a*b`` again. 10 | 11 | Using this technique, you can build a DFA directly from the regex. 12 | The algorithm is elegant and simple. 13 | 14 | The main trick is to 'canonicalize' each resulting derivative so that 15 | we can tell when we've come across a derivative that we've already 16 | seen. 17 | 18 | As described in the paper, the resulting DFAs are often minimal or 19 | near-minimal. 20 | 21 | -------------------------------------------------------------------------------- /lib/dl.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require-ffi 'dl) 4 | 5 | (define (dlopen name) 6 | (let ((ztname (zero-terminate name)) 7 | (handle (dl/dlopen (cstring ztname) (logior RTLD_LAZY RTLD_LOCAL)))) 8 | (if (cref-null? handle) 9 | (raise (:DL/OpenFailed name)) 10 | handle))) 11 | 12 | (define (dlsym handle name) : ((cref void) string -> (cref void)) 13 | (let ((ztname (zero-terminate name)) 14 | (result (dl/dlsym handle (cstring ztname)))) 15 | (if (cref-null? result) 16 | (raise (:DL/SymFailed name)) 17 | result))) 18 | 19 | ;; note: extension is platform-specific. 20 | ;; (let ((hpng (dlopen "libpng.dylib"))) 21 | ;; (printn (dlsym hpng "png_get_copyright")) 22 | ;; ) 23 | ;; (dlsym-default "puts") 24 | -------------------------------------------------------------------------------- /lib/exception.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; hope: this will eventually grow into a debugger. 4 | ;; 5 | ;; to get there, we will need to extend `raise` to capture 6 | ;; the current continuation so it can be examined. 7 | 8 | (define (print-exception e) : ((rsum 'a) -> undefined) 9 | (let ((name (variant->name e))) 10 | (printf "Exception \"" (sym name) "\" raised.\n") 11 | (printf " values: ") 12 | (printn e) 13 | #u 14 | )) 15 | 16 | (define (print-exception-exit e) : ((rsum 'a) -> 'b) 17 | (print-exception e) 18 | (%exit #f -1) 19 | ) 20 | 21 | (set! *the-exception-handler* print-exception-exit) 22 | -------------------------------------------------------------------------------- /lib/malloc.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype malloc 4 | (:t int) 5 | ) 6 | 7 | ;; Features to consider: 8 | ;; * use a record to track whether a pointer is valid or not. 9 | ;; * track all valid pointers in a map. 10 | ;; * a macro that automatically frees all memory allocated 11 | ;; in that scope upon exit (i.e., a c++-style destructor) 12 | 13 | ;; Note: we treat addresses as integers here: this will fail if 14 | ;; the highest bit is set on the address. (which should be rare). 15 | (define (malloc size) 16 | (let ((addr (%%cexp (int -> int) "malloc((size_t)%0)" size))) 17 | (if (= addr 0) 18 | (raise (:MallocFailed)) 19 | (malloc:t addr)))) 20 | 21 | (define free 22 | (malloc:t r) 23 | -> (%%cexp (int -> undefined) "(free((void*)%0), IRK_UNDEFINED)" r) 24 | ) 25 | 26 | (define malloc/addr 27 | (malloc:t addr) -> addr 28 | ) 29 | -------------------------------------------------------------------------------- /lib/metadata.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; (metadata 4 | ;; (item0 data0 ...) 5 | ;; (item1 data1 ...) 6 | ;; ...) 7 | 8 | (define (fetch-metadata key) 9 | (define search-sexp-list 10 | key ((sexp:list ((sexp:symbol name) . data)) . tl) 11 | -> (if (eq? name key) 12 | data 13 | (search-sexp-list key tl)) 14 | key _ -> (raise (:Metadata/KeyError key)) 15 | ) 16 | (match (get-metadata) with 17 | (sexp:list ((sexp:symbol 'metadata) . items)) 18 | -> (search-sexp-list key items) 19 | x -> (raise (:Metadata/Malformed x)) 20 | )) 21 | 22 | (define the-variant-label-map #()) 23 | 24 | (define (build-variant-label-map) 25 | (let ((variants (fetch-metadata 'variants))) 26 | (set! the-variant-label-map (make-vector (length variants) "")) 27 | (let loop ((vls variants)) 28 | (match vls with 29 | ((sexp:list ((sexp:symbol name) (sexp:int tag))) . tl) 30 | -> (begin 31 | (set! the-variant-label-map[tag] name) 32 | (loop tl)) 33 | _ -> #u)) 34 | )) 35 | -------------------------------------------------------------------------------- /lib/parse/glextab.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; generated by demo/parse/lexgen from parse/meta-lex.sg 4 | ;; do not edit. 5 | 6 | (define table-g 7 | (let ( 8 | (t0 (rle (9 1) 2 3 (21 1) 2 (14 1) 4 (10 1) 7 8 (5 1) (26 9) (4 1) 9 1 (26 9) 1 10 (131 1))) 9 | (t1 (rle (256 1))) 10 | (t2 (rle (9 1) 2 3 (21 1) 2 (14 1) 4 (208 1))) 11 | (t3 (rle (9 1) (2 3) (21 1) 3 (223 1))) 12 | (t4 (rle (47 1) 5 (208 1))) 13 | (t5 (rle (10 5) 6 (245 5))) 14 | (t6 (rle (48 1) (10 9) (7 1) (26 9) (4 1) 9 1 (26 9) (133 1))) 15 | ) 16 | (list->vector (list t0 t1 t2 t3 t4 t5 t1 t1 t1 t6 t1)))) 17 | 18 | (define finals-g #( 19 | 'not-final 20 | '%%sink%% 21 | 'WHITESPACE 22 | 'WHITESPACE 23 | 'not-final 24 | 'not-final 25 | 'COMMENT 26 | 'COLON 27 | 'SEMICOLON 28 | 'NAME 29 | 'VBAR 30 | )) 31 | 32 | (define (step-g ch state) 33 | (%array-ref #f table-g[state] (char->ascii ch))) 34 | 35 | (define dfa-g {step=step-g table=table-g finals=finals-g}) 36 | -------------------------------------------------------------------------------- /lib/partial.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (defmacro partial 4 | (partial (arg ...)) 5 | -> (partial1 () (arg ...) ()) 6 | ) 7 | 8 | ;; scans for placeholders 9 | (defmacro partial1 10 | (partial1 (formal ...) () (exp ...)) 11 | -> (lambda (formal ...) (exp ...)) 12 | (partial1 (formal ...) (<_> args ...) (exp ...)) 13 | -> (partial1 (formal ... $x) (args ...) (exp ... $x)) 14 | (partial1 (formal ...) (arg args ...) (exp ...)) 15 | -> (partial1 (formal ...) (args ...) (exp ... arg)) 16 | ) 17 | 18 | ;; (partial (somefun _ 'arg _)) 19 | ;; => (lambda ($x0 $x1) (somefun $x0 'arg $x1)) 20 | ;; (map (partial (- _ 3)) (range 10)) 21 | ;; => (-3 -2 -1 0 1 2 3 4 5 6) 22 | ;; (map (partial (- 3 _)) (range 10)) 23 | ;; => (3 2 1 0 -1 -2 -3 -4 -5 -6) 24 | 25 | ;; would be nice, but I don't see a way to do it. 26 | ;; (partial (* _ (+ x _))) 27 | ;; we need a way to recursively walk the expression 28 | ;; while accumulating into a flat list of formals. 29 | 30 | (defmacro uncurry 31 | (uncurry (lambda (x ...) (lambda (y ...) body ...))) 32 | -> (lambda (x ... y ...) body ...) 33 | ) 34 | -------------------------------------------------------------------------------- /lib/posix.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; This should really go into lib/os.scm or somewhere like that. 4 | ;; *or* we put posix-only stuff here. 5 | 6 | (require-ffi 'posix) 7 | 8 | (define (uname) 9 | (let ((utsname* (malloc (struct utsname))) 10 | (_ (syscall (posix/uname utsname*))) 11 | (result 12 | {sysname = (get-cstring (%c-sref utsname.sysname utsname*)) 13 | nodename = (get-cstring (%c-sref utsname.nodename utsname*)) 14 | release = (get-cstring (%c-sref utsname.release utsname*)) 15 | version = (get-cstring (%c-sref utsname.version utsname*)) 16 | machine = (get-cstring (%c-sref utsname.machine utsname*))})) 17 | (free utsname*) 18 | result 19 | )) 20 | -------------------------------------------------------------------------------- /lib/random.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require-ffi 'posix) 4 | 5 | (define (random) 6 | (posix/random)) 7 | 8 | (define (srandom n) 9 | (posix/srandom n)) 10 | -------------------------------------------------------------------------------- /lib/stack.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; a simple stack 4 | 5 | (define (make-stack) 6 | (let ((l '())) 7 | (define (push x) 8 | (set! l (list:cons x l))) 9 | (define (pop) 10 | (match l with 11 | () -> (error "stack underflow") 12 | (hd . tl) 13 | -> (let ((result hd)) 14 | (set! l tl) 15 | result))) 16 | (define (get) l) 17 | (define (top) 18 | (match l with 19 | () -> (error "stack underflow") 20 | (hd . _) -> hd)) 21 | (define (stack-length) (length l)) 22 | {push=push pop=pop top=top get=get length=stack-length} 23 | )) 24 | 25 | -------------------------------------------------------------------------------- /lib/time.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require-ffi 'posix) 4 | 5 | (define (clock-gettime kind) 6 | (let ((ts* (halloc (struct timespec)))) 7 | (posix/clock_gettime kind ts*) 8 | {sec = (%c-get-int #f (%c-sref timespec.tv_sec ts*)) 9 | nsec = (%c-get-int #f (%c-sref timespec.tv_nsec ts*))} 10 | )) 11 | 12 | (define (timespec->nanoseconds ts) 13 | (+ (* ts.sec 1000000000) ts.nsec)) 14 | 15 | (define (gettime/monotonic) 16 | (clock-gettime CLOCK_MONOTONIC)) 17 | 18 | (define (gettime/realtime) 19 | (clock-gettime CLOCK_REALTIME)) 20 | 21 | (define (gettime/process) 22 | (clock-gettime CLOCK_PROCESS_CPUTIME_ID)) 23 | 24 | -------------------------------------------------------------------------------- /lib/urandom.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (urandom-make) 4 | (let ((fd (open "/dev/random" O_RDONLY 0))) 5 | (define (get n) 6 | (let ((bytes (read fd n))) 7 | (when (not (= (string-length bytes) n)) 8 | (raise (:Urandom/Underflow n))) 9 | bytes)) 10 | get 11 | )) 12 | -------------------------------------------------------------------------------- /notes/introspection.txt: -------------------------------------------------------------------------------- 1 | 2 | I'd like to provide some kind of introspection (with respect to types) 3 | at runtime. Now that I know how to use %%sexp in macros, this might 4 | be easier. 5 | 6 | --- aside --- 7 | | we need a real motivation for this other than xxx-repr, 8 | | because that could be auto-generated. 9 | 10 | I think we need two data structures at runtime: 11 | 12 | 1) a representation of type. 13 | 2) a representation of datatypes. 14 | 15 | Yah, it's confusing. 16 | 17 | When an expression has type `(tree int string)`, that is #1. 18 | But the definition of a tree is #2. 19 | 20 | We will need both to do full introspection at runtime. 21 | A possible goal here is to be able to print out objects 22 | without having to write `xxx-repr` and `xxx-print` funs. 23 | 24 | For #1, we need a special form that will generate a literal, just 25 | like with %%ffitype. 26 | 27 | For #2, we will need a runtime version of the datatype declaration. 28 | 29 | -------------------------------------------------------------------------------- /notes/metadata.txt: -------------------------------------------------------------------------------- 1 | # -*- Mode: Markdown -*- 2 | 3 | metadata 4 | -------- 5 | 6 | We need a way of attaching metadata of various kinds to the program. 7 | It needs to be accessible *by* the program. Examples include: 8 | 9 | datatypes with tags (for runtime reflection) 10 | polyvar names and tags (for exception printing) 11 | function names/address/pc/etc (for debugging) 12 | ctypes: can we subsume the current ctypes hack into this? 13 | 14 | The simplest way to do this is to use a map of s-expressions. we 15 | could have various functions at the top level grab this data and have 16 | it at the ready. For example, a vector of symbols would suffice to 17 | name every polyvar. Then getting the name for an exception would 18 | consist of looking up its tag and indexing into that table. 19 | 20 | -------------------------------------------------------------------------------- /self/bootstrap.byc: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/samrushing/irken-compiler/a36fc2ce3eccd19aa4e524091c44149472846af1/self/bootstrap.byc -------------------------------------------------------------------------------- /self/flags.scm: -------------------------------------------------------------------------------- 1 | 2 | (define CC "clang") 3 | (define CFLAGS "-std=c99 -O3 -fomit-frame-pointer -I./include") 4 | -------------------------------------------------------------------------------- /tests/dfa/t_dfa.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (include "lib/cmap.scm") 7 | (include "lib/counter.scm") 8 | (include "lib/dfa/charset.scm") 9 | (include "lib/dfa/rx.scm") 10 | (include "lib/dfa/deriv.scm") 11 | (include "lib/dfa/dfa.scm") 12 | (include "lib/dfa/emit.scm") 13 | 14 | (define (t0 regex) 15 | (let ((dfa (rx->dfa (parse-rx regex)))) 16 | ;;(print-dfa dfa) 17 | (dfa->dot dfa regex) 18 | )) 19 | 20 | ;(t0 "a|ba|c") 21 | ;(t0 "ab|ac") 22 | ;(t0 "(a+b*a+)") 23 | ;(t0 "a+b") 24 | ;(t0 ".*{a+b*a+}") 25 | ;(t0 ".*{a*}b") 26 | ;(t0 ".*({[A-Z][a-z]*}{[0-9]+}xy") 27 | ;(t0 ".*({Aa*}x") 28 | 29 | ;; experimenting with using groups for a lexer 30 | ;;(t0 "{cat}|{dog}") 31 | ;;(t0 "{cat}|{cape}") 32 | ;;(t0 "{[A-Za-z][A-Za-z_]*}|{[ \t\n]+}|{[0-9]+}") 33 | (t0 "{cat}|{dog}|{[A-Za-z][A-Za-z_]*}|{[0-9]+}") 34 | ;;(t0 "{a+}|{b+}") 35 | 36 | -------------------------------------------------------------------------------- /tests/dfa/t_rx.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/counter.scm") 6 | (include "lib/dfa/charset.scm") 7 | (include "lib/dfa/rx.scm") 8 | 9 | (printf (rx-repr (parse-rx "[A-Z]+")) "\n") 10 | (printf (rx-repr (parse-rx "(ab+)?")) "\n") 11 | (printf (rx-repr (parse-rx "a*bca*")) "\n") 12 | (printf (rx-repr (parse-rx "([abc]~)?[de]+")) "\n") 13 | (printf (rx-repr (parse-rx "[a-z]\\[0")) "\n") 14 | 15 | (let ((r0 (parse-rx "a+b*a+")) 16 | (r1 (parse-rx "a+b*a+"))) 17 | (printf "r0 < r1 = " (bool (rx< r0 r1)) "\n") 18 | (printf "r1 < r0 = " (bool (rx< r1 r0)) "\n") 19 | ) 20 | (let ((r0 (parse-rx "a+")) 21 | (r1 (parse-rx "a+"))) 22 | (printf "r0 < r1 = " (bool (rx< r0 r1)) "\n") 23 | (printf "r1 < r0 = " (bool (rx< r1 r0)) "\n") 24 | ) 25 | 26 | (printf (pp-rx (parse-rx "((ab)~c)~d*")) "\n") 27 | (printf (pp-rx (parse-rx "{(ab)~c}~d*")) "\n") 28 | -------------------------------------------------------------------------------- /tests/f0.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (+ a b) 3 | (%%cexp (int int -> int) "%0+%1" a b)) 4 | 5 | (+ 1 #\A) 6 | 7 | -------------------------------------------------------------------------------- /tests/f1.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (printn x) 3 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 4 | 5 | (define (+ a b) 6 | (%%cexp (int int -> int) "%0+%1" a b)) 7 | 8 | (define (z x) 9 | (vcase x 10 | ((:thing v) (+ v 1)))) 11 | 12 | ;;; OK. houston, we have a problem. this should fail. 13 | 14 | (let ((y (:thing #\A))) 15 | (printn (z y)) 16 | ) 17 | -------------------------------------------------------------------------------- /tests/f2.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (printn x) 3 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 4 | 5 | (define (+ a b) 6 | (%%cexp (int int -> int) "%0+%1" a b)) 7 | 8 | (define (z x) 9 | (+ x[0] 1)) 10 | 11 | (let ((y #(#\A #\B #\C))) 12 | (printn (z y)) 13 | ) 14 | -------------------------------------------------------------------------------- /tests/f3.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (printn x) 3 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 4 | 5 | (define (+ a b) 6 | (%%cexp (int int -> int) "%0+%1" a b)) 7 | 8 | (define (z x) 9 | (+ x.a 1)) 10 | 11 | (let ((y {a=#\A b=#\B})) 12 | (printn (z y)) 13 | ) 14 | -------------------------------------------------------------------------------- /tests/f4.scm: -------------------------------------------------------------------------------- 1 | 2 | ;;; OK. houston, we have a problem. this should fail. 3 | 4 | (define (z x) 5 | (vcase x 6 | ((:thing v) (%%cexp (int int -> int) "%0+%1" v 1)))) 7 | 8 | (let ((y (:thing #\A))) 9 | (z y)) 10 | 11 | -------------------------------------------------------------------------------- /tests/f_anno1.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype bool (:true) (:false)) 3 | 4 | (define (thing:(int -> int) x) 5 | 3) 6 | 7 | (thing #f) 8 | -------------------------------------------------------------------------------- /tests/f_anno2.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (thing:(char char -> {a=char b=int}) a b) 3 | {a=a b=b} 4 | ) 5 | 6 | (thing #\a #\b) 7 | 8 | -------------------------------------------------------------------------------- /tests/f_arity.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; type inference arity check 3 | 4 | (define (thing x y) 1) 5 | 6 | (thing 1) 7 | 8 | 9 | -------------------------------------------------------------------------------- /tests/f_datatype.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; fail to mix list(int) with list(bool) 3 | (list:cons #t (list:cons 4 (list:cons 5 (list:nil)))) 4 | -------------------------------------------------------------------------------- /tests/f_datatype0.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (nil) 4 | (cons 'a list) 5 | ) 6 | 7 | (let ((l0 (list:cons 4 (list:nil))) 8 | (l1 (list:cons #t (list:nil))) 9 | (l2 (list:cons "hey" (list:nil))) 10 | ) 11 | (set! l0 (list:cons #t l0)) 12 | l0 13 | ) 14 | -------------------------------------------------------------------------------- /tests/f_datatype6.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | ;; test records in datatypes 8 | 9 | ;; note that the '...' is missing, meaning that the 10 | ;; record type is closed. test and test2 attempts to 11 | ;; throw other stuff in should thus fail. 12 | 13 | (datatype thing 14 | (:t {x=int y=char}) 15 | ) 16 | 17 | (define (test) 18 | (thing:t {x=3 y=#\b z=9}) 19 | ) 20 | 21 | (define (test2) 22 | (thing:t {x=4 y=#\c z=#\a a=#t b=#f})) 23 | 24 | (printn (test)) 25 | (printn (test2)) 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /tests/f_gen1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/os.scm") 5 | 6 | (define (range-generator start stop) 7 | (make-generator 8 | (lambda (consumer) 9 | (let loop ((n start)) 10 | (if (= n stop) 11 | (forever (consumer (maybe:no))) 12 | (begin 13 | (consumer (maybe:yes n)) 14 | (loop (+ n 1)))))))) 15 | 16 | (for (range-generator 100 120) i 17 | (printf "i = " (char i) "\n")) 18 | -------------------------------------------------------------------------------- /tests/f_letpoly.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (:nil) 4 | (:cons 'a (list 'a)) 5 | ) 6 | 7 | (define (make-stack) 8 | (let ((l (list:nil))) 9 | (lambda (e) 10 | (set! l (list:cons e l))) 11 | )) 12 | 13 | (let ((is (make-stack)) 14 | (bs (make-stack))) 15 | (is 10) 16 | (bs #f) 17 | (is #f) 18 | ) 19 | -------------------------------------------------------------------------------- /tests/f_letpoly0.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (:nil) 4 | (:cons 'a (list 'a)) 5 | ) 6 | 7 | (let ((l (%dtcon/list/nil)) 8 | (is (lambda (e) 9 | (set! l (%dtcon/list/cons e l))))) 10 | (is 10) 11 | (is #f)) -------------------------------------------------------------------------------- /tests/f_match5.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (eq? a b) 3 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 4 | 5 | (define (error x) 6 | (%%cexp (-> 'a) "goto Lreturn") 7 | (%%cexp (-> 'a) "IRK_UNDEFINED") 8 | ) 9 | 10 | ;; without a default case this should raise a match error 11 | 12 | (define flip 13 | 0 -> 1 14 | 1 -> 0 15 | ;; x -> (error "flipped out!") 16 | ) 17 | 18 | (flip 0) 19 | -------------------------------------------------------------------------------- /tests/f_match6.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; should trigger a error for incomplete match 3 | 4 | (datatype bool (:true) (:false)) 5 | 6 | (datatype thing 7 | (:one) 8 | (:two) 9 | (:three) 10 | ) 11 | 12 | (define test 13 | (thing:one) -> #t 14 | (thing:two) -> #f 15 | ) 16 | 17 | (test (thing:three)) 18 | -------------------------------------------------------------------------------- /tests/f_overexhaustive.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (datatype thing 6 | (:one) 7 | (:two) 8 | (:three) 9 | ) 10 | 11 | (define test0 12 | (thing:one) -> 11 13 | (thing:two) -> 22 14 | (thing:three) -> 33 15 | _ -> 44 16 | ) 17 | 18 | (define test1 19 | (thing:one) -> 11 20 | (thing:two) -> 22 21 | _ -> 44 22 | ) 23 | 24 | (test0 (thing:one)) 25 | (test1 (thing:one)) 26 | -------------------------------------------------------------------------------- /tests/f_value_rest.scm: -------------------------------------------------------------------------------- 1 | ;; value restriction 2 | 3 | ;(datatype bool (:false) (:true)) 4 | 5 | (define (+ a b) 6 | (%%cexp (int int -> int) "%0+%1" a b)) 7 | 8 | (let ((id (lambda (x) x))) 9 | (set! id (lambda (x) (+ 1 x))) 10 | ;; shouldn't be able to add one to #t 11 | (id #t) 12 | ) 13 | -------------------------------------------------------------------------------- /tests/llvm/t_ll0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;(include "lib/core.scm") 4 | 5 | (define (^llvm-thing a b) 6 | 1924 7 | ) 8 | 9 | ;(printn (^llvm-thing 12 13)) 10 | (^llvm-thing 12 13) 11 | 12 | -------------------------------------------------------------------------------- /tests/llvm/t_ll1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype bool 4 | (:true) 5 | (:false) 6 | ) 7 | 8 | (define (printn x) 9 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 10 | 11 | (define boolvar #t) 12 | 13 | (define (^llvm-thing x) 14 | (if x 15 | 19 16 | 34)) 17 | 18 | (printn (^llvm-thing boolvar)) 19 | -------------------------------------------------------------------------------- /tests/llvm/t_ll3.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (^llvm-thing) 3 | (let ((x 19)) 4 | (set! x 34) 5 | x)) 6 | 7 | (^llvm-thing) 8 | -------------------------------------------------------------------------------- /tests/llvm/t_ll4.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (llvm-thing a b) 3 | (%%cexp (int int -> int) "%0+%1" a b) 4 | ;;(%plus #f a b) 5 | ) 6 | 7 | (llvm-thing 3 4) 8 | 9 | ;; plus: 10 | ;; %7 = and i64 %6, -2 11 | ;; %8 = ptrtoint i8* %3 to i64 12 | ;; %9 = add i64 %7, %8 13 | ;; %10 = or i64 %9, 1 14 | ;; %11 = inttoptr i64 %10 to i8** 15 | -------------------------------------------------------------------------------- /tests/llvm/t_ll5.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (printn '(1 2 3 a b)) 7 | 8 | 9 | -------------------------------------------------------------------------------- /tests/llvm/t_ll6.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (^llvm-thing) 4 | 1924 5 | ) 6 | 7 | (^llvm-thing) 8 | -------------------------------------------------------------------------------- /tests/llvm/t_ll7.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (+ a b) 4 | (%llarith add a b)) 5 | 6 | (define (- a b) 7 | (%llarith sub a b)) 8 | 9 | (define (> a b) 10 | (%llicmp ugt a b)) 11 | 12 | (define (>= a b) 13 | (%llicmp uge a b)) 14 | 15 | (define (< a b) 16 | (%llicmp ult a b)) 17 | 18 | (define (<= a b) 19 | (%llicmp ule a b)) 20 | 21 | (define (= a b) 22 | (%llicmp eq a b)) 23 | 24 | (define (+ a b) 25 | (%%cexp (int int -> int) "%0+%1" a b)) 26 | 27 | (define (> a b) 28 | (%%cexp (int int -> bool) "%0>%1" a b)) 29 | 30 | (define (^llvm-thing a b) 31 | ;;(< (- (+ 99 (+ a b)) 1) 150) 32 | (+ 33 | (if (< a b) 34 | 17 35 | 71) 36 | (if (= a 19) 37 | 27 38 | 37) 39 | )) 40 | 41 | (^llvm-thing 19 34) 42 | 43 | -------------------------------------------------------------------------------- /tests/llvm/t_ll8.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; (define (+ a b) 4 | ;; (%%cexp (int int -> int) "%0+%1" a b)) 5 | 6 | ;; (define (- a b) 7 | ;; (%%cexp (int int -> int) "%0-%1" a b)) 8 | 9 | (define (+ a b) 10 | (%llarith add a b)) 11 | 12 | (define (- a b) 13 | (%llarith sub a b)) 14 | 15 | (define (^llvm-x a) 16 | (let ((b (+ a 3)) 17 | (c (+ b 9))) 18 | (- b c))) 19 | 20 | (^llvm-x 19) 21 | -------------------------------------------------------------------------------- /tests/llvm/t_ll9.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; (define (+ a b) 4 | ;; (%%cexp (int int -> int) "%0+%1" a b)) 5 | 6 | ;; (define (- a b) 7 | ;; (%%cexp (int int -> int) "%0-%1" a b)) 8 | 9 | (define (+ a b) 10 | (%llarith add a b)) 11 | 12 | (define (- a b) 13 | (%llarith sub a b)) 14 | 15 | (define (= a b) 16 | (%llicmp eq a b)) 17 | 18 | (define (^llvm-x a) 19 | (if (= a 0) 20 | #\X 21 | (^llvm-x (- a 1)))) 22 | 23 | (^llvm-x 100) 24 | -------------------------------------------------------------------------------- /tests/llvm/t_lla.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype color (:red) (:green) (:blue)) 4 | 5 | (define (^llvm-x) 6 | (color:green) 7 | ) 8 | 9 | (^llvm-x) 10 | -------------------------------------------------------------------------------- /tests/llvm/t_llb.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | 4 | (define (^llvm-x) 5 | (:thing) 6 | ) 7 | 8 | (^llvm-x) 9 | -------------------------------------------------------------------------------- /tests/llvm/t_llc.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | 4 | (define (^llvm-x) 5 | (:thing 3) 6 | ) 7 | 8 | (^llvm-x) 9 | -------------------------------------------------------------------------------- /tests/llvm/t_lld.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (+ a b) 4 | (%llarith add a b)) 5 | 6 | (define (- a b) 7 | (%llarith sub a b)) 8 | 9 | (define (^llvm-a a) 10 | (+ a 3)) 11 | 12 | (define (^llvm-b b c) 13 | (^llvm-a (+ b (- c 1)))) 14 | 15 | (^llvm-b 3 4) 16 | -------------------------------------------------------------------------------- /tests/llvm/t_lle.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (+ a b) 4 | (%llarith add a b)) 5 | 6 | (define (- a b) 7 | (%llarith sub a b)) 8 | 9 | (define (1- a) 10 | (%llarith sub a 1)) 11 | 12 | (define x 33) 13 | 14 | (define (^llvm-x) 15 | x) 16 | 17 | (define (^llvm-a a) 18 | (+ a 3)) 19 | 20 | ;; (define (^llvm-b b c) 21 | ;; (+ (^llvm-x) 22 | ;; (1- (^llvm-a (+ b (- c 1)))) 23 | ;; )) 24 | 25 | (define (^llvm-b) 26 | (+ (+ (^llvm-x) 27 | (^llvm-x)) 28 | (^llvm-x))) 29 | 30 | (^llvm-b) 31 | -------------------------------------------------------------------------------- /tests/llvm/t_llf.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype X 4 | (:r int int) 5 | (:g int) 6 | (:b) 7 | ) 8 | 9 | (define (^llvm-x) 10 | (X:r 19 27) 11 | ) 12 | 13 | (^llvm-x) 14 | -------------------------------------------------------------------------------- /tests/llvm/t_llg.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype list 4 | (:cons 'a (list 'a)) 5 | (:nil) 6 | ) 7 | 8 | (define (eq? a b) 9 | (%llicmp eq a b)) 10 | 11 | (define (- a b) 12 | (%llarith sub a b)) 13 | 14 | (define ^llvm-N 15 | 0 acc -> acc 16 | n acc -> (^llvm-N (- n 1) (list:cons n acc)) 17 | ) 18 | 19 | (^llvm-N 10 '()) 20 | -------------------------------------------------------------------------------- /tests/llvm/t_llh.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype list 4 | (:cons 'a (list 'a)) 5 | (:nil) 6 | ) 7 | 8 | (define (= a b) 9 | (%llicmp eq a b)) 10 | 11 | (define (- a b) 12 | (%llarith sub a b)) 13 | 14 | (define (^llvm-N n acc) 15 | (if (= n 0) 16 | acc 17 | (^llvm-N (- n 1) (list:cons n acc)))) 18 | 19 | (^llvm-N 10 '()) 20 | -------------------------------------------------------------------------------- /tests/llvm/t_lli.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (+ a b) 4 | (%llarith add a b)) 5 | 6 | ;(define (+ a b) 7 | ; (%%cexp (int int -> int) "%0+%1" a b)) 8 | 9 | (define (^llvm-x a) 10 | (lambda (b) 11 | (+ a b)) 12 | ) 13 | 14 | ((^llvm-x 19) 3) 15 | 16 | -------------------------------------------------------------------------------- /tests/llvm/t_llj.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (+ a b) 4 | (%llarith add a b)) 5 | 6 | ;(define (+ a b) 7 | ; (%%cexp (int int -> int) "%0+%1" a b)) 8 | 9 | (define (^llvm-x a) 10 | (define (x b) 11 | (+ a b)) 12 | x) 13 | 14 | ((^llvm-x 19) 3) 15 | 16 | -------------------------------------------------------------------------------- /tests/llvm/t_llk.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype list 4 | (:nil) 5 | (:cons 'a (list 'a)) 6 | ) 7 | 8 | 9 | (define (^llvm-x) '("thing1" "thing2")) 10 | 11 | (^llvm-x) 12 | 13 | 14 | -------------------------------------------------------------------------------- /tests/llvm/t_lll.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype list 4 | (:nil) 5 | (:cons 'a (list 'a)) 6 | ) 7 | 8 | ;(define (+ a b) 9 | ; (%%cexp (int int -> int) "%0+%1" a b)) 10 | 11 | (define (+ a b) 12 | (%llarith add a b)) 13 | 14 | (define ^llvm-len 15 | () acc -> acc 16 | (_ . tl) acc -> (^llvm-len tl (+ 1 acc)) 17 | ) 18 | 19 | (^llvm-len '(1 2 3 4 5) 0) 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /tests/llvm/t_llm.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (printn x) 4 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 5 | 6 | (datatype thing 7 | (:a int) 8 | (:b int) 9 | (:c int) 10 | ) 11 | 12 | (define (+ a b) 13 | (%llarith add a b)) 14 | 15 | (define ^llvm-x 16 | (thing:a n) -> (+ 1 n) 17 | (thing:b n) -> 34 18 | (thing:c n) -> (+ n 2) 19 | ) 20 | 21 | (printn (^llvm-x (thing:a 3))) 22 | (printn (^llvm-x (thing:b 3))) 23 | (printn (^llvm-x (thing:c 3))) 24 | 25 | 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /tests/llvm/t_lln.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (printn x) 4 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 5 | 6 | (define (+ a b) 7 | (%llarith add a b)) 8 | 9 | (define ^llvm-x 10 | (:a n) -> (+ 1 n) 11 | (:b n) -> 34 12 | (:c n) -> (+ n 2) 13 | ) 14 | 15 | (printn (^llvm-x (:a 3))) 16 | (printn (^llvm-x (:b 3))) 17 | (printn (^llvm-x (:c 3))) 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /tests/llvm/t_llo.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (^llvm-mv) 4 | (%make-vector #f 10 0) 5 | ) 6 | 7 | (^llvm-mv) 8 | 9 | -------------------------------------------------------------------------------- /tests/llvm/t_llp.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (^llvm-mv) 4 | (let ((v (%make-vector #f 10 0))) 5 | v[5])) 6 | 7 | (^llvm-mv) 8 | 9 | -------------------------------------------------------------------------------- /tests/llvm/t_llq.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (= a b) 4 | (%llicmp eq a b)) 5 | 6 | (define (+ a b) 7 | (%llarith add a b)) 8 | 9 | (define (- a b) 10 | (%llarith sub a b)) 11 | 12 | (define (^llvm-mv) 13 | (let ((v (%make-vector #f 10 0))) 14 | (for-range i 10 15 | (set! v[i] (- 10 i))) 16 | v)) 17 | 18 | (^llvm-mv) 19 | 20 | -------------------------------------------------------------------------------- /tests/llvm/t_llr.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (= a b) 4 | (%llicmp eq a b)) 5 | 6 | (define (+ a b) 7 | (%llarith add a b)) 8 | 9 | (define (- a b) 10 | (%llarith sub a b)) 11 | 12 | (define (^llvm-mv r) 13 | (+ r.x r.z) 14 | ) 15 | 16 | (define (printn x) 17 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 18 | 19 | ;; creating this similar record forces the use of lookup_field(). 20 | (define thing {x=3 y="fnord" z=8 a=12}) 21 | 22 | (printn thing) 23 | 24 | (^llvm-mv {x=3 y="testing" z=7}) 25 | 26 | -------------------------------------------------------------------------------- /tests/llvm/t_lls.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (= a b) 4 | (%llicmp eq a b)) 5 | 6 | (define (+ a b) 7 | (%llarith add a b)) 8 | 9 | (define (- a b) 10 | (%llarith sub a b)) 11 | 12 | (define (^llvm-mv r) 13 | (set! r.x (+ r.x 1)) 14 | (+ r.x r.z) 15 | ) 16 | 17 | (define (printn x) 18 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 19 | 20 | ;; creating this similar record forces the use of lookup_field(). 21 | (define thing {x=3 y="fnord" z=8 a=12}) 22 | 23 | (printn thing) 24 | 25 | (^llvm-mv {x=3 y="testing" z=7}) 26 | 27 | -------------------------------------------------------------------------------- /tests/llvm/t_llt.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (^llvm-mv r) 4 | (set! r.x 1934) 5 | r 6 | ) 7 | 8 | (^llvm-mv {x=3 y="testing" z=7}) 9 | 10 | -------------------------------------------------------------------------------- /tests/llvm/t_llu.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (^llvm-mv r) 4 | (%call (DO ('a -> undefined)) r)) 5 | 6 | (^llvm-mv {x=3 y="testing" z=7}) 7 | -------------------------------------------------------------------------------- /tests/llvm/t_llv.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (^llvm-mv r) 4 | (%%ffi DO ('a -> undefined) r) 5 | r) 6 | 7 | (^llvm-mv {x=3 y="testing" z=7}) 8 | -------------------------------------------------------------------------------- /tests/llvm/t_llw.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (^llvm-x n) 4 | (%%ffi putchar (int -> undefined) n) 5 | n 6 | ) 7 | 8 | (^llvm-x 65) 9 | 10 | -------------------------------------------------------------------------------- /tests/llvm/tak20-llvm.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; Tak, the Hideous New Girl! 4 | 5 | (define (>= a b) 6 | (%llicmp uge a b)) 7 | 8 | (define (- a b) 9 | (%llarith sub a b)) 10 | 11 | (define (zero? a) 12 | (%llicmp eq a 0)) 13 | 14 | (define (tak x y z) 15 | (if (>= y x) 16 | z 17 | (tak (tak (- x 1) y z) 18 | (tak (- y 1) z x) 19 | (tak (- z 1) x y)))) 20 | 21 | (let loop ((n 20)) 22 | (let ((r (tak 18 12 6))) 23 | (if (zero? n) 24 | r 25 | (loop (- n 1))))) 26 | -------------------------------------------------------------------------------- /tests/manboy.exp: -------------------------------------------------------------------------------- 1 | -67 2 | -------------------------------------------------------------------------------- /tests/manboy.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; https://en.wikipedia.org/wiki/Man_or_boy_test 4 | 5 | (include "lib/core.scm") 6 | 7 | (define (A k x1 x2 x3 x4 x5) 8 | (define (B) 9 | (set! k (- k 1)) 10 | (A k B x1 x2 x3 x4)) 11 | (if (<= k 0) 12 | (+ (x4) (x5)) 13 | (B))) 14 | 15 | (printn 16 | (A 10 17 | (lambda () 1) 18 | (lambda () -1) 19 | (lambda () -1) 20 | (lambda () 1) 21 | (lambda () 0) 22 | )) 23 | -------------------------------------------------------------------------------- /tests/parse/t_earley.exp: -------------------------------------------------------------------------------- 1 | (E (E (E (E (T (T (P {ident:a})) {*:*} (P {ident:b}))) {+:+} (T (T (P {ident:c})) {*:*} (P {ident:d}))) {+:+} (T (P {ident:e}))) {+:+} (T (P {ident:f}))) 2 | (E 3 | (E 4 | (E 5 | (E 6 | (T (T (P (ident "a"))) (* "*") (P (ident "b")))) 7 | (+ "+") 8 | (T (T (P (ident "c"))) (* "*") (P (ident "d")))) 9 | (+ "+") 10 | (T (P (ident "e")))) 11 | (+ "+") 12 | (T (P (ident "f")))) 13 | #u 14 | -------------------------------------------------------------------------------- /tests/parse_0.py: -------------------------------------------------------------------------------- 1 | thing (1, arg (2, barney), arg ("testing"), fred, jim()) 2 | blord (gronk (blah (jack (jill)))) 3 | 4 | -------------------------------------------------------------------------------- /tests/parse_2.py: -------------------------------------------------------------------------------- 1 | def thing (a, b): 2 | for x, y in z: 3 | x = x + y 4 | break 5 | else: 6 | raise Glerk() 7 | c = a / b 8 | while 1: 9 | break 10 | if True: 11 | return 12 12 | elif False: 13 | return 13 14 | else: 15 | return 14 16 | return c + 12 17 | 18 | zinger = lambda x: x 19 | -------------------------------------------------------------------------------- /tests/t0.exp: -------------------------------------------------------------------------------- 1 | 41 2 | -------------------------------------------------------------------------------- /tests/t0.scm: -------------------------------------------------------------------------------- 1 | (define (+ a b) 2 | (%%cexp (int int -> int) "%0+%1" a b)) 3 | 4 | (define (thing z) 5 | (+ 3 (%raccess/left z))) 6 | 7 | (let ((x (%rextend/right (%rextend/left (%rmake) 19) #\A))) 8 | (let ((y (%rextend/right (%rmake) (lambda (x) x)))) 9 | (+ (%raccess/left x) (thing x)))) 10 | -------------------------------------------------------------------------------- /tests/t1.exp: -------------------------------------------------------------------------------- 1 | 22 2 | -------------------------------------------------------------------------------- /tests/t1.scm: -------------------------------------------------------------------------------- 1 | (define (+ a b) 2 | (%%cexp (int int -> int) "%0+%1" a b)) 3 | 4 | (define (thing m) 5 | (+ 3 m.left)) 6 | 7 | (let ((x {right=#\A left=19})) 8 | (let ((y {right=(lambda (c) c)})) 9 | (let ((z y.right)) 10 | (z (z (thing x)))))) 11 | -------------------------------------------------------------------------------- /tests/t10.exp: -------------------------------------------------------------------------------- 1 | 2 2 | -------------------------------------------------------------------------------- /tests/t10.scm: -------------------------------------------------------------------------------- 1 | (let ((x (:fnord 0 1 2))) 2 | (vcase x 3 | ((:fnord a b c) c))) 4 | -------------------------------------------------------------------------------- /tests/t11.exp: -------------------------------------------------------------------------------- 1 | 9 2 | 39 3 | 666 4 | 9 5 | 42 6 | 666 7 | 9 8 | 42 9 | 4242 10 | #u 11 | -------------------------------------------------------------------------------- /tests/t11.scm: -------------------------------------------------------------------------------- 1 | ;; give a good workout to variant case, including don't-care binding, inlining, etc.. 2 | 3 | (define (printn x) 4 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 5 | 6 | (define (+ a b) 7 | (%%cexp (int int -> int) "%0+%1" a b)) 8 | 9 | (define (glort0 a) 10 | (vcase a 11 | ((:blurb x) x) 12 | ((:blort a b c) (+ a (+ b c))) 13 | ((:urk) 666))) 14 | 15 | (define (glort1 a) 16 | (vcase a 17 | ((:blurb x) x) 18 | ((:blort _ _ _ ) 42) 19 | ((:urk) 666))) 20 | 21 | (define (glort2 a) 22 | (vcase a 23 | ((:blurb x) x) 24 | ((:blort _ _ _ ) 42) 25 | (else 4242))) 26 | 27 | (let ((x (:blurb 9)) 28 | (y (:blort 12 13 14)) 29 | (z (:urk)) 30 | ) 31 | (printn (glort0 x)) 32 | (printn (glort0 y)) 33 | (printn (glort0 z)) 34 | (printn (glort1 x)) 35 | (printn (glort1 y)) 36 | (printn (glort1 z)) 37 | (printn (glort2 x)) 38 | (printn (glort2 y)) 39 | (printn (glort2 z)) 40 | ) 41 | -------------------------------------------------------------------------------- /tests/t12.exp: -------------------------------------------------------------------------------- 1 | 20 2 | -------------------------------------------------------------------------------- /tests/t12.scm: -------------------------------------------------------------------------------- 1 | ((lambda () 20)) 2 | -------------------------------------------------------------------------------- /tests/t13.exp: -------------------------------------------------------------------------------- 1 | {u0 12 13 14} 2 | -------------------------------------------------------------------------------- /tests/t13.scm: -------------------------------------------------------------------------------- 1 | (let ((x (:blurb)) 2 | (y (:blurb 12 13 14))) 3 | y) -------------------------------------------------------------------------------- /tests/t14.exp: -------------------------------------------------------------------------------- 1 | {u0 #t 3 (1 2 3 1 2 3) (0 1 2 3 4 5 6 7 8 9) ("five" "five" "five" "five" "five") (9 8 7 6 5 4 3 2 1 0)} 2 | -------------------------------------------------------------------------------- /tests/t14.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | 5 | (let ((l (cons 1 (cons 2 (cons 3 (list:nil)))))) 6 | (let ((t0 (member? 3 l =)) 7 | (t1 (length l)) 8 | (t2 (append l l)) 9 | (t3 (range 10)) 10 | (t4 (n-of 5 "five")) 11 | (t5 (reverse t3)) 12 | ) 13 | {a=t0 b=t1 c=t2 d=t3 e=t4 f=t5})) 14 | -------------------------------------------------------------------------------- /tests/t15.exp: -------------------------------------------------------------------------------- 1 | 19 2 | {u0 {u0 1 "two" #f} 414777680} 3 | #u 4 | -------------------------------------------------------------------------------- /tests/t15.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; tests cexp type decls 3 | 4 | (datatype bool (:true) (:false)) 5 | 6 | (define (printn x) 7 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 8 | 9 | (define (random) 10 | (%%cexp (-> int) "random()")) 11 | 12 | (define (srandom n) 13 | (%%cexp (int -> undefined) "(srandom (%0), IRK_UNDEFINED)" n)) 14 | 15 | (define (fun p) 16 | ;; takes and returns an identity function 17 | (%%cexp (('a -> 'a) -> ('a -> 'a)) "%0" p)) 18 | 19 | (let ((x {a=1 b="two" c=#f})) 20 | ;; so we get repeatable results 21 | (srandom 314159) 22 | ;; pass our identity function through then apply it 23 | (printn ((fun (lambda (x) x)) 19)) 24 | (printn (:thing x (random)))) 25 | -------------------------------------------------------------------------------- /tests/t17.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype bool (:true) (:false)) 3 | 4 | (define (random) 5 | (%%cexp (-> int) "random()")) 6 | 7 | ;; hmmm... think about defining a *boxed* (rather than tagged) type that will 8 | ;; hold a pointer. [or maybe better... consider switching to untagged ints 9 | ;; and having something like a 'stack map' for the gc that knows the type 10 | ;; of everything on the stack] 11 | 12 | (define (malloc n) 13 | (%%cexp (int -> int) "(pxll_int)malloc(%0)" n)) 14 | 15 | (define (free n) 16 | (%%cexp (int -> undefined) "free((void*)%0); IRK_UNDEFINED" n)) 17 | 18 | (define (write-int p n) 19 | (%%cexp (int int -> undefined) "(*(pxll_int *)(%0)) = %1" p n)) 20 | 21 | (define (read-int p) 22 | (%%cexp (int -> int) "(*(pxll_int *)(%0))" p)) 23 | 24 | (define (printn x) 25 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 26 | 27 | (define (sizeof-int) 28 | (%%cexp (-> int) "sizeof(pxll_int)")) 29 | 30 | (let ((x 3) 31 | (y (malloc 16))) 32 | (set! x (random)) 33 | (printn y) 34 | (write-int y 3141) 35 | (printn (read-int y)) 36 | (free y) 37 | (printn (sizeof-int)) 38 | #t 39 | ) 40 | 41 | -------------------------------------------------------------------------------- /tests/t18.exp: -------------------------------------------------------------------------------- 1 | {u0 #("id" "while" "begin" "end" "if" "then") 6} 2 | -------------------------------------------------------------------------------- /tests/t18.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; bring vectors back from the dead 4 | 5 | (let ((x #(1 2 3 4 5 6 7 8 9)) 6 | (y #("id" "while" "begin" "end" "if" "then")) 7 | ) 8 | (:pair y x[5])) 9 | -------------------------------------------------------------------------------- /tests/t19.exp: -------------------------------------------------------------------------------- 1 | 6 2 | -1 3 | 1 4 | -3 5 | 3 6 | howdy 7 | howdy 8 | testing 9 | #(florb testing grok urk) 10 | "sam" 11 | -------------------------------------------------------------------------------- /tests/t19.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/frb.scm") 3 | (include "lib/pair.scm") 4 | (include "lib/string.scm") 5 | (include "lib/symbol.scm") 6 | 7 | (printn (string-length "howdyx")) 8 | (printn (string-compare "howdy" "howdyx")) 9 | (printn (string-compare "howdyx" "howdy")) 10 | (printn (string-compare "abc" "defghijkl")) 11 | (printn (string-compare "defghijkl" "abc")) 12 | 13 | (printn (string->symbol "howdy")) 14 | (printn (string->uninterned-symbol "howdy")) 15 | (printn (string->symbol "testing")) 16 | (printn #('florb 'testing 'grok 'urk)) 17 | 18 | (list->string (string->list "sam")) 19 | -------------------------------------------------------------------------------- /tests/t2.scm: -------------------------------------------------------------------------------- 1 | (define (+ a b) 2 | (%%cexp (int int -> int) "%0+%1" a b)) 3 | 4 | (define (thing x) 5 | x.add2) 6 | 7 | (let ((ob0 {add2=(lambda (x) (+ x 2))}) 8 | (th (thing ob0)) 9 | (ob1 {add2=34}) 10 | (xy (thing ob1))) 11 | (th xy)) 12 | 13 | -------------------------------------------------------------------------------- /tests/t21.scm: -------------------------------------------------------------------------------- 1 | ;; file i/o 2 | 3 | ;; XXX needs to catch errors 4 | 5 | (include "lib/core.scm") 6 | (include "lib/pair.scm") 7 | (include "lib/string.scm") 8 | (include "lib/io.scm") 9 | 10 | ;; copy file to stdout 11 | (let ((f (file/open-read "gc.c"))) 12 | (let loop ((buffer (file/read-buffer f))) 13 | (cond ((> (string-length buffer) 0) 14 | (write 1 buffer) 15 | (loop (file/read-buffer f))))) 16 | (file/close f)) 17 | 18 | ;; read a few characters... 19 | (let ((f (file/open-read "gc.c"))) 20 | (let loop ((n 10)) 21 | (cond ((= n 0) #t) 22 | (else 23 | (printn (file/read-char f)) 24 | (loop (- n 1))))) 25 | (file/close f)) 26 | 27 | ;; write a file by chars... 28 | (let ((f (file/open-write "thing.txt" #t #o644))) 29 | ;;(print-string "fd=") (printn f.fd) 30 | (file/write-char f #\H) 31 | (file/write-char f #\o) 32 | (file/write-char f #\w) 33 | (file/write-char f #\d) 34 | (file/write-char f #\y) 35 | (file/write-char f #\newline) 36 | (file/flush f) 37 | (file/close f) 38 | ) 39 | 40 | -------------------------------------------------------------------------------- /tests/t22.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; maybe one way of doing OO-like stuff using records? 3 | 4 | (include "lib/core.scm") 5 | (include "lib/pair.scm") 6 | 7 | (define (make-counter) 8 | (let ((val 0)) 9 | (define (next) 10 | (let ((r val)) 11 | (set! val (+ val 1)) 12 | r) 13 | ) 14 | {next=next} 15 | )) 16 | 17 | (define (n-counters n) 18 | (let loop ((n n) (l (list:nil))) 19 | (if (zero? n) 20 | l 21 | (loop (- n 1) (list:cons (make-counter) l))))) 22 | 23 | (printn (n-counters 5)) 24 | 25 | (let ((x (make-counter)) 26 | (y (make-counter))) 27 | (printn (x.next)) 28 | (printn (x.next)) 29 | (printn (x.next)) 30 | (printn (x.next)) 31 | (printn (x.next)) 32 | (printn (x.next)) 33 | (printn (y.next)) 34 | (printn (y.next)) 35 | (printn (y.next)) 36 | (printn (y.next)) 37 | (printn (y.next)) 38 | (printn (y.next)) 39 | ) 40 | -------------------------------------------------------------------------------- /tests/t23.exp: -------------------------------------------------------------------------------- 1 | #\eof 2 | -------------------------------------------------------------------------------- /tests/t23.scm: -------------------------------------------------------------------------------- 1 | ;; tests constants brought through from C 2 | 3 | (cinclude "fcntl.h") 4 | 5 | (define O_RDONLY (%%cexp int "O_RDONLY")) 6 | (define O_WRONLY (%%cexp int "O_WRONLY")) 7 | (define O_RDWR (%%cexp int "O_RDWR")) 8 | 9 | (let ((x O_RDONLY) 10 | (y #\eof) 11 | ) 12 | y) 13 | -------------------------------------------------------------------------------- /tests/t24.exp: -------------------------------------------------------------------------------- 1 | 21 2 | 12 3 | #u 4 | -------------------------------------------------------------------------------- /tests/t24.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (printn x) 3 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 4 | 5 | (define (+ a b) 6 | (%%cexp (int int -> int) "%0+%1" a b)) 7 | 8 | (define (other-thing x y z) 9 | (+ x (+ y z))) 10 | 11 | (define (thing a) 12 | (other-thing a.x a.y a.z)) 13 | 14 | (printn (thing {a=9 x=8 y=7 z=6})) 15 | (printn (thing {x=3 y=4 z=5})) 16 | 17 | -------------------------------------------------------------------------------- /tests/t25.exp: -------------------------------------------------------------------------------- 1 | 16 2 | -------------------------------------------------------------------------------- /tests/t25.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (+ a b) 3 | (%%cexp (int int -> int) "%0+%1" a b)) 4 | 5 | (let ((x (+ 3 4))) 6 | (+ 9 x)) 7 | -------------------------------------------------------------------------------- /tests/t26.exp: -------------------------------------------------------------------------------- 1 | #\A 2 | -------------------------------------------------------------------------------- /tests/t26.scm: -------------------------------------------------------------------------------- 1 | 2 | (let ((y {b=(lambda (x) x)})) 3 | (let ((id y.b)) 4 | (id #\A))) 5 | -------------------------------------------------------------------------------- /tests/t27.exp: -------------------------------------------------------------------------------- 1 | 19 2 | -------------------------------------------------------------------------------- /tests/t27.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (id x) x) 3 | 4 | (let ((x 19) 5 | (y (id #\A)) 6 | ) 7 | ((id id) (id x))) 8 | 9 | 10 | -------------------------------------------------------------------------------- /tests/t28.exp: -------------------------------------------------------------------------------- 1 | #((1 2 3 4) (1 2 3)) 2 | -------------------------------------------------------------------------------- /tests/t28.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | ;; vector and list literals 4 | #('(1 2 3 4) '(1 2 3)) 5 | -------------------------------------------------------------------------------- /tests/t3.scm: -------------------------------------------------------------------------------- 1 | (datatype bool (:true) (:false)) 2 | (let ((ob {left={left=19 middle=18 right=20} right=#f})) 3 | ob.left.left) 4 | -------------------------------------------------------------------------------- /tests/t30.exp: -------------------------------------------------------------------------------- 1 | 3 2 | -------------------------------------------------------------------------------- /tests/t30.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; polymorphic variant lists 3 | 4 | (define (+ a b) 5 | (%%cexp (int int -> int) "%0+%1" a b)) 6 | 7 | (define (length l) 8 | (let loop ((l l) 9 | (n 0)) 10 | (vcase l 11 | ((:nil) n) 12 | ((:cons _ tl) 13 | (loop tl (+ n 1)))))) 14 | 15 | (let ((l (:cons 1 (:cons 2 (:cons 3 (:nil)))))) 16 | (length l)) 17 | -------------------------------------------------------------------------------- /tests/t35.exp: -------------------------------------------------------------------------------- 1 | 19 2 | #\A 3 | #u 4 | -------------------------------------------------------------------------------- /tests/t35.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (printn x) 3 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 4 | 5 | (let () 6 | (printn 19) 7 | (printn #\A)) 8 | -------------------------------------------------------------------------------- /tests/t37.exp: -------------------------------------------------------------------------------- 1 | 4 2 | -------------------------------------------------------------------------------- /tests/t37.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (+ a b) 3 | (%%cexp (int int -> int) "%0+%1" a b)) 4 | 5 | (define (thing r) 6 | (let ((x r.x) 7 | (z r.z) 8 | ) 9 | (+ x z))) 10 | 11 | (thing {x=1 z=3}) 12 | -------------------------------------------------------------------------------- /tests/t38.exp: -------------------------------------------------------------------------------- 1 | {u0 thingy glorb drone} 2 | -------------------------------------------------------------------------------- /tests/t38.scm: -------------------------------------------------------------------------------- 1 | (include "lib/basis.scm") 2 | 3 | {x='thingy y='glorb z='drone} 4 | -------------------------------------------------------------------------------- /tests/t39.exp: -------------------------------------------------------------------------------- 1 | {u0 3 1} 2 | -------------------------------------------------------------------------------- /tests/t4.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype bool (:true) (:false)) 3 | 4 | (define (printn x) 5 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 6 | 7 | (define (bigger z n) 8 | (%rextend/c z n)) 9 | 10 | (let ((x {a=1 b=#t}) 11 | (y (bigger x 34))) 12 | (printn x) 13 | (printn y) 14 | (let ((z (bigger y 19))) 15 | (printn z))) 16 | 17 | -------------------------------------------------------------------------------- /tests/t42.exp: -------------------------------------------------------------------------------- 1 | 42 2 | 43 3 | 44 4 | 45 5 | 46 6 | 47 7 | 48 8 | #u 9 | -------------------------------------------------------------------------------- /tests/t42.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (define (make-int-generator n) 5 | (make-generator 6 | (lambda (consumer) 7 | (let loop ((n n)) 8 | (consumer n) 9 | (loop (+ n 1)))))) 10 | 11 | (let ((g (make-int-generator 42))) 12 | (printn (g)) 13 | (printn (g)) 14 | (printn (g)) 15 | (printn (g)) 16 | (printn (g)) 17 | (printn (g)) 18 | (printn (g)) 19 | ) 20 | -------------------------------------------------------------------------------- /tests/t43.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (typealias thing int) 4 | 5 | (datatype blob 6 | (:one thing thing) 7 | (:two thing thing) 8 | ) 9 | 10 | (blob:one 42 0) 11 | ;43 12 | -------------------------------------------------------------------------------- /tests/t5.scm: -------------------------------------------------------------------------------- 1 | (define (- a b) 2 | (%%cexp (int int -> int) "%0-%1" a b)) 3 | 4 | (define (+ a b) 5 | (%%cexp (int int -> int) "%0+%1" a b)) 6 | 7 | (define (= a b) 8 | (%%cexp (int int -> bool) "%0==%1" a b)) 9 | 10 | (if (= 3 4) 11 | (+ 2 3) 12 | (- 2 3)) -------------------------------------------------------------------------------- /tests/t6_2.scm: -------------------------------------------------------------------------------- 1 | (define (- a b) 2 | (%%cexp (int int -> int) "%0-%1" a b)) 3 | 4 | (define (= a b) 5 | (%%cexp (int int -> bool) "%0==%1" a b)) 6 | 7 | (define (zero? x) 8 | (%%cexp (int -> bool) "%0==0" x)) 9 | 10 | ;; variant with zero-arg loop 11 | 12 | (let ((n 1000000)) 13 | (let loop () 14 | (if (zero? n) 15 | "done" 16 | (let ((n0 (- n 1))) 17 | (set! n n0) 18 | (loop))))) 19 | -------------------------------------------------------------------------------- /tests/t7.scm: -------------------------------------------------------------------------------- 1 | ;; testing variants 2 | ;; this will currently fail because case is not yet implemented 3 | 4 | (datatype bool (:true) (:false)) 5 | 6 | (define (+ a b) 7 | (%%cexp (int int -> int) "%0+%1" a b)) 8 | 9 | (let ((x (:fnord 12)) 10 | (y (:blort #f)) 11 | (z (:shlum "howdy")) 12 | ) 13 | ;; three args: (success-cont, failure-cont, sum) 14 | (&vcase (fnord) 15 | (lambda (a) (+ a 3)) 16 | (lambda (b) 17 | (&vcase (blort) 18 | (lambda (c) (if c 99 34)) 19 | (lambda (d) 19) 20 | b)) 21 | z)) 22 | 23 | -------------------------------------------------------------------------------- /tests/t8.scm: -------------------------------------------------------------------------------- 1 | ;; testing variant with else clause 2 | 3 | (include "lib/core.scm") 4 | 5 | (let ((w (:doubleu)) 6 | (x (:fnord 12)) 7 | (y (:blort #f)) 8 | (z (:norg)) 9 | ) 10 | (vcase z 11 | ((:fnord a) (+ a 5)) 12 | ((:blort b) (if b 9 8)) 13 | ((:doubleu) 99) 14 | (else 12) 15 | )) 16 | -------------------------------------------------------------------------------- /tests/t9.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; do some allocation in the loop 3 | 4 | (datatype bool (:true) (:false)) 5 | 6 | (define (- a b) 7 | (%%cexp (int int -> int) "%0-%1" a b)) 8 | 9 | (define (= a b) 10 | (%%cexp (int int -> bool) "%0==%1" a b)) 11 | 12 | (define (zero? x) 13 | (%%cexp (int -> bool) "%0==0" x)) 14 | 15 | (let loop ((n 1000000) 16 | (z {thing=0 blorb=#f}) 17 | (y (:blort 12))) 18 | (if (zero? n) 19 | z 20 | (loop (- n 1) 21 | {thing=n blorb=#f} 22 | (:blort n)))) 23 | -------------------------------------------------------------------------------- /tests/t_LIST.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | 4 | (list 5 | (list 1 2) 6 | (list 3 4) 7 | (list 5 6) 8 | ) 9 | -------------------------------------------------------------------------------- /tests/t_alias.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | (define (+ a b) 4 | (%%cexp (int int -> int) "%0+%1" a b)) 5 | 6 | (define plus +) 7 | 8 | (plus 1 (plus 2 3)) 9 | 10 | -------------------------------------------------------------------------------- /tests/t_alist.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | (include "lib/alist.scm") 5 | 6 | (let ((l0 (alist/make)) 7 | (l1 (alist/make))) 8 | (alist/push l0 'thing 34) 9 | (alist/push l1 'blurb #f) 10 | ) 11 | 12 | -------------------------------------------------------------------------------- /tests/t_alist0.exp: -------------------------------------------------------------------------------- 1 | {u0 six} 2 | {u0 seven} 3 | 4 | {u1 100 one-hundred {u1 0 zero {u1 1 one {u1 2 two {u1 3 three {u1 4 four {u1 5 five {u1 6 six {u1 7 seven {u1 8 eight {u1 9 nine }}}}}}}}}}} 5 | {u1 a "a" {u1 b "b" {u1 c "c" }}} 6 | #u 7 | -------------------------------------------------------------------------------- /tests/t_ambig.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define r0 {a=1 b=2 m=3}) 6 | (define r1 {a=1 b=2 c=3 m=4}) 7 | (define r2 {a=1 b=2 c=3 d=4 m=5}) 8 | 9 | (printn r0.m) 10 | (printn r1.m) 11 | (printn r2.m) 12 | #u 13 | -------------------------------------------------------------------------------- /tests/t_anno.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (+ a b) 3 | (%%cexp (int int -> int) "%0+%1" a b)) 4 | 5 | (define y 19) 6 | 7 | (let ((x:int 34)) 8 | (+ x y) 9 | ) 10 | -------------------------------------------------------------------------------- /tests/t_anno0.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (:nil) 4 | (:cons 'a (list 'a)) 5 | ) 6 | 7 | (datatype bool (:true) (:false)) 8 | 9 | (let ((il:(list int) (list:nil)) 10 | (bl:(list bool) (list:nil))) 11 | (set! il (list:cons 12 il)) 12 | (set! bl (list:cons #f bl)) 13 | il 14 | ) 15 | -------------------------------------------------------------------------------- /tests/t_anno1.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; (define (thing:(int -> int) x) 3 | ;; 3) 4 | 5 | (define (printn x) 6 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 7 | 8 | (define (thing x) : (int -> int) 9 | (printn x) 10 | (printn x) 11 | (printn x) 12 | (printn x) 13 | (printn x) 14 | (printn x) 15 | (printn x) 16 | 3) 17 | 18 | (printn (thing 3)) 19 | (printn (thing 4)) 20 | (printn (thing 5)) 21 | -------------------------------------------------------------------------------- /tests/t_anno2.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (thing a b) : (char int -> {a=char b=int}) 3 | {a=a b=b} 4 | ) 5 | 6 | (thing #\a 12) 7 | 8 | -------------------------------------------------------------------------------- /tests/t_ansi.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (printf "testing, " 7 | (ansi red "red") " " (ansi blue "blue") " " 8 | (ansi (bold red) "bold red") " " (ansi (bold blue) "bold blue") "\n" 9 | (ansi (bold red) (int 99) "->" (int 88)) "\n" 10 | ) 11 | -------------------------------------------------------------------------------- /tests/t_argv.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | (include "lib/os.scm") 7 | 8 | (printn sys.argc) 9 | (printn sys.argv) 10 | (printn sys) 11 | 12 | -------------------------------------------------------------------------------- /tests/t_attr.exp: -------------------------------------------------------------------------------- 1 | 1 2 | -------------------------------------------------------------------------------- /tests/t_attr.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define r {a=0 b=1 c=2}) 4 | 5 | (%%attr r b) 6 | -------------------------------------------------------------------------------- /tests/t_backend.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (%backend c 6 | 7 | (define (binary+ a b) 8 | (%%cexp (int int -> int) "%0+%1" a b)) 9 | 10 | ) 11 | 12 | (%backend llvm 13 | 14 | (define (binary+ a b) 15 | (%llarith add a b)) 16 | 17 | ) 18 | 19 | (defmacro + 20 | (+ x) -> x 21 | (+ a b ...) -> (binary+ a (+ b ...))) 22 | 23 | (+ 1 2 3 4 5) 24 | -------------------------------------------------------------------------------- /tests/t_backend2.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (%backend c 6 | (printn 1) 7 | (printn 2) 8 | (printn 3) 9 | ) 10 | -------------------------------------------------------------------------------- /tests/t_backquote.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype list 4 | (:nil) 5 | (:cons 'a (list 'a))) 6 | 7 | (define x 9) 8 | 9 | ;;`(1 2 3 ,x) 10 | 11 | `((1 2 3) 12 | (4 5 6) 13 | (7 8 ,x) 14 | (10 11 12)) 15 | -------------------------------------------------------------------------------- /tests/t_bad_inline.exp: -------------------------------------------------------------------------------- 1 | 10 2 | -------------------------------------------------------------------------------- /tests/t_bad_inline.scm: -------------------------------------------------------------------------------- 1 | ;; should return 10, not 5! 2 | 3 | (let ((n 10)) 4 | ((lambda (x) (set! n 5) x) n)) 5 | 6 | -------------------------------------------------------------------------------- /tests/t_binop.scm: -------------------------------------------------------------------------------- 1 | (include "lib/basis.scm") 2 | 3 | (printf (int (+ 1 2 3 4 5)) "\n") 4 | (printf (int (- 3 4 5)) "\n") 5 | (printf (int (* 2 3 5 7)) "\n") 6 | -------------------------------------------------------------------------------- /tests/t_bitget.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | ;; #x1001 0001 0000 0000 0001 6 | (printn (bit-get #x1001 0)) 7 | (printn (bit-get #x1001 1)) 8 | (printn (bit-get #x1001 2)) 9 | (printn (bit-get #x1001 3)) 10 | (printn (bit-get #x1001 4)) 11 | (printn (bit-get #x1001 5)) 12 | (printn (bit-get #x1001 6)) 13 | (printn (bit-get #x1001 7)) 14 | (printn (bit-get #x1001 8)) 15 | (printn (bit-get #x1001 9)) 16 | (printn (bit-get #x1001 10)) 17 | (printn (bit-get #x1001 11)) 18 | (printn (bit-get #x1001 12)) 19 | (printn (bit-get #x1001 13)) 20 | (printn (bit-get #x1001 14)) 21 | (printn (bit-get #x1001 15)) 22 | (printn (bit-get #x1001 16)) 23 | 24 | (printn (bit-set 0 12)) 25 | (printn (bit-set 3141 7)) 26 | -------------------------------------------------------------------------------- /tests/t_bool.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (printn #t) 3 | (printn #f) 4 | (printn (bool:true)) 5 | (printn (bool:false)) 6 | -------------------------------------------------------------------------------- /tests/t_bug1.exp: -------------------------------------------------------------------------------- 1 | 19 2 | -------------------------------------------------------------------------------- /tests/t_bug1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (thing) 4 | (let ((x 19)) 5 | x 6 | ); 7 | ) 8 | 9 | (thing) 10 | -------------------------------------------------------------------------------- /tests/t_bug32.exp: -------------------------------------------------------------------------------- 1 | thing-wrap! 2 | thing! 3 | #u 4 | -------------------------------------------------------------------------------- /tests/t_bug32.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | 5 | (define (thing1) 6 | (printf "thing!\n")) 7 | 8 | (define original-thing1 thing1) 9 | 10 | (define (thing1-wrap) 11 | (printf "thing-wrap!\n") 12 | (original-thing1)) 13 | 14 | (set! thing1 thing1-wrap) 15 | 16 | (thing1) 17 | -------------------------------------------------------------------------------- /tests/t_butlast.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | 5 | (printn (butlast '(1 2 3 4 5 6))) 6 | -------------------------------------------------------------------------------- /tests/t_callbug.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/alist.scm") 6 | 7 | ;; trying to repro a bug I found when working on self/match.scm, where I 8 | ;; accidentally invoked a symbol arg... somehow the solver let it slide, 9 | ;; dunno why. If I changed (tag) to (3) or (rules-stack) I get an error, 10 | ;; somehow the key part of alist/iterate allowed it to get through. 11 | 12 | ;; (alist/iterate 13 | ;; (lambda (tag rules-stack) 14 | ;; (let ((alt (dt.get (tag))) 15 | ;; (vars0 (nthunk alt.arity new-match-var)) 16 | ;; (wild (make-vector alt.arity #t)) 17 | ;; (rules1 '())) 18 | 19 | 20 | (define (get s) 21 | s) 22 | 23 | (define thing 24 | (alist/make 25 | ('x {get=get n=0}) 26 | ('y {get=get n=1}) 27 | )) 28 | 29 | (alist/iterate 30 | (lambda (k v) 31 | (let ((x (v.get k))) 32 | (printn x))) 33 | thing 34 | ) 35 | -------------------------------------------------------------------------------- /tests/t_cexp_wrap.exp: -------------------------------------------------------------------------------- 1 | 42 2 | 5 3 | #u 4 | -------------------------------------------------------------------------------- /tests/t_cexp_wrap.scm: -------------------------------------------------------------------------------- 1 | (define (printn x) 2 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 3 | 4 | (define (string-length s) 5 | (%%cexp ((raw string) -> int) "%0->len" s)) 6 | 7 | (define (thing) 8 | (%%cexp (-> int) "42")) 9 | 10 | (printn (thing)) 11 | (printn (string-length "howdy")) 12 | -------------------------------------------------------------------------------- /tests/t_clock_gettime.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/basis.scm") 4 | (require "lib/time.scm") 5 | 6 | (define (test kind) 7 | (let ((ts (clock-gettime kind))) 8 | (printf "nsec " (int ts.nsec) "\n") 9 | (printf "current time: " (int ts.sec) "." (zpad 9 (int ts.nsec)) "\n") 10 | )) 11 | 12 | (test CLOCK_REALTIME) 13 | (test CLOCK_MONOTONIC) 14 | (test CLOCK_PROCESS_CPUTIME_ID) 15 | -------------------------------------------------------------------------------- /tests/t_collect.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/alist.scm") 6 | (include "lib/stack.scm") 7 | 8 | ;; sort a collection into lists with matching

9 | ;;

must return an eq?-compatible object. returns an alist of stacks. 10 | (define (collect p l) 11 | (let loop ((acc (alist/make)) 12 | (l l)) 13 | (match l with 14 | () -> acc 15 | (hd . tl) 16 | -> (let ((key (p hd))) 17 | (match (alist/lookup acc key) with 18 | (maybe:no) -> (let ((stack (make-stack))) 19 | (stack.push hd) 20 | (loop (alist:entry key stack acc) tl)) 21 | (maybe:yes stack) -> (begin (stack.push hd) (loop acc tl))))))) 22 | 23 | (datatype test 24 | (:red) 25 | (:green) 26 | (:blue) 27 | ) 28 | 29 | (define R (test:red)) 30 | (define G (test:green)) 31 | (define B (test:blue)) 32 | 33 | (define test->color 34 | (test:red) -> 'red 35 | (test:green) -> 'green 36 | (test:blue) -> 'blue 37 | ) 38 | 39 | (let ((l (list R G B B R R G G B))) 40 | (alist/iterate 41 | (lambda (k v) 42 | (printn (v.get))) 43 | (collect test->color l))) 44 | 45 | 46 | -------------------------------------------------------------------------------- /tests/t_combinations.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/combinatorics.scm") 6 | 7 | (printf "one\n") 8 | (for-list comb (combinations '(0 1 2 3 4) 3) 9 | (printn comb)) 10 | (printf "two\n") 11 | (for comb (combinations* '(0 1 2 3 4) 3) 12 | (printn comb)) 13 | (printf "three\n") 14 | (for comb (combinations* '(0 1 2 3 4 5) 3) 15 | (printn comb)) 16 | (printf "four\n") 17 | (for comb (combinations* '(0 1 2 3 4 5) 2) 18 | (printn comb)) 19 | (printf "five\n") 20 | (for comb (combinations** '(0 1 2 3 4 5) 2) 21 | (printn comb)) 22 | (define (rcombinations xs k) 23 | (makegen emit 24 | (cond ((= k 0) (emit (list:nil))) 25 | ((not (null? xs)) 26 | (for sub (rcombinations (rest xs) k) 27 | (emit sub)) 28 | (for sub (rcombinations (rest xs) (- k 1)) 29 | (emit (list:cons (first xs) sub))))))) 30 | (for comb (rcombinations '(0 1 2 3 4 5) 2) 31 | (printn comb)) 32 | -------------------------------------------------------------------------------- /tests/t_cond.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define (thing x) 6 | (cond ((= x 0) 1) 7 | ((= x 1) 2) 8 | (else 3))) 9 | 10 | (thing 5) 11 | -------------------------------------------------------------------------------- /tests/t_constructor.exp: -------------------------------------------------------------------------------- 1 | () 2 | -------------------------------------------------------------------------------- /tests/t_constructor.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | 5 | ;; equivalent to (list:nil) 6 | ((%%constructor list nil)) 7 | 8 | -------------------------------------------------------------------------------- /tests/t_datatype.exp: -------------------------------------------------------------------------------- 1 | (1 2 3 4 5) 2 | 5 3 | () 4 | 0 5 | (#\C) 6 | 1 7 | (#\B #\C) 8 | 2 9 | (#\A #\B #\C) 10 | 3 11 | ("hello" "hello" "hello" "hello" "hello" "hello" "hello" "hello" "hello" "hello") 12 | #f 13 | #t 14 | 99 15 | -------------------------------------------------------------------------------- /tests/t_datatype0.exp: -------------------------------------------------------------------------------- 1 | (1 2 3 4) 2 | 4 3 | (#t) 4 | #u 5 | -------------------------------------------------------------------------------- /tests/t_datatype0.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype bool (:true) (:false)) 3 | 4 | (datatype list 5 | (:nil) 6 | (:cons 'a (list 'a)) 7 | ) 8 | 9 | (define (+ a b) 10 | (%%cexp (int int -> int) "%0+%1" a b)) 11 | 12 | (define (printn x) 13 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 14 | 15 | (define (length l) 16 | (let loop ((l l) (r 0)) 17 | (vcase list l 18 | ((:nil) r) 19 | ((:cons _ tl) (loop tl (+ r 1)))))) 20 | 21 | (let ((l0 (list:cons 1 (list:cons 2 (list:cons 3 (list:cons 4 (list:nil)))))) 22 | (l1 (list:nil)) 23 | ) 24 | (printn l0) 25 | (printn (length l0)) 26 | (set! l1 (list:cons #t l1)) 27 | (printn l1) 28 | ) 29 | 30 | 31 | -------------------------------------------------------------------------------- /tests/t_datatype2.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; let's try to build these data structures for the parser: 3 | 4 | ;; stack = (:elem item state stack) | (:nil) 5 | ;; item = (:nt kind args) | (:t val) 6 | ;; args = (:cons item args) | (:nil) 7 | ;; state = int 8 | ;; kind = symbol 9 | 10 | (datatype list 11 | (:cons 'a (list 'a)) 12 | (:nil) 13 | ) 14 | 15 | (datatype item 16 | (:nt string (list (item 'a))) 17 | (:t string) 18 | ) 19 | 20 | (datatype stack 21 | (:empty) 22 | (:elem (item 'a) int (stack 'a)) 23 | ) 24 | 25 | (let ((stack (stack:empty)) 26 | (item0 (item:t "terminal")) 27 | (item1 (item:nt "non-terminal" (list:cons (item:t "term2") (list:nil)))) 28 | ) 29 | 30 | (define (push x y) 31 | (set! stack (stack:elem x y stack)) 32 | stack 33 | ) 34 | 35 | (push item0 34) 36 | (push item1 9) 37 | ;;(push item0 #t) 38 | stack 39 | ) 40 | 41 | -------------------------------------------------------------------------------- /tests/t_datatype3.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype goto 3 | (:nil) 4 | (:cons int int (goto))) 5 | 6 | (let ((x (goto:cons 1 1 (goto:cons 2 2 (goto:cons 3 3 (goto:nil)))))) 7 | x) 8 | -------------------------------------------------------------------------------- /tests/t_datatype5.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | ;; test records in datatypes 8 | 9 | (datatype thing 10 | (:a {x=int y=char}) 11 | (:b {x=bool y=string}) 12 | ) 13 | 14 | (datatype thing2 15 | (:t {x=int y={a=int b=int c=int}})) 16 | 17 | (define (test) 18 | (thing:a {x=3 y=#\A}) 19 | ) 20 | 21 | (printn (test)) 22 | (printn (thing2:t {x=5 y={a=3 b=3 c=6}})) 23 | 24 | 25 | -------------------------------------------------------------------------------- /tests/t_datatype6.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | ;; declare a new datatype with only one alternative 8 | ;; which consists of an open record type... i.e., a record that 9 | ;; may contain other unknown fields. 10 | (datatype thing 11 | (:t {x=int y=char ...}) 12 | ) 13 | 14 | (define (test1) 15 | (thing:t {x=3 y=#\b z=9}) 16 | ) 17 | 18 | (define (test2) 19 | (thing:t {x=4 y=#\c z=#\a a=#t b=#f})) 20 | 21 | ;; make sure it still works with *no* extra fields 22 | (define (test3) 23 | (thing:t {x=4 y=#\a})) 24 | 25 | ;; now match against them 26 | (define bar 27 | {y=y x=x ...} -> (+ x 1)) 28 | 29 | (define foo 30 | (thing:t r) -> (bar r)) 31 | 32 | (printn (test1)) 33 | (printn (test2)) 34 | (printn (test3)) 35 | (printn (foo (test1))) 36 | (printn (foo (test2))) 37 | (printn (foo (test3))) 38 | 39 | 40 | -------------------------------------------------------------------------------- /tests/t_dtsexp.exp: -------------------------------------------------------------------------------- 1 | (thing 2 | ((one 3 | 0 4 | ((int) (int))) 5 | (two 1 ((bool))) 6 | (three 7 | 2 8 | ((char) (thing))))) 9 | {u1 three 2 {u1 two 1 {u1 one 0 }}} 10 | thing:two has tag 1 11 | (tree 12 | ((red 13 | 0 14 | ((tree 'a 'b) 15 | (tree 'a 'b) 16 | 'a 17 | 'b)) 18 | (black 19 | 1 20 | ((tree 'a 'b) 21 | (tree 'a 'b) 22 | 'a 23 | 'b)) 24 | (empty 2 ()))) 25 | {u1 empty 2 {u1 black 1 {u1 red 0 }}} 26 | 10 27 | -------------------------------------------------------------------------------- /tests/t_dump_image.exp: -------------------------------------------------------------------------------- 1 | 49 48 47 46 45 44 43 42 41 40 39 38 37 36 35 34 33 32 31 30 29 28 27 26 25 24 23 22 21 20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1 0 9 2 | -------------------------------------------------------------------------------- /tests/t_dump_image.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/os.scm") 5 | 6 | ;;; Note: if this test is failing you may need to disable ASLR on your 7 | ;;; operating system. Otherwise the addresses of continuations/functions/etc 8 | ;;; will not be identical between runs and the loading of image dumps will fail. 9 | 10 | (define (thing n) 11 | (printn "howdy!") 5) 12 | 13 | (define (go) 14 | (let loop ((n 100)) 15 | (print n) (print-string " ") 16 | (cond ((= n 0) 9) 17 | ((= n 50) 18 | (callcc (lambda (k) (dump "test.image" k))) 19 | (loop (- n 1))) 20 | (else (loop (- n 1)))))) 21 | 22 | ;; invoke without an argument to dump the image, 23 | ;; with an argument to load it and run it. 24 | (if (> sys.argc 1) 25 | (throw (load "test.image") 0) 26 | (go)) 27 | 28 | 29 | -------------------------------------------------------------------------------- /tests/t_empty_vector.exp: -------------------------------------------------------------------------------- 1 | #t 2 | -------------------------------------------------------------------------------- /tests/t_empty_vector.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | 5 | ;; tests TC_EMPTY_VECTOR by triggering gc with some empty vectors in the heap 6 | 7 | (let ((z (n-of 100 (:testing 23 #f)))) 8 | ;; z gives the gc something to do 9 | 10 | (let loop ((n 10000)) 11 | (let ((v (%make-vector #f 0 0))) 12 | (if (= n 0) 13 | v 14 | (loop (- n 1))))) 15 | 16 | (let loop ((n 100000)) 17 | (let ((x #(#() #() #() #() #() #(1 2 3)))) 18 | (set! x[5] (%make-vector #f 0 3)) 19 | (set! x[0] (%make-vector #f 0 4)) 20 | ) 21 | (if (= n 0) 22 | #t 23 | (loop (- n 1)))) 24 | ) 25 | 26 | -------------------------------------------------------------------------------- /tests/t_endian.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (define big-endian? 7 | (let ((val0* (halloc u32 1)) 8 | (val1* (%c-cast (array u8) val0*))) 9 | (define (get n) 10 | (c-get-int (c-aref val1* n))) 11 | (c-set-int (c-aref val0* 0) #xf00fda) 12 | (match (get 0) (get 1) (get 2) with 13 | #xda #x0f #xf0 -> #f 14 | #xf0 #x0f #xda -> #t 15 | x y z 16 | -> (begin 17 | (printf "vals " (int x) " " (int y) " " (int z) "\n") 18 | (raise (:I_Am_Confused))) 19 | ))) 20 | 21 | (printf 22 | (match big-endian? with 23 | #t -> "big-endian" 24 | #f -> "little-endian") 25 | "\n") 26 | 27 | 28 | -------------------------------------------------------------------------------- /tests/t_endswith.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (defmacro verify 7 | (verify) -> #t 8 | (verify truth test rest ...) 9 | -> (if (not (eq? truth test)) 10 | (error "failed assertion") 11 | (verify rest ...)) 12 | ) 13 | 14 | (verify 15 | #t (ends-with "moose" "ose") 16 | #f (ends-with "noose" "osf") 17 | #f (ends-with "moo" "moose") 18 | #t (ends-with "abcd" "") 19 | #f (ends-with "" "abcd") 20 | #f (ends-with "foo" "bar") 21 | #f (ends-with "foo" "fox") 22 | #f (ends-with "foo" "fox") 23 | ) 24 | -------------------------------------------------------------------------------- /tests/t_enum.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (define (print-imm x) 5 | (%%cexp ('a -> int) "fprintf (stderr, \"code=%%p\\n\", (object*)%0)" x)) 6 | 7 | (datatype foo 8 | (:one) 9 | (:two) 10 | (:three) 11 | ) 12 | 13 | (datatype glork 14 | (:a) 15 | (:b) 16 | ) 17 | 18 | (define bar 19 | (foo:one) -> 1 20 | (foo:two) -> 2 21 | (foo:three) -> 3 22 | ) 23 | 24 | (printn (bar (foo:one))) 25 | (printn (bar (foo:two))) 26 | (printn (bar (foo:three))) 27 | (print-imm (foo:one)) 28 | (print-imm (foo:two)) 29 | (print-imm (foo:three)) 30 | ;(print-imm #t) 31 | ;(print-imm #f) 32 | ;(print-imm (glork:a)) 33 | ;(print-imm (glork:b)) 34 | 35 | -------------------------------------------------------------------------------- /tests/t_enum1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/enum.scm") 6 | 7 | (make-enum color (red 0) (green 1) (blue 2)) 8 | (printn (color->int (color:red))) 9 | (printn (color->int (color:green))) 10 | (printn (color->int (color:blue))) 11 | (printf "blue is named " (sym (color->name (color:blue))) "\n") 12 | (printf "1 is named " (sym (color->name (int->color 1))) "\n") 13 | -------------------------------------------------------------------------------- /tests/t_explode.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | ;; the old definition of the constant rule in match.py 7 | ;; caused an exponential explosion with code like this, 8 | ;; because the 'default' was getting duplicated at each 9 | ;; level. Code like this would explode to 250kB of C. 10 | 11 | (define thing 12 | (0 x 1 . rest) -> 1 13 | (1 2 x 3 4 y) -> 2 14 | (2 . z) -> 3 15 | (3 0 x) -> 4 16 | (4 x y z) -> 5 17 | (x . y) -> 6 18 | () -> 7 19 | ) 20 | 21 | (thing '(1 2 0 3 4 5)) 22 | -------------------------------------------------------------------------------- /tests/t_explode0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (eq? a b) 4 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 5 | 6 | (define thing 7 | 0 2 1 -> 1 8 | 1 3 2 -> 0 9 | _ _ _ -> 2 10 | ) 11 | 12 | (thing 3 2 2) 13 | -------------------------------------------------------------------------------- /tests/t_extend.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define (other-fun) 6 | {d=2 e=#t f="there"}) 7 | 8 | (define thing 9 | 0 f -> {d=1 e=#f f="hello" a=7} 10 | _ f -> (let ((r (other-fun))) 11 | (%rextend/a r 34)) 12 | ) 13 | 14 | (define (thing2) 15 | (let ((r {a=0 b=1 c=2})) 16 | (%rextend/b r 12))) 17 | 18 | (printn (thing 2 other-fun)) 19 | (printn (thing2)) 20 | 21 | 22 | -------------------------------------------------------------------------------- /tests/t_fficonst.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (require-ffi 'posix) 7 | (%backend bytecode (update-sizeoff-table)) 8 | 9 | (%backend bytecode (printf "lookup O_TRUNC: " (int (lookup-constant 'O_TRUNC)) "\n")) 10 | (printf " O_TRUNC = " (int O_TRUNC) "\n") 11 | -------------------------------------------------------------------------------- /tests/t_fold0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (printn (fold + 0 '(1 2 3 4 5))) 7 | (printn (foldr list:cons '() '(a b c d e fg))) 8 | 9 | -------------------------------------------------------------------------------- /tests/t_fold_alist.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | (include "lib/alist.scm") 4 | 5 | (printn (foldr 6 | (lambda (x al) (alist:entry x 0 al)) 7 | (alist:nil) 8 | '(0 1 2 3 4 5))) 9 | 10 | -------------------------------------------------------------------------------- /tests/t_for_range.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (for-range x (+ 5 5) 8 | (for-range y 10 9 | (print-string 10 | (format "x=" (int x) " y=" (int y) " "))) 11 | (newline) 12 | ) 13 | 14 | (printn (map-range i 10 i)) 15 | (printn (map-range i 10 (printn i) (+ i i))) 16 | -------------------------------------------------------------------------------- /tests/t_format.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (printn (format "Int: " (int 3) " Hex: " (hex 16384) " Bool: " (bool #f) " woo hoo!")) 8 | (print-string (format-join " " "testing" (int 1) (bool #t) (char #\A) "\n")) 9 | (printn (format "list(" (join id "," '("sexp")) ")" )) 10 | (printn (format (lpad 10 "hi-") (rpad 10 "there"))) 11 | (printn (rpad 10 "xyz")) 12 | (printn (lpad 10 "xyz")) 13 | (printn (cpad 10 "xyz")) 14 | (printn (format "thing")) 15 | 16 | -------------------------------------------------------------------------------- /tests/t_frb0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/frb.scm") 6 | 7 | ;; test tree/make macro 8 | 9 | (let ((t (tree/make int-cmp 10 | (1 "time") 11 | (2 "flies") 12 | (3 "like") 13 | (4 "a") 14 | (5 "banana") 15 | ))) 16 | (printn t) 17 | (tree/member t int-cmp 5) 18 | ) 19 | -------------------------------------------------------------------------------- /tests/t_frb1.exp: -------------------------------------------------------------------------------- 1 | {u1 {u0 {u1 1 "time"} {u1 3 "like"} 2 "flies"} {u1 5 "banana"} 4 "a"} 2 | 1 time 3 | 2 flies 4 | 3 like 5 | 4 a 6 | 5 banana 7 | {u1 {u1 1 "time"} {u1 {u0 3 "like"} 5 "banana"} 2 "flies"} 8 | {u0 11493 2261} 9 | {u0 2146914234 5786} 10 | 11493 11 | 2146914234 12 | black-height: 7 13 | #t 14 | #u 15 | -------------------------------------------------------------------------------- /tests/t_gen1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/os.scm") 5 | 6 | (define (range-generator start stop) 7 | (make-generator 8 | (lambda (consumer) 9 | (let loop ((n start)) 10 | (if (= n stop) 11 | (forever (consumer (maybe:no))) 12 | (begin 13 | (consumer (maybe:yes n)) 14 | (loop (+ n 1)))))))) 15 | 16 | (define (char-generator) 17 | (make-generator 18 | (lambda (consumer) 19 | (let loop ((n 65)) 20 | (if (= n (+ 65 26)) 21 | (forever (consumer (maybe:no))) 22 | (begin 23 | (consumer (maybe:yes (ascii->char n))) 24 | (loop (+ n 1)))))))) 25 | 26 | (for (range-generator 100 120) i 27 | (printf "i = " (int i) "\n")) 28 | 29 | (for (char-generator) ch 30 | (printf "ch = " (char ch) "\n")) 31 | -------------------------------------------------------------------------------- /tests/t_genutils.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/basis.scm") 4 | 5 | (for (i num) (counting-gen (list-generator (reverse (range 10)))) 6 | (printf "i " (int i) " : " (int num) "\n")) 7 | 8 | (for (last? num) (notify-last-gen (list-generator (range 10))) 9 | (printf (bool last?) " " (int num) "\n")) 10 | 11 | -------------------------------------------------------------------------------- /tests/t_graph.exp: -------------------------------------------------------------------------------- 1 | graph = { 2 | foo : baz 3 | baz : bar 4 | bar : foo 5 | biff : barf 6 | barf : snoo, snee 7 | snoo : biff 8 | snee : 9 | top : foo, biff 10 | } 11 | graph = { 12 | foo : bar, top 13 | baz : foo 14 | bar : baz 15 | biff : snoo, top 16 | barf : biff 17 | snoo : barf 18 | snee : barf 19 | top : 20 | } 21 | ((foo baz bar) (snee) (biff barf snoo) (top)) 22 | 10 23 | -------------------------------------------------------------------------------- /tests/t_graph.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/graph.scm") 6 | 7 | (define (print-graph g krepr) 8 | (printf "graph = {\n") 9 | (for-map k v g 10 | (printf " " (krepr k) " : " (join krepr ", " (set->list v)) "\n")) 11 | (printf "}\n") 12 | ) 13 | 14 | (define test-g 15 | '((foo baz) ;; these three 16 | (baz bar) ;; form a 17 | (bar foo) ;; cycle. 18 | (biff barf) ;; as do 19 | (barf snoo snee) ;; these 20 | (snoo biff) ;; three. 21 | (snee) 22 | (top foo biff))) 23 | 24 | (define (make-sample) 25 | (let ((g (tree/empty))) 26 | (for-list l test-g 27 | (tree/insert! 28 | g 29 | symbol-index-cmp 30 | (car l) 31 | (list->set (cdr l) symbol-index-cmp (set/empty)))) 32 | g)) 33 | 34 | (let ((g0 (make-sample)) 35 | (g1 (transpose g0 symbol-index-cmp))) 36 | (print-graph g0 symbol->string) 37 | (print-graph g1 symbol->string) 38 | (printn (strongly g0 symbol-index-cmp)) 39 | ) 40 | -------------------------------------------------------------------------------- /tests/t_halloc.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (let ((buf (halloc int 20))) 7 | (for-range j 1000000 8 | (let ((thing (make-string 1024))) 9 | (for-range i 20 10 | (let ((int* (c-aref buf i))) 11 | ;; (printn int*) 12 | (c-set-int int* (+ i 1234)))))) 13 | (for-range i 20 14 | (let ((int* (c-aref buf i))) 15 | (printf (lpad 3 (int i)) " " (lpad 8 (int (c-get-int int*))) "\n") 16 | )) 17 | (let ((thing (halloc int 1))) 18 | (free thing)) 19 | ) 20 | 21 | -------------------------------------------------------------------------------- /tests/t_hex0.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | (include "lib/string.scm") 4 | 5 | (printn (int->hex-string #xdeadbeef)) 6 | (printn (int->hex-string -34)) 7 | 8 | -------------------------------------------------------------------------------- /tests/t_hexenc.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/codecs/hex.scm") 6 | 7 | (let ((s "603c303a040361626302013202022711020417bc927a3020300602010a020165300602010a020165300602010a020165300602010a0201650101000a0100")) 8 | (printn (hex->string s)) 9 | (printn (string->hex (hex->string s))) 10 | (assert (string=? s (string->hex (hex->string s))))) 11 | -------------------------------------------------------------------------------- /tests/t_if_maybe.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (define thing0 (list (maybe:yes 1) (maybe:no) (maybe:yes 3))) 7 | 8 | (define (t0) 9 | (for-list item thing0 10 | (printf " - " (int (if-maybe val item (+ val 3) 0)) "\n") 11 | )) 12 | 13 | (t0) 14 | -------------------------------------------------------------------------------- /tests/t_inline0.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | 4 | ;; we need a partial evaluator?, the inliner can't 5 | ;; see and make this Do The Right Thing. 6 | ;; XXX see appel "modern compiler implementation..." 15.4. 7 | ;; according to that we need loop-preheader and loop-invariant 8 | ;; optimizations. 9 | (printn (member? 0 '(0 1 2 3) eq?)) 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /tests/t_insert0.exp: -------------------------------------------------------------------------------- 1 | (99 0 1 2 3 4 5) 2 | (0 99 1 2 3 4 5) 3 | (0 1 99 2 3 4 5) 4 | (0 1 2 99 3 4 5) 5 | (0 1 2 3 99 4 5) 6 | (0 1 2 3 4 99 5) 7 | (0 1 2 3 4 5 99) 8 | (0 1 2 3 4 5 99) 9 | 10 10 | -------------------------------------------------------------------------------- /tests/t_insert0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (printn (insert (list 0 1 2 3 4 5) 0 99)) 7 | (printn (insert (list 0 1 2 3 4 5) 1 99)) 8 | (printn (insert (list 0 1 2 3 4 5) 2 99)) 9 | (printn (insert (list 0 1 2 3 4 5) 3 99)) 10 | (printn (insert (list 0 1 2 3 4 5) 4 99)) 11 | (printn (insert (list 0 1 2 3 4 5) 5 99)) 12 | (printn (insert (list 0 1 2 3 4 5) 6 99)) 13 | (printn (insert (list 0 1 2 3 4 5) 10 99)) 14 | 15 | -------------------------------------------------------------------------------- /tests/t_int0.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | (include "lib/string.scm") 4 | 5 | (printn (int->string #xdeadbeef)) 6 | (printn (int->string -34)) 7 | (printn (int->string 0)) 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /tests/t_lambda.scm: -------------------------------------------------------------------------------- 1 | t_λ.scm -------------------------------------------------------------------------------- /tests/t_length.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | 4 | (printn (length '(0 1 2 3 4 5))) 5 | (printn (length '())) 6 | -------------------------------------------------------------------------------- /tests/t_letcc.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode:Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define (thing n) 6 | (let/cc exit 7 | (for-range 8 | i 1000 9 | (printn i) 10 | (if (= i n) 11 | (exit i)) 12 | ) 13 | 1001)) 14 | 15 | (define (test) 16 | (printn "before") 17 | (printn (thing 20)) 18 | (printn "after")) 19 | 20 | (test) 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /tests/t_letpoly.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (:nil) 4 | (:cons 'a (list 'a)) 5 | ) 6 | 7 | (datatype bool (:true) (:false)) 8 | 9 | (define (make-stack) 10 | (let ((l (list:nil))) 11 | (lambda (e) 12 | (set! l (list:cons e l))) 13 | )) 14 | 15 | (let ((is (make-stack)) 16 | (bs (make-stack))) 17 | (is 10) 18 | (bs #f) 19 | ) 20 | -------------------------------------------------------------------------------- /tests/t_letreg.exp: -------------------------------------------------------------------------------- 1 | 11 2 | -------------------------------------------------------------------------------- /tests/t_letreg.scm: -------------------------------------------------------------------------------- 1 | 2 | ;; verify that let_reg works correctly 3 | 4 | (define (+ a b) 5 | (%%cexp (int int -> int) "%0+%1" a b)) 6 | 7 | (define (< a b) 8 | (%%cexp (int int -> bool) "%0<%1" a b)) 9 | 10 | (define (min x y) 11 | (if (< x y) x y)) 12 | 13 | (let ((x 3) 14 | (y 5) 15 | (m (min x y)) 16 | ) 17 | (+ m (+ x y))) 18 | -------------------------------------------------------------------------------- /tests/t_letreg0.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (printn x) 3 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 4 | 5 | (define (+ a b) 6 | (%%cexp (int int -> int) "%0+%1" a b)) 7 | 8 | (define (make-counter) 9 | (let ((val 0)) 10 | (define (next) 11 | (let ((r val)) 12 | (set! val (+ val 1)) 13 | r) 14 | ) 15 | next 16 | )) 17 | 18 | (let ((c (make-counter))) 19 | (printn (c)) 20 | (printn (c)) 21 | ) 22 | -------------------------------------------------------------------------------- /tests/t_letreg_bug.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; this code aggravates an issue with letreg and register allocation. 4 | 5 | ;; in cps/c-let-reg: 6 | ;; the original line: 7 | ;; 8 | ;; (compile tail? (car inits) lenv (add-free-regs k regs)) 9 | ;; 10 | ;; would lead to the target getting stomped on by the first 11 | ;; letreg variable. strange and rare problem that only shows 12 | ;; up in the bytecode compiler. 13 | ;; 14 | ;; this extra move seems to fix things: 15 | ;; 16 | ;; (compile tail? (car inits) lenv 17 | ;; (cont (merge-sets regs (k/free k)) 18 | ;; (lambda (reg) 19 | ;; (insn:move reg -1 k)))) 20 | 21 | (define (vector-length v) 22 | (%backend (c llvm) 23 | (%%cexp 24 | ((vector 'a) -> int) 25 | "(%0 == (object*) TC_EMPTY_VECTOR) ? 0 : GET_TUPLE_LENGTH(*%0)" v)) 26 | (%backend bytecode 27 | (%%cexp ((vector 'a) -> int) "vlen" v)) 28 | ) 29 | 30 | (define thing 31 | (let ((x #(1 2 3 4))) 32 | { a=(vector-length x) b=x } 33 | )) 34 | 35 | thing 36 | -------------------------------------------------------------------------------- /tests/t_lisp_reader.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/basis.scm") 4 | 5 | (define (read-file path) 6 | (let ((file (file/open-read path)) 7 | (result (reader path (lambda () (file/read-char file))))) 8 | result)) 9 | 10 | (define (test-file) 11 | (let ((t (read-file 12 | (if (> sys.argc 1) 13 | sys.argv[1] 14 | "lib/core.scm")))) 15 | (for-each (lambda (x) (pp x 80) (newline)) t) 16 | #u 17 | )) 18 | 19 | (test-file) 20 | -------------------------------------------------------------------------------- /tests/t_list_lt.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (printn (list bool) "%0<%1" a b)) 7 | 8 | (defmacro zand 9 | (zand) -> #t 10 | (zand test) -> test 11 | (zand test1 test2 ...) -> (if test1 (zand test2 ...) #f) 12 | ) 13 | 14 | (zand (< 1 2) (< 3 4) (< 5 6)) 15 | -------------------------------------------------------------------------------- /tests/t_magic_lt.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (defmacro test 7 | (test val exp) -> (assert (eq? exp val)) 8 | ) 9 | 10 | (test #f (magic 1 6 | n -> (* n (fact (- n 1))) 7 | ) 8 | 9 | (define fact-iter 10 | 0 a -> a 11 | n a -> (fact-iter (- n 1) (* n a)) 12 | ) 13 | 14 | {a=(fact 5) b=(fact-iter 5 1)} 15 | -------------------------------------------------------------------------------- /tests/t_match10.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (datatype list 5 | (:nil) 6 | (:cons 'a (list 'a)) 7 | ) 8 | 9 | (define car 10 | (x . _) -> x 11 | _ -> (error "car") 12 | ) 13 | 14 | (define cdr 15 | (_ . y) -> y 16 | _ -> (error "cdr") 17 | ) 18 | 19 | (cdr '(1 2 3)) 20 | 21 | (define thing 22 | (1 2 a b) -> a 23 | (1 2 a 9) -> a 24 | () -> 0 25 | _ -> -1 26 | ) 27 | 28 | (define duncan 29 | ((1 2) (3 4 5) (6 7)) -> "idaho" 30 | _ -> "donuts" 31 | ) 32 | 33 | { a = (car '(1 2 3)) 34 | b = (cdr '(10 11 12)) 35 | c = (thing '(1 2 9 8)) 36 | d = (duncan '((1 2) (3 4 5) (6 7))) 37 | e = (duncan '((1 2) (3 4 5 9) (6 7))) 38 | } 39 | -------------------------------------------------------------------------------- /tests/t_match11.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (:nil) 4 | (:cons 'a (list 'a)) 5 | ) 6 | 7 | (define unwieldy 8 | () () -> (list:nil) 9 | x y -> (list:cons 10 (list:cons 9 (list:cons 8 x))) 10 | ) 11 | 12 | (unwieldy '(12) '(8 9 7)) 13 | ;(unwieldy '() '()) 14 | -------------------------------------------------------------------------------- /tests/t_match12.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | 5 | (define thing 6 | ('a 'b 'c) -> #t 7 | _ -> #f 8 | ) 9 | 10 | (printn (thing '(a b c))) 11 | (printn (thing '(c b a))) 12 | -------------------------------------------------------------------------------- /tests/t_match13.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype bool (:true) (:false)) 4 | (datatype list (:nil) (:cons 'a (list 'a))) 5 | 6 | (define demo 7 | () ys -> (:A ys) 8 | xs () -> (:B xs) 9 | (x . xs) (y . ys) -> (:C x xs y ys) 10 | ) 11 | 12 | (demo '(1 2 3) '(4 5 6)) 13 | -------------------------------------------------------------------------------- /tests/t_match2.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (:nil) 4 | (:cons 'a (list 'a))) 5 | 6 | (define map-pairs 7 | f (list:nil) ys -> (list:nil) 8 | f (list:cons x xs) (list:nil) -> (list:nil) 9 | f (list:cons x xs) (list:cons y ys) -> (list:cons (f x y) (map-pairs f xs ys))) 10 | 11 | ;; original version: 12 | ;(define (reverse-onto l1 l2) 13 | ; (vcase list l1 14 | ; ((:nil) l2) 15 | ; ((:cons hd tl) 16 | ; (reverse-onto tl (list:cons hd l2))) 17 | ; )) 18 | 19 | ;; pattern-matching version: 20 | (define reverse-onto 21 | (list:nil) y -> y 22 | (list:cons x xs) y -> (reverse-onto xs (list:cons x y)) 23 | ) 24 | 25 | ;; with list syntax help: 26 | ;(define reverse-onto 27 | ; [] y -> y 28 | ; [x :: xs] y -> (reverse-onto xs [x :: y]) 29 | ; ) 30 | 31 | (define (reverse l) 32 | (reverse-onto l (list:nil))) 33 | 34 | (define (+ a b) 35 | (%%cexp (int int -> int) "%0+%1" a b)) 36 | 37 | (reverse (map-pairs + '(1 2 3 4) '(5 6 7 8))) 38 | 39 | -------------------------------------------------------------------------------- /tests/t_match3.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; repro a bug in something, somewhere: not getting the let_subst treatment. 4 | 5 | (define (eq? a b) 6 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 7 | 8 | (datatype list (:nil) (:cons 'a (list 'a))) 9 | (datatype color (:red) (:green)) 10 | 11 | ;; bug is in wrapped let_subst somehow, probably need to be performed 12 | ;; in a particular direction, and we're doing it wrong. 13 | 14 | (define (thing exps) 15 | (define recur 16 | () -> 0 17 | (xx . tl) -> (match xx with 18 | 0 -> (recur tl) 19 | yy -> (recur (list:cons yy tl)) 20 | )) 21 | (recur exps)) 22 | -------------------------------------------------------------------------------- /tests/t_match4.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (:nil) 4 | (:cons 'a (list 'a))) 5 | 6 | (define (error) 7 | (%exit #f #u) 8 | ) 9 | 10 | (define thing 11 | (list:nil) -> (error) 12 | (list:cons x _) -> x 13 | ) 14 | 15 | (thing '(1 2 3)) 16 | 17 | 18 | -------------------------------------------------------------------------------- /tests/t_match5.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (eq? a b) 3 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 4 | 5 | (define (error x) 6 | (%exit #f x) 7 | ) 8 | 9 | (define flip 10 | 0 -> 1 11 | 1 -> 0 12 | x -> (error "flipped out!") 13 | ) 14 | 15 | (flip 0) 16 | -------------------------------------------------------------------------------- /tests/t_match6.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (eq? a b) 3 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 4 | 5 | (define (+ a b) 6 | (%%cexp (int int -> int) "%0+%1" a b)) 7 | 8 | (define thing 9 | 0 1 -> 2 10 | 0 y -> 3 11 | 1 0 -> 4 12 | 1 x -> (+ x 5) 13 | y z -> (+ y z) 14 | ) 15 | 16 | (thing 10 20) 17 | -------------------------------------------------------------------------------- /tests/t_match8.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (:nil) 4 | (:cons 'a (list 'a)) 5 | ) 6 | 7 | (datatype symbol (:t string)) 8 | 9 | (define (eq? a b) 10 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 11 | 12 | (define parse 13 | () -> 0 14 | ('expr . _) -> 1 15 | _ -> 2 16 | ) 17 | 18 | (define (printn x) 19 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 20 | 21 | (let ((x '(expr a b c))) 22 | (printn x) 23 | (parse x)) 24 | -------------------------------------------------------------------------------- /tests/t_match9.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | ;; test 5 | 6 | (define (frob n) 7 | (match (* n n) with 8 | 0 -> 'zed 9 | 1 -> 'one 10 | 4 -> 'two 11 | x -> (error "bad arg to frob"))) 12 | 13 | {a=(frob 0) b=(frob 1) c=(frob 2)} 14 | -------------------------------------------------------------------------------- /tests/t_match_bool.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define thing 6 | #t -> 0 7 | #f -> 1 8 | ) 9 | 10 | (printn (thing (bool:false))) 11 | (printn (thing (bool:true))) 12 | 13 | 14 | -------------------------------------------------------------------------------- /tests/t_match_char.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | (define thing 4 | #\A -> 0 5 | #\B -> 1 6 | #\C -> 2 7 | _ -> 3 8 | ) 9 | 10 | (printn (thing #\A)) 11 | (printn (thing #\B)) 12 | (printn (thing #\C)) 13 | (printn (thing #\D)) 14 | -------------------------------------------------------------------------------- /tests/t_match_onearm.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; goal: if a datatype has only one arm, the compiler should *not* 4 | ;; emit an nvcase for it. (NYI 2016.08) 5 | 6 | (define (printn x) 7 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 8 | 9 | (define (+ a b) 10 | (%%cexp (int int -> int) "%0+%1" a b)) 11 | 12 | (datatype thing 13 | (:t {a=int b=int}) 14 | ) 15 | 16 | (define add-thing 17 | (thing:t {a=a b=b}) 18 | -> (+ a b)) 19 | 20 | (printn (add-thing (thing:t {a=1 b=3}))) 21 | -------------------------------------------------------------------------------- /tests/t_match_pvariant.exp: -------------------------------------------------------------------------------- 1 | 9 2 | 7 3 | 9 4 | 7 5 | #u 6 | -------------------------------------------------------------------------------- /tests/t_match_pvariant.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (printn x) 4 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 5 | 6 | (define (eq? a b) 7 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 8 | 9 | (define thing 10 | (:pair x 2) -> x 11 | (:pair 3 y) -> y 12 | (:pair x y) -> x 13 | (:dude z) -> z 14 | ) 15 | 16 | (printn (thing (:pair 9 2))) 17 | (printn (thing (:pair 3 7))) 18 | (printn (thing (:pair 9 9))) 19 | (printn (thing (:dude 7))) 20 | -------------------------------------------------------------------------------- /tests/t_match_pvariant0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (printn x) 4 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 5 | 6 | (define (eq? a b) 7 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 8 | 9 | (define thing 10 | (:pair x 2) -> x 11 | (:pair 3 y) -> y 12 | (:pair x y) -> x 13 | (:dude z) -> z 14 | ) 15 | 16 | (printn (thing (:pair 9 2))) 17 | (printn (thing (:pair 3 7))) 18 | (printn (thing (:pair 9 9))) 19 | (printn (thing (:dude 7))) 20 | -------------------------------------------------------------------------------- /tests/t_match_record.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (define thing 5 | {a=x b=2} -> x 6 | {a=3 b=y} -> y 7 | {a=m b=n} -> (+ m n) 8 | ) 9 | 10 | ;; => 11 | ;; (define (thing r) 12 | ;; (match r.a r.b with 13 | ;; x 2 -> x 14 | ;; 3 y -> y 15 | ;; )) 16 | 17 | (printn (thing {a=3 b=1})) 18 | (printn (thing {a=3 b=2})) 19 | (printn (thing {a=4 b=5})) 20 | 21 | -------------------------------------------------------------------------------- /tests/t_match_string.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (define thing 8 | "testing" -> #t 9 | "blurble" -> #t 10 | _ -> #f 11 | ) 12 | 13 | (printn (thing "blurble")) 14 | (printn (thing "not really")) 15 | 16 | -------------------------------------------------------------------------------- /tests/t_maze.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/basis.scm") 4 | (require-ffi 'posix) 5 | 6 | ;; https://10print.org/ 7 | ;; 10 PRINT CHR$(205.5+RND(1)); : GOTO 10 8 | 9 | (while #t (printf (if (= 0 (mod (posix/random) 2)) "╱" "╲"))) 10 | -------------------------------------------------------------------------------- /tests/t_multiple.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (let (((q r) (divmod 1000 3))) 7 | (printf "q= " (int q) " r= " (int r) "\n") 8 | ) 9 | -------------------------------------------------------------------------------- /tests/t_multiple2.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (let (((q0 r0) (divmod 1000 3)) 6 | ((q1 r1) (divmod 555 9)) 7 | (n 34) 8 | ((q2 r2) (divmod 3141 7))) 9 | (printn q0) 10 | (printn r0) 11 | (printn q1) 12 | (printn r1) 13 | (printn n) 14 | (printn q2) 15 | (printn r2) 16 | ) 17 | -------------------------------------------------------------------------------- /tests/t_mutex.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (require "lib/basis.scm") 4 | (require "doom/doom.scm") 5 | (require "doom/sync.scm") 6 | 7 | (define the-mutex (mutex/make)) 8 | 9 | (define (worker n) 10 | (with-mutex the-mutex 11 | (debugf "worker: " (int n) "\n") 12 | (when (and (> n 2) (< n 6)) 13 | (timeq/sleep 3000)))) 14 | 15 | (for-range i 8 16 | (poller/fork (lambda () (worker i)))) 17 | 18 | (poller/wait-and-schedule) 19 | -------------------------------------------------------------------------------- /tests/t_namedlet0.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | ;; http://groups.google.com/group/comp.lang.scheme/msg/3e2d267c8f0ef180 5 | 6 | (define (negate n) 7 | (- 0 n)) 8 | 9 | (let ((f negate)) 10 | (let f ((n (f 1))) n)) 11 | -------------------------------------------------------------------------------- /tests/t_neg.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | (define (thing x) 4 | (if (eq? x -1) 5 | "yes" 6 | "no")) 7 | 8 | (thing (- 0 1)) 9 | -------------------------------------------------------------------------------- /tests/t_nth.exp: -------------------------------------------------------------------------------- 1 | 5 2 | 0 3 | 4 | *** 5 | Runtime Error, halting: "list index out of range" 6 | "list index out of range" 7 | -------------------------------------------------------------------------------- /tests/t_nth.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (printn (nth '(0 1 2 3 4 5 6 7) 5)) 7 | (printn (nth '(0 1 2 3) 0)) 8 | (printn (nth '(0 1 2 3) 9)) 9 | -------------------------------------------------------------------------------- /tests/t_nvcase0.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype list 3 | (:nil) 4 | (:cons 'a (list 'a)) 5 | ;; because of the hard-coded TC_PAIR tags, users can't do this any more 6 | ;; (:blurt 'a) 7 | ) 8 | 9 | (define (printn x) 10 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 11 | 12 | (define (error x) 13 | (printn x) 14 | (%%cexp (-> 'a) "exit_continuation();") 15 | (%%cexp (-> 'a) "IRK_UNDEFINED") 16 | ) 17 | 18 | (define (thing x) 19 | (vcase list x 20 | ((:cons hd tl) hd) 21 | (else (error "empty list?")))) 22 | 23 | (thing '(1 2 3)) 24 | -------------------------------------------------------------------------------- /tests/t_nvcase1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define thing1 6 | #\newline -> 0 7 | #\space -> 1 8 | #\tab -> 2 9 | _ -> 3 10 | ) 11 | 12 | (datatype color 13 | (:red) 14 | (:green) 15 | (:blue) 16 | ) 17 | 18 | (define thing2 19 | (color:red) -> 0 20 | (color:green) -> 1 21 | (color:blue) -> 2 22 | ) 23 | 24 | (printn (thing1 #\space)) 25 | (printn (thing2 (color:blue))) 26 | 27 | 28 | -------------------------------------------------------------------------------- /tests/t_pack.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (define (cmp-first a b) 7 | (= (first a) (first b))) 8 | 9 | ;; this verifies that the packing is 'stable' 10 | (pack '((1 0) (1 1) (1 2) (2 0) (3 0) (3 1) (3 2) (4 0) (4 1) (2 1) (2 2) (2 3)) cmp-first) 11 | -------------------------------------------------------------------------------- /tests/t_pack1.exp: -------------------------------------------------------------------------------- 1 | "\x11\x17\xf1\xfb.\xff\xfa\xec\xa2\x0f\xe1\x12\xb9\xb0\xa1testing!" 2 | 17 3 | 23 4 | -15 5 | -1234 6 | 65530 7 | -324923423 8 | 314159265 9 | "testing!" 10 | val: 0x1234abcd 11 | val: 0xe49 12 | val: 0xdeadbeef 13 | val: 0x2a7d1ef2 14 | {u0 0 1 2 7} 15 | -------------------------------------------------------------------------------- /tests/t_pack1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/pack.scm") 5 | 6 | (let ((p (pbuf/make 10))) 7 | (p@u8 17) 8 | (p@u8 23) 9 | (p@i8 -15) 10 | (p@i16 -1234) 11 | (p@u16 65530) 12 | (p@i32 -324923423) 13 | (p@u32 314159265) 14 | (p@string "testing!") 15 | (let ((v (p@val)) 16 | (u (ubuf/make v))) 17 | (printn v) 18 | (printn (u@u8)) 19 | (printn (u@u8)) 20 | (printn (u@i8)) 21 | (printn (u@i16)) 22 | (printn (u@u16)) 23 | (printn (u@i32)) 24 | (printn (u@u32)) 25 | (printn (u@string 8)) 26 | ) 27 | ) 28 | 29 | (printf "val: 0x" (hex (packbits (16 #xabcd) (16 #x1234))) "\n") 30 | (printf "val: 0x" (hex (packbits (3 1) (3 1) (3 1) (3 7))) "\n") 31 | (printf "val: 0x" (hex (packbits (8 #xef) (8 #xbe) (8 #xad) (8 #xde))) "\n") 32 | (printf "val: 0x" (hex (packbits (18 73458) (12 2719))) "\n") 33 | (let ((v0 (packbits (3 0) (3 1) (3 2) (3 7))) 34 | (r {a=0 b=0 c=0 d=0})) 35 | (unpackbits v0 (3 r.a) (3 r.b) (3 r.c) (3 r.d)) 36 | r) 37 | -------------------------------------------------------------------------------- /tests/t_pem.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/codecs/base64.scm") 6 | (include "lib/codecs/hex.scm") 7 | (include "lib/asn1/ber.scm") 8 | (include "lib/crypto/pem.scm") 9 | 10 | (define (main) 11 | (let ((g0 (file-char-generator 12 | (file/open-read sys.argv[1])))) 13 | (printf ";; path: " sys.argv[1] "\n") 14 | (for section (pem-gen g0) 15 | (match section with 16 | (:tuple label data) 17 | -> (begin 18 | (printf ";; DER " (string->hex data) "\n") 19 | (printf ";; PEM " (string label)) 20 | (pp-ber (ber->asn1 data) 0) 21 | (printf "\n") 22 | ) 23 | )))) 24 | 25 | (main) 26 | -------------------------------------------------------------------------------- /tests/t_permutations.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/combinatorics.scm") 6 | 7 | (for perm (permutations '(0 1 2 3 4)) 8 | (printn perm)) 9 | -------------------------------------------------------------------------------- /tests/t_pop.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (let ((l '(1 2 3 4 5))) 7 | (printn (pop! l)) 8 | (printn (pop! l)) 9 | (printn (pop! l)) 10 | (printn (pop! l)) 11 | (printn (pop! l)) 12 | (printn (pop! l))) 13 | -------------------------------------------------------------------------------- /tests/t_pow.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (printf "13^16 " (int (pow 13 16)) "\n") 7 | -------------------------------------------------------------------------------- /tests/t_pv0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (printn x) 4 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 5 | 6 | (define (thing a) 7 | (vcase a 8 | ((:one x y) x) 9 | ((:two z) z) 10 | ((:urk) 0) 11 | )) 12 | 13 | (printn (thing (:one 12 3))) 14 | (printn (thing (:urk))) 15 | (printn (thing (:two 9))) 16 | 17 | 18 | -------------------------------------------------------------------------------- /tests/t_pv1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (eq? a b) 4 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 5 | 6 | (define (+ a b) 7 | (%%cexp (int int -> int) "%0+%1" a b)) 8 | 9 | (define (- a b) 10 | (%%cexp (int int -> int) "%0-%1" a b)) 11 | 12 | (define klength 13 | (:nil) -> 0 14 | (:kons _ y) -> (+ 1 (klength y))) 15 | 16 | (define kn 17 | 0 -> (:nil) 18 | n -> (:kons n (kn (- n 1)))) 19 | 20 | (klength (kn 5)) 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /tests/t_quine1.exp: -------------------------------------------------------------------------------- 1 | t_quine1.scm -------------------------------------------------------------------------------- /tests/t_quine1.scm: -------------------------------------------------------------------------------- 1 | (define q '(40 114 101 113 117 105 114 101 32 34 108 105 98 47 98 97 115 105 115 46 115 99 109 34 41 10 40 112 114 105 110 116 102 32 34 40 100 101 102 105 110 101 32 113 32 39 40 34 32 40 106 111 105 110 32 105 110 116 45 62 115 116 114 105 110 103 32 34 32 34 32 113 41 32 34 41 41 10 34 41 10 40 102 111 114 45 108 105 115 116 10 32 32 102 111 114 109 10 32 32 40 114 101 97 100 45 115 116 114 105 110 103 32 40 108 105 115 116 45 62 115 116 114 105 110 103 32 40 109 97 112 32 97 115 99 105 105 45 62 99 104 97 114 32 113 41 41 41 10 32 32 40 112 112 32 102 111 114 109 32 54 48 41 41 10 35 117 10)) 2 | (require "lib/basis.scm") 3 | (printf "(define q '(" (join int->string " " q) "))\n") 4 | (for-list 5 | form 6 | (read-string (list->string (map ascii->char q))) 7 | (pp form 60)) 8 | #u 9 | -------------------------------------------------------------------------------- /tests/t_read_file0.exp: -------------------------------------------------------------------------------- 1 | file length=425 2 | #u 3 | -------------------------------------------------------------------------------- /tests/t_read_file0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/os.scm") 5 | 6 | (define (read-file path) 7 | (let ((ifile (file/open-read path))) 8 | (let loop ((buf (file/read-buffer ifile)) 9 | (l '())) 10 | (cond ((= (string-length buf) 0) (string-concat (reverse l))) 11 | (else (loop (file/read-buffer ifile) 12 | (list:cons buf l))))))) 13 | 14 | (let ((s (read-file (if (> sys.argc 1) sys.argv[1] "tests/t_read_file0.scm")))) 15 | (print-string s) 16 | (print-string (format "file length=" (int (string-length s)) "\n"))) 17 | -------------------------------------------------------------------------------- /tests/t_recmac.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | ;; test macros that output record literals and attribute references. 6 | 7 | (defmacro thing 8 | (thing a b) 9 | -> {x=a y=b} 10 | ) 11 | 12 | (defmacro yattr 13 | (yattr ob) 14 | -> ob.y 15 | ) 16 | 17 | (defmacro attr 18 | (attr ob z) 19 | -> ob.z 20 | ) 21 | 22 | (defmacro mkrec 23 | (mkrec field val) 24 | -> {field=val} 25 | ) 26 | 27 | (let ((o (thing 1 2))) 28 | (printn (+ (yattr o) (attr o x))) 29 | (printn (mkrec z 34)) 30 | ) 31 | 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /tests/t_record_literal1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | {a=0 b=1 c=2} 4 | -------------------------------------------------------------------------------- /tests/t_recur.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (define (thing n) 7 | (if (zero? n) 8 | (maybe:no) 9 | (maybe:yes { sub=(thing (- n 1)) }))) 10 | 11 | (thing 5) 12 | -------------------------------------------------------------------------------- /tests/t_recur0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (thing n) 4 | thing) 5 | 6 | (thing 5) 7 | -------------------------------------------------------------------------------- /tests/t_recur1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define (eq? a b) 4 | (%%cexp ('a 'a -> bool) "%0==%1" a b)) 5 | 6 | (define (+ a b) 7 | (%%cexp (int int -> int) "%0+%1" a b)) 8 | 9 | (define (kons x l) 10 | (:kons x l)) 11 | 12 | (define (klength l) 13 | (define loop 14 | (:nil) n -> n 15 | (:kons _ tl) n -> (loop tl (+ n 1)) 16 | ) 17 | (loop l 0) 18 | ) 19 | 20 | (klength (kons 1 (kons 2 (kons 3 (:nil))))) 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /tests/t_recursive.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (define zength 7 | acc {next=(maybe:yes x)} -> (zength (+ acc 1) x) 8 | acc {next=(maybe:no)} -> acc) 9 | 10 | (zength 0 {next=(maybe:no)}) 11 | 12 | -------------------------------------------------------------------------------- /tests/t_row0.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (datatype thing 5 | (:one {x=int y=char ...}) 6 | (:two int) 7 | ) 8 | 9 | (let ((x (thing:one {x=3 y=#\A})) 10 | (y (thing:one {x=1 y=#\Z z=3})) 11 | (z (thing:two 9)) 12 | ;;(y (thing:one {x=1 y=#\Z})) 13 | ) 14 | (printn x) 15 | (printn y) 16 | (printn z) 17 | ) 18 | -------------------------------------------------------------------------------- /tests/t_row1.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (datatype thing 5 | (:one {x=int y=thing ...}) 6 | (:two int) 7 | ) 8 | 9 | (define frob 10 | (thing:two x) -> (thing:two (* x 2)) 11 | (thing:one r) -> (thing:one {x=(* r.x 2) y=(frob r.y)}) 12 | ) 13 | 14 | (let ((x (thing:one {x=3 y=(thing:two 9)}))) 15 | (printn x) 16 | (printn (frob x)) 17 | ) 18 | -------------------------------------------------------------------------------- /tests/t_row2.scm: -------------------------------------------------------------------------------- 1 | 2 | ;;(include "lib/core.scm") 3 | 4 | (define (printn x) 5 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 6 | 7 | (datatype glork 8 | (:x 'a) 9 | (:y 'a 'a)) 10 | 11 | (datatype thing 12 | (:one {x=int ...}) 13 | ) 14 | 15 | (let ((x (thing:one {x=3})) 16 | (y (thing:one {x=1 y=3})) 17 | ) 18 | (printn x) 19 | (printn y) 20 | ) 21 | -------------------------------------------------------------------------------- /tests/t_set.exp: -------------------------------------------------------------------------------- 1 | #f 2 | #f 3 | #t 4 | #t 5 | 6 | #f 7 | #f 8 | #t 9 | #t 10 | 11 | (94 15 12) 12 | (thing a y) 13 | #u 14 | -------------------------------------------------------------------------------- /tests/t_set_ptr.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (let ((int5* (halloc ushort 5)) 7 | (int5** (halloc (* ushort) 5)) 8 | (p0 (c-aref int5** 0)) 9 | (p1 (c-aref int5* 0)) 10 | ) 11 | (c-set-int p1 3141) 12 | (c-set-ptr p0 p1) 13 | (assert (= 3141 (c-get-int (c-get-ptr p0)))) 14 | (for-range i 5 15 | (c-set-int (c-aref int5* i) (* i i)) 16 | (c-set-ptr (c-aref int5** i) (c-aref int5* i)) 17 | ) 18 | (let ((r '())) 19 | (for-range i 5 20 | (push! r (c-get-int (c-aref int5* i)))) 21 | (assert (eq? (cmp:=) (list-cmp int-cmp r '(16 9 4 1 0)))) 22 | ) 23 | ) 24 | -------------------------------------------------------------------------------- /tests/t_sexp0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (pp (sexp (int 1) (sym 'x) (char #\a) (sexp (int 0) (int 3) (string "test"))) 20) 7 | (pp (sexp (rec (a (sym 'int)) (b (sym 'list)))) 20) 8 | (define list0 (sexp (int 0) (int 1) (int 2))) 9 | (define list1 (sexpl (int 0) (int 1) (int 2))) 10 | (pp (sexp (string "[") list0 (string "]")) 20) 11 | (pp (sexp (string "[") (list list1) (string "]") 12 | (undef) (cons 'list 'nil) 13 | (attr (sym 'x) 'name) 14 | (attr (sexp (int 0) (int 1)) 'name) 15 | (vec (int 0) (int 1) (int 2)) 16 | ) 17 | 10) 18 | -------------------------------------------------------------------------------- /tests/t_sha1.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/codecs/hex.scm") 6 | (include "lib/crypto/sha1.scm") 7 | 8 | (define (t0) 9 | (let ((strings '("testing" ", testing!\n"))) 10 | (assert 11 | (string=? 12 | "fbf8c65de539027c21c84cd3544aaf18e8786c90" 13 | (string->hex (sha1 (list-generator strings))))))) 14 | 15 | (define (t1) 16 | (define (gen) 17 | (makegen emit 18 | (for-range i 100 19 | (let ((ch (int->char i)) 20 | (part (format (repeat 17 (char ch))))) 21 | (emit part))))) 22 | (assert 23 | (string=? 24 | "9cbe914e14e2ebeeb126ffda120638997e664774" 25 | (string->hex (sha1 (gen)))))) 26 | 27 | (t0) 28 | (t1) 29 | 30 | -------------------------------------------------------------------------------- /tests/t_sha256.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | (include "lib/format.scm") 7 | (include "demo/sha256.scm") 8 | 9 | (define (string->hex s) 10 | (format 11 | (join 12 | (map 13 | (lambda (x) (format (zpad 2 (hex x)))) 14 | (map char->int (string->list s)))))) 15 | 16 | (assert 17 | (string=? "62812653f2165f5437bb2eae59819dbc4ecdbd40ece9cf62f6911d5b7de1074c" 18 | (string->hex (sha256 "onomatopoeia")))) 19 | -------------------------------------------------------------------------------- /tests/t_single_dt.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype thing 4 | (:t int int)) 5 | 6 | (define second 7 | (thing:t _ x) -> x 8 | ) 9 | 10 | (second (thing:t 5 4)) 11 | -------------------------------------------------------------------------------- /tests/t_small.exp: -------------------------------------------------------------------------------- 1 | 42 2 | -------------------------------------------------------------------------------- /tests/t_small.scm: -------------------------------------------------------------------------------- 1 | 42 2 | -------------------------------------------------------------------------------- /tests/t_sort.exp: -------------------------------------------------------------------------------- 1 | (17907 58577 31150 37731 87344 14969 7748 70250 80452 83177 74608 12566 40331 84455 31723 85178 89745 83699 60577 62183 40394 58455 42631 33163 42193 4593 69381 94656 11394 73105 19482 63824 71233 16181 29982 741 18165 8219 95642 67886 42846 73801 64491 55153 78357 31672 8249 11210 43305 2121 19551 90879 99910 21686 63782 47537 76847 79924 58821 31217 1872 3301 17490 54139 81664 21763 5099 50279 65373 5488 3395 87693 95444 16467 30551 67147 88367 6128 91659 36074 85859 81513 27097 36021 28486 67506 88715 45630 78052 55520 97375 31380 5285 95726 49040 31385 40038 99611 30532 77680) 2 | (741 1872 2121 3301 3395 4593 5099 5285 5488 6128 7748 8219 8249 11210 11394 12566 14969 16181 16467 17490 17907 18165 19482 19551 21686 21763 27097 28486 29982 30532 30551 31150 31217 31380 31385 31672 31723 33163 36021 36074 37731 40038 40331 40394 42193 42631 42846 43305 45630 47537 49040 50279 54139 55153 55520 58455 58577 58821 60577 62183 63782 63824 64491 65373 67147 67506 67886 69381 70250 71233 73105 73801 74608 76847 77680 78052 78357 79924 80452 81513 81664 83177 83699 84455 85178 85859 87344 87693 88367 88715 89745 90879 91659 94656 95444 95642 95726 97375 99611 99910) 3 | #u 4 | -------------------------------------------------------------------------------- /tests/t_sort.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/random.scm") 6 | 7 | (srandom 314159) 8 | 9 | (define nrandom 10 | acc 0 -> acc 11 | acc n -> (nrandom 12 | (list:cons (mod (random) 100000) acc) 13 | (- n 1))) 14 | 15 | (let ((rl (nrandom '() 100))) 16 | (printn rl) 17 | (printn (sort < rl))) 18 | -------------------------------------------------------------------------------- /tests/t_sorted_list.exp: -------------------------------------------------------------------------------- 1 | (1 20) 2 | (1 5 20) 3 | (#f #f) 4 | (#f #f #t) 5 | #u 6 | -------------------------------------------------------------------------------- /tests/t_sorted_list.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | 5 | ;; #t > #f 6 | (define (bool->? a b) 7 | (if a #t #f)) 8 | 9 | (define (list/insert x > l) 10 | (match l with 11 | () -> (list:cons x l) 12 | (hd . tl) -> (if (> hd x) 13 | (list:cons x l) 14 | (list:cons hd (list/insert x > tl))) 15 | )) 16 | 17 | (let ((l0 (list 20)) 18 | (l1 (list #f)) 19 | ) 20 | (set! l0 (list/insert 1 > l0)) 21 | (printn l0) 22 | (set! l0 (list/insert 5 > l0)) 23 | (printn l0) 24 | (set! l1 (list/insert #f bool->? l1)) 25 | (printn l1) 26 | (set! l1 (list/insert #t bool->? l1)) 27 | (printn l1) 28 | ) 29 | 30 | -------------------------------------------------------------------------------- /tests/t_stack.exp: -------------------------------------------------------------------------------- 1 | 2 | {u1 1 } 3 | {u1 2 {u1 1 }} 4 | 2 5 | {u1 1 } 6 | 1 7 | 8 | "underflow" 9 | 1 10 | -------------------------------------------------------------------------------- /tests/t_stack.scm: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | ;; what are the rules for deciding when it's safe to inline an argument/function? 5 | 6 | ;; in this case: 7 | ;;(let ((y 5)) 8 | ;; ((lambda (x) (set! y 3) x) y)) 9 | ;; we should *not* inline the inside the function, because 10 | ;; it is assigned to. but will this transformation work? 11 | ;(let ((y 5)) 12 | ; (let ((y2 y)) 13 | ; (set! y 3) 14 | ; y2)) 15 | 16 | ;; two different vars to worry about. 17 | ;; ((lambda (x) ...) y) 18 | ;; assign to y (either inside or outside the fun) 19 | ;; assign to x 20 | ;; 21 | ;; assignment to *either* requires making it a 22 | 23 | (define (printn x) 24 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 25 | 26 | (define (error x) 27 | (%exit #f x) 28 | ) 29 | 30 | (let ((stack (:empty))) 31 | 32 | (define (push item) 33 | (set! stack (:elem item stack))) 34 | 35 | (define (pop) 36 | (vcase stack 37 | ((:empty) (error "underflow")) 38 | ((:elem item rest) 39 | (set! stack rest) 40 | item))) 41 | 42 | (printn stack) 43 | (push 1) 44 | (printn stack) 45 | (push 2) 46 | (printn stack) 47 | (printn (pop)) 48 | (printn stack) 49 | (printn (pop)) 50 | (printn stack) 51 | (printn (pop)) 52 | (printn stack) 53 | ) 54 | 55 | -------------------------------------------------------------------------------- /tests/t_stack0.exp: -------------------------------------------------------------------------------- 1 | 6(5 4 3) 2 | 3 3 | #\B 4 | #\A 5 | (#f #t) 6 | 7 | *** 8 | Runtime Error, halting: "stack underflow" 9 | "stack underflow" 10 | -------------------------------------------------------------------------------- /tests/t_stack0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; test lib/stack.scm 4 | 5 | (include "lib/core.scm") 6 | (include "lib/pair.scm") 7 | (include "lib/stack.scm") 8 | 9 | (let ((s0 (make-stack)) 10 | (s1 (make-stack)) 11 | (s2 (make-stack)) 12 | ) 13 | (s0.push 3) 14 | (s0.push 4) 15 | (s1.push #t) 16 | (s1.push #f) 17 | (s0.push 5) 18 | (s0.push 6) 19 | (print (s0.pop)) 20 | (printn (s0.get)) 21 | (s2.push #\A) 22 | (printn (s0.length)) 23 | (s2.push #\B) 24 | (printn (s2.pop)) 25 | (printn (s2.pop)) 26 | (printn (s1.get)) 27 | (s1.pop) 28 | (s1.pop) 29 | (s1.pop) 30 | ) 31 | -------------------------------------------------------------------------------- /tests/t_stack2.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; test lib/stack2.scm 4 | 5 | (include "lib/core.scm") 6 | (include "lib/pair.scm") 7 | (include "lib/stack2.scm") 8 | 9 | (let ((s0 (new-stack)) 10 | (s1 (new-stack)) 11 | (s2 (new-stack)) 12 | ) 13 | (s0::push 3) 14 | (s0::push 4) 15 | (s1::push #t) 16 | (s1::push #f) 17 | (s0::push 5) 18 | (s0::push 6) 19 | (print (s0::pop)) 20 | (printn (s0::get)) 21 | (s2::push #\A) 22 | (printn (s0::len)) 23 | (s1::pop) 24 | (s1::pop) 25 | (s2::push #\B) 26 | ;; (s1::pop) 27 | (printn (s2::pop)) 28 | (printn (s2::pop)) 29 | (printn (s1::get)) 30 | ) 31 | -------------------------------------------------------------------------------- /tests/t_startswith.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (defmacro verify 8 | (verify) -> #t 9 | (verify truth test rest ...) 10 | -> (if (not (eq? truth test)) 11 | (error "failed assertion") 12 | (verify rest ...)) 13 | ) 14 | 15 | (verify 16 | #t (starts-with "moose" "moo") 17 | #f (starts-with "noose" "moo") 18 | #f (starts-with "moo" "moose") 19 | #t (starts-with "abcd" "") 20 | #f (starts-with "" "abcd") 21 | #f (starts-with "foo" "bar") 22 | #f (starts-with "foo" "fox") 23 | #f (starts-with "foo" "fox") 24 | ) 25 | -------------------------------------------------------------------------------- /tests/t_stdio.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (let ((FILE* (stdio/open-read sys.argv[1]))) 7 | (for ch (stdio-char-generator FILE*) 8 | (printf (char ch)) 9 | ) 10 | (printf "\n") 11 | (stdio/close FILE*) 12 | ) 13 | 14 | -------------------------------------------------------------------------------- /tests/t_stl.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | (cverbatim " 4 | #include 5 | std::list my_list; 6 | ") 7 | 8 | (define (push-back n) 9 | (%%cexp (int -> undefined) "my_list.push_back(%0)" n)) 10 | 11 | (define (size) 12 | (%%cexp (-> int) "my_list.size()")) 13 | 14 | (define (pop-front) 15 | (%%cexp (-> undefined) "my_list.pop_front()") #u) 16 | 17 | (define (front) 18 | (%%cexp (-> int) "my_list.front()")) 19 | 20 | (push-back 10) 21 | (push-back 20) 22 | (printn (size)) 23 | (printn (front)) 24 | (printn (pop-front)) 25 | (printn (front)) 26 | (printn (pop-front)) 27 | -------------------------------------------------------------------------------- /tests/t_string0.scm: -------------------------------------------------------------------------------- 1 | "testing" 2 | -------------------------------------------------------------------------------- /tests/t_string1.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | (include "lib/string.scm") 5 | 6 | (define s0 "testing") 7 | 8 | (string-set! s0 0 #\T) 9 | (printn s0) 10 | ;; should trigger an out-of-bounds error 11 | (string-ref s0 20) 12 | 13 | -------------------------------------------------------------------------------- /tests/t_string2.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | (include "lib/string.scm") 5 | 6 | (string->int "345") 7 | -------------------------------------------------------------------------------- /tests/t_string_append.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | (include "lib/string.scm") 4 | 5 | (printn (string-append "not " "today " "zurg!")) 6 | (printn (string-append)) 7 | (printn (string-append "stuff!")) 8 | (printn (string-append "a" "b" "c" "d")) 9 | -------------------------------------------------------------------------------- /tests/t_string_concat.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | (include "lib/string.scm") 4 | 5 | (let ((sl 6 | (list:cons 7 | "not " 8 | (list:cons 9 | "today " 10 | (list:cons 11 | "zurg!" 12 | (list:nil)))))) 13 | (print (string-concat sl))) 14 | -------------------------------------------------------------------------------- /tests/t_string_find0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (printn (string-find "xyz" "-------xyz----------")) 8 | (printn (string-find "xyz" "--------------------")) 9 | (printn (string-find "xyz" "------------------xy")) 10 | (printn (string-find "xyz" "xyz-----------------")) 11 | (printn (string-find "xyz" "-----------------xyz")) 12 | (printn (string-find "xyz" "xy---------------xyz")) 13 | (printn (string-find "xyz" "xy------------------")) 14 | (printn (string-find "xyz" "-----xyxyxyz--------")) 15 | -------------------------------------------------------------------------------- /tests/t_string_join.exp: -------------------------------------------------------------------------------- 1 | "quick brown fox" 2 | "%%vcon/list/cons" 3 | "thing" 4 | #u 5 | -------------------------------------------------------------------------------- /tests/t_string_join.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | (include "lib/string.scm") 4 | 5 | (printn (string-join '("quick" "brown" "fox") " ")) 6 | (printn (string-join '("%%vcon" "list" "cons") "/")) 7 | (printn (string-join '("thing") ",")) 8 | -------------------------------------------------------------------------------- /tests/t_string_split.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | (include "lib/format.scm") 7 | 8 | (printn (string-split "quick brown fox" #\space)) 9 | (printn (string-split "%%vcon/list/cons" #\/)) 10 | (printn (string-split "thing" #\/)) 11 | (printn (string-split "" #\a)) 12 | (printn (string-split "..." #\.)) 13 | (printn (string-split "%0 %% %1" #\%)) 14 | 15 | -------------------------------------------------------------------------------- /tests/t_string_split_string.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (printn (string-split-string "------aaaa------aaaa-------" "aaaa")) 7 | (printn (string-split-string "------aaaa------aaaa-------" "bbbb")) 8 | (printn (string-split-string "------aaaa------aaaa" "aaaa")) 9 | (printn (string-split-string "------a------aaaa" "a")) 10 | (printn (string-split-string "aaa---a---aaa---" "aaa")) 11 | (printn (string-split-string "aaaaa---a---aaaaa---" "aaa")) 12 | 13 | (printn (string-split-string "header0: value0\r\nheader1: value1\r\nheader2: value2\r\n\r\n" "\r\n")) 14 | (printn (string-split-string "header0: value0\r\nheader1: value1\r\nheader2: value2\r\n" "\r\n")) 15 | (printn (string-split-string "header0: value0\r\nheader1: value1\r\nheader2: value2" "\r\n")) 16 | (printn (string-split-string "header0: value0" "\r\n")) 17 | (printn (string-split-string "header0: value0\r" "\r\n")) 18 | (printn (string-split-string "header0: value0\r\n" "\r\n")) 19 | 20 | (printn (string-replace-all "aaaaa---a---aaaaa---" "aaa" "b")) 21 | 22 | -------------------------------------------------------------------------------- /tests/t_strlen.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | 6 | (libc/strlen (cstring "howdythere\x00")) 7 | -------------------------------------------------------------------------------- /tests/t_symbols.exp: -------------------------------------------------------------------------------- 1 | (not-final not-final whitespace not-final not-final comment newline) 2 | -------------------------------------------------------------------------------- /tests/t_symbols.scm: -------------------------------------------------------------------------------- 1 | ;; create a bunch of symbols. 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | (include "lib/frb.scm") 7 | (include "lib/symbol.scm") 8 | 9 | '(not-final not-final whitespace not-final not-final comment newline) 10 | ;; not-final not-final string1 not-final not-final mulop augassign bitand 11 | ;; not-final not-final string2 not-final not-final lparen rparen mulop 12 | ;; power addop comma addop getattr mulop mulop number colon semicolon 13 | ;; compare shift compare assign compare compare compare shift ident ident 14 | ;; lbrace rbrace bitxor ident ident ident) 15 | -------------------------------------------------------------------------------- /tests/t_symbols0.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | (printn '(foo bar foo bar)) 4 | 5 | -------------------------------------------------------------------------------- /tests/t_symbols1.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | (include "lib/pair.scm") 3 | (include "lib/string.scm") 4 | (include "lib/frb.scm") 5 | (include "lib/symbol.scm") 6 | 7 | (eq? 'thingy (string->symbol "thingy")) 8 | (printn the-symbol-table) 9 | (let ((s0 (string->symbol "abc")) 10 | (s1 (string->symbol "def")) 11 | ) 12 | (printn (symbol->index 'thingy)) 13 | (printn (symbol->index s0)) 14 | (printn (symbol->index s1)) 15 | (printn the-symbol-table) 16 | ) 17 | 18 | -------------------------------------------------------------------------------- /tests/t_tail.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (+ a b) 3 | (%%cexp (int int -> int) "%0+%1" a b)) 4 | 5 | (define (thing1 x) 6 | (define (thing2) 7 | (+ 10 x) 8 | ) 9 | (thing2) 10 | ) 11 | 12 | (thing1 5) 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /tests/t_typealias0.exp: -------------------------------------------------------------------------------- 1 | {u0 {u0 1 3}} 2 | {u1 {u0 2 #\A}} 3 | #u 4 | -------------------------------------------------------------------------------- /tests/t_typealias0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (typealias ralias {a=int b='a}) 6 | 7 | (datatype thing 8 | (:one (ralias int)) 9 | (:two (ralias char)) 10 | ) 11 | 12 | (define thing1 (thing:one {a=1 b=3})) 13 | (define thing2 (thing:two {a=2 b=#\A})) 14 | 15 | (printn thing1) 16 | (printn thing2) 17 | 18 | -------------------------------------------------------------------------------- /tests/t_uimm.scm: -------------------------------------------------------------------------------- 1 | 2 | (datatype uimm 3 | (:INT int) 4 | (:CHAR char) 5 | (:pair int int) 6 | ; (:THING int) 7 | ) 8 | 9 | (let ((x (uimm:INT 3))) 10 | (vcase uimm x 11 | ((:INT n) "gotcha") 12 | ((:CHAR ch) "not so much") 13 | ((:pair a b) "fuggedaboudit") 14 | )) 15 | 16 | -------------------------------------------------------------------------------- /tests/t_urandom.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/map.scm") 5 | (include "lib/urandom.scm") 6 | (include "lib/codecs/hex.scm") 7 | 8 | (define RNG (urandom-make)) 9 | 10 | (printf "32 random bytes: " (string->hex (RNG 32)) "\n") 11 | -------------------------------------------------------------------------------- /tests/t_utf8.exp: -------------------------------------------------------------------------------- 1 | ∃ 2 | ∃ 3 | #u 4 | -------------------------------------------------------------------------------- /tests/t_utf8.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define s1 "\xe2\x88\x83\n") 6 | (define s2 "∃\n") 7 | 8 | (print-string s1) 9 | (print-string s2) 10 | -------------------------------------------------------------------------------- /tests/t_vec16.scm: -------------------------------------------------------------------------------- 1 | 2 | (define (printn x) 3 | (%%cexp ('a -> undefined) "dump_object (%0, 0); fprintf (stdout, \"\\n\")" x)) 4 | 5 | (let ((v (%make-vec16 25))) 6 | (printn v) 7 | (set! v[19] 34) 8 | (printn v) 9 | v[19] 10 | ) 11 | -------------------------------------------------------------------------------- /tests/t_vec16_1.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | 5 | (let ((v (list->vec16 '(1 2 3 4 5)))) 6 | (printn v) 7 | (printn v[4]) 8 | ) 9 | -------------------------------------------------------------------------------- /tests/t_veclit0.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (define fact 7 | 0 a -> a 8 | n a -> (fact (- n 1) (* n a)) 9 | ) 10 | 11 | #(0 1 2 3 4 (fact 5 1) 6) 12 | ;; (list->vector 13 | ;; (list:cons 14 | ;; 0 (list:cons 15 | ;; 1 (list:cons 16 | ;; 2 (list:cons 17 | ;; 3 (list:cons 18 | ;; 4 (list:cons 19 | ;; (fact 5 1) 20 | ;; (list:cons 6 (list:nil))))))))) 21 | -------------------------------------------------------------------------------- /tests/t_vector.exp: -------------------------------------------------------------------------------- 1 | 1 2 | 5 3 | (1 2 3 4 5) 4 | #(1 2 3 4 5) 5 | #u 6 | -------------------------------------------------------------------------------- /tests/t_vector.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | 5 | (define (thing v) v[0]) 6 | 7 | (printn (thing #(1 2 3))) 8 | (printn (vector-length #(1 2 3 4 5))) 9 | (printn (vector-length #())) 10 | (printn (vector-length (make-vector 0 0))) 11 | (printn (vector->list #(1 2 3 4 5))) 12 | (printn (list->vector (vector->list #(1 2 3 4 5)))) 13 | -------------------------------------------------------------------------------- /tests/t_vector1.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | (include "lib/pair.scm") 4 | 5 | (define v1 #(#(0 1 2) #(3 4 5) #(6 7 8))) 6 | (printn v1[0][0]) 7 | (set! v1[2][2] 99) 8 | (printn v1) 9 | (define v2 #(#(#(0 1) #(2 3) #(4 5)) 10 | #(#(6 7) #(8 9) #(10 11)) 11 | #(#(12 13) #(14 15) #(16 17)))) 12 | (set! v2[1][1][0] 99) 13 | (printn v2) 14 | -------------------------------------------------------------------------------- /tests/t_while.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (let ((n 100)) 6 | (while (> n 0) 7 | (printn n) 8 | (set! n (- n 1)) 9 | )) 10 | -------------------------------------------------------------------------------- /tests/t_y.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; Note: since removing support for recursive types, this code 4 | ;; no longer works. 5 | 6 | ;; See http://en.wikipedia.org/wiki/Fixed_point_combinator 7 | 8 | (include "lib/core.scm") 9 | 10 | (define (Y f) 11 | (lambda (x) 12 | ((f (Y f)) x))) 13 | 14 | (define (factabs fact) 15 | (lambda (x) 16 | (if (= x 0) 17 | 1 18 | (* x (fact (- x 1)))))) 19 | 20 | (printn ((Y factabs) 5)) 21 | 22 | ;; and http://caml.inria.fr/pub/docs/u3-ocaml/ocaml-ml.html#toc5 23 | ;; let fix f' = let g f x = f' (f f) x in (g g);; 24 | ;; let fact = fix fact' in fact 5;; 25 | 26 | (define (Y2 f1) 27 | ;; the '^' prefix tells the compiler not to inline this function 28 | ;; which in this particular case would never terminate... 29 | (define (^g f) 30 | (lambda (x) 31 | (f1 (f f) x))) 32 | (^g ^g)) 33 | 34 | (define (fact1 fact x) 35 | (if (= x 0) 36 | 1 37 | (* x (fact (- x 1))))) 38 | 39 | (printn ((Y2 fact1) 5)) 40 | -------------------------------------------------------------------------------- /tests/t_λ.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define add 6 | (λ (x) 7 | (λ (y) 8 | (+ x y)))) 9 | 10 | ((add 3) 4) 11 | -------------------------------------------------------------------------------- /tests/tak20.exp: -------------------------------------------------------------------------------- 1 | 7 2 | -------------------------------------------------------------------------------- /tests/tak20.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | ;; Tak, the Hideous New Girl! 4 | 5 | (include "lib/core.scm") 6 | 7 | (define (tak x y z) 8 | (if (>= y x) 9 | z 10 | (tak (tak (- x 1) y z) 11 | (tak (- y 1) z x) 12 | (tak (- z 1) x y)))) 13 | 14 | (let loop ((n 20)) 15 | (let ((r (tak 18 12 6))) 16 | (if (= 0 n) 17 | r 18 | (loop (- n 1))))) 19 | -------------------------------------------------------------------------------- /util/build_bootstraps.py: -------------------------------------------------------------------------------- 1 | # -*- Mode: Python -*- 2 | 3 | import os 4 | 5 | def getenv_or (name, default): 6 | v = os.getenv (name) 7 | if v is not None: 8 | return v 9 | else: 10 | return default 11 | 12 | class CommandFailed (Exception): 13 | pass 14 | 15 | def system (cmd): 16 | print (cmd) 17 | if 0 != os.system (cmd): 18 | raise CommandFailed (cmd) 19 | 20 | system ('IRKENLIB=. self/compile self/compile.scm -b -q') 21 | system ('cp self/compile.byc self/bootstrap.byc') 22 | system ('IRKENLIB=. self/compile ffi/gen/genffi.scm -b -q') 23 | -------------------------------------------------------------------------------- /util/build_vm.py: -------------------------------------------------------------------------------- 1 | # -*- Mode: Python -*- 2 | 3 | # build the vm. 4 | 5 | import os 6 | import platform 7 | 8 | def getenv_or (name, default): 9 | v = os.getenv (name) 10 | if v is not None: 11 | return v 12 | else: 13 | return default 14 | 15 | cc = getenv_or ('CC', 'clang') 16 | cflags = getenv_or ('CFLAGS', '-std=c99 -O3 -fomit-frame-pointer -I./include -lffi') 17 | 18 | sysname = platform.uname()[0] 19 | 20 | if sysname == 'FreeBSD': 21 | # libffi is under /usr/local/ 22 | cflags += ' -I/usr/local/include -L/usr/local/lib' 23 | elif sysname == 'Linux': 24 | cflags += ' -D_GNU_SOURCE -ldl' 25 | 26 | cmd = '%s vm/irkvm.c -o vm/irkvm %s' % (cc, cflags) 27 | print (cmd) 28 | os.system (cmd) 29 | -------------------------------------------------------------------------------- /util/clean_outputs.py: -------------------------------------------------------------------------------- 1 | # -*- Mode: Python -*- 2 | 3 | # find .c, .ll, and binaries for compiled irken 4 | # and nuke them all. 5 | 6 | import os 7 | import sys 8 | 9 | if len(sys.argv) == 2: 10 | path = sys.argv[1] 11 | else: 12 | path = '.' 13 | 14 | pj = os.path.join 15 | 16 | to_remove = [] 17 | 18 | for root, dirs, files in os.walk (path): 19 | for name in files: 20 | base, ext = os.path.splitext (name) 21 | if ext == '.scm': 22 | if base + '.c' in files: 23 | to_remove.append (pj (root, base + '.c')) 24 | if base + '.ll' in files: 25 | to_remove.append (pj (root, base + '.ll')) 26 | if base + '.byc' in files: 27 | to_remove.append (pj (root, base + '.byc')) 28 | if base in files: 29 | to_remove.append (pj (root, base)) 30 | 31 | PRECIOUS = [ 32 | './self/compile', 33 | './self/compile.c', 34 | './self/compile.byc', 35 | './ffi/gen/genffi.byc', 36 | ] 37 | 38 | for path in to_remove: 39 | if path not in PRECIOUS: 40 | os.unlink (path) 41 | -------------------------------------------------------------------------------- /util/measure_inline_threshold.py: -------------------------------------------------------------------------------- 1 | # -*- Mode: Python -*- 2 | 3 | # measure the effect of 'inline-threshold' on the size and speed of the compiler. 4 | 5 | class CommandFailed (Exception): 6 | pass 7 | 8 | import time 9 | import os 10 | 11 | class Timer: 12 | def __enter__(self): 13 | self.start = time.time() 14 | return self 15 | def __exit__(self, *args): 16 | self.interval = time.time() - self.start 17 | 18 | def system (cmd): 19 | print (cmd) 20 | if 0 != os.system (cmd): 21 | raise CommandFailed (cmd) 22 | 23 | def do_one (val): 24 | # compile twice to reach steady state 25 | system ("self/compile self/compile.scm -q -i %d" % (val,)) 26 | system ("self/compile self/compile.scm -q -i %d" % (val,)) 27 | with Timer() as t: 28 | # time just the code generation, not the C compiler. 29 | for i in range (5): 30 | system ("self/compile self/compile.scm -q -c -i %d" % (val,)) 31 | return ( 32 | val, 33 | t.interval / 5.0, 34 | os.stat('self/compile.c').st_size, 35 | os.stat('self/compile').st_size 36 | ) 37 | 38 | values = [] 39 | for thresh in range (0, 21): 40 | r = do_one (thresh) 41 | print (r) 42 | values.append (r) 43 | 44 | print (values) 45 | -------------------------------------------------------------------------------- /util/pygment.py: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/python2.5 2 | 3 | import os 4 | from pygments.cmdline import main as highlight 5 | 6 | for root, dirs, files in os.walk ('.', topdown=False): 7 | for name in files: 8 | if name.endswith ('.py') or name.endswith ('.scm'): 9 | path = os.path.join (root, name) 10 | highlight (('pygmentize -O full -f html -o %s.html %s' % (path, path)).split()) 11 | -------------------------------------------------------------------------------- /util/safe.py: -------------------------------------------------------------------------------- 1 | # -*- Mode: Python -*- 2 | 3 | # keep the last 10 compilers in case of nasty bugs that are 4 | # difficult to back out of. 5 | 6 | import os 7 | import re 8 | 9 | def rename_binaries(): 10 | files = [] 11 | for path in os.listdir ('./self'): 12 | m = re.match ('^compile([0-9])$', path) 13 | if m is not None: 14 | num = int (m.group(1)) 15 | files.append ((num, path)) 16 | 17 | files.sort() 18 | files.reverse() 19 | 20 | for num, path in files: 21 | #print 'self/%s' %path, 'self/compile%d' % (num+1) 22 | os.rename ('self/%s' %path, 'self/compile%d' % (num+1)) 23 | # over the horizon... 24 | if os.path.isfile ('self/compile10'): 25 | os.unlink ('self/compile10') 26 | 27 | os.rename ('self/compile', 'self/compile0') 28 | if 0 == os.system ('self/compile0 self/compile.scm'): 29 | rename_binaries() 30 | else: 31 | os.rename ('self/compile0', 'self/compile') 32 | -------------------------------------------------------------------------------- /vm/.gitignore: -------------------------------------------------------------------------------- 1 | vm 2 | vm.c 3 | vm.ll 4 | -------------------------------------------------------------------------------- /vm/low/irkvm.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/basis.scm") 4 | (include "lib/os.scm") 5 | 6 | (local-include "vm.c") 7 | 8 | (define (read-bytecode-file path) 9 | (%%cexp (string -> int) "read_bytecode_file (%0)" path)) 10 | 11 | ;; this is an (admittedly kludgy) way of bootstrapping the vm->irken 12 | ;; call interface: we provide a single "object-getting closure"... 13 | (define (set-closure closure) 14 | (%%cexp ('a -> int) "vm_set_closure (%0)" closure)) 15 | 16 | ;; ... and these are the exposed objects. 17 | (define boot-get-object 18 | "O_RDONLY" -> (magic O_RDONLY) 19 | "O_RDWR" -> (magic O_RDWR) 20 | "O_CREAT" -> (magic O_CREAT) 21 | "STDOUT_FILENO" -> (magic STDOUT_FILENO) 22 | "open" -> (magic open) 23 | "close" -> (magic close) 24 | "write" -> (magic write) 25 | "argv" -> (magic sys.argv) 26 | x -> (error1 "boot-get-object" x) 27 | ) 28 | 29 | (define (go) 30 | (cond ((not (= -1 (read-bytecode-file (zero-terminate sys.argv[1])))) 31 | (set-closure boot-get-object) 32 | (%%cexp (-> 'a) "vm_go()")) 33 | (else 34 | (printf "failed to read bytecode file\n")) 35 | )) 36 | 37 | (printn (boot-get-object "STDOUT_FILENO")) 38 | (go) 39 | -------------------------------------------------------------------------------- /vm/tests/.gitignore: -------------------------------------------------------------------------------- 1 | *.byc 2 | -------------------------------------------------------------------------------- /vm/tests/t0.scm: -------------------------------------------------------------------------------- 1 | 42 2 | 3 | -------------------------------------------------------------------------------- /vm/tests/t1.scm: -------------------------------------------------------------------------------- 1 | #\A 2 | -------------------------------------------------------------------------------- /vm/tests/t10.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | (define (plus a b) 4 | (+ a b)) 5 | 6 | (plus 100 (plus 1 (plus 2 (plus 3 4)))) 7 | 8 | -------------------------------------------------------------------------------- /vm/tests/t11.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (define calls 0) 5 | 6 | (define (tak x y z) 7 | (set! calls (+ 1 calls)) 8 | (if (>= y x) 9 | z 10 | (tak (tak (- x 1) y z) 11 | (tak (- y 1) z x) 12 | (tak (- z 1) x y)))) 13 | 14 | (let loop ((n 20)) 15 | (let ((r (tak 18 12 6))) 16 | (if (= n 0) 17 | r 18 | (loop (- n 1))))) 19 | 20 | calls 21 | 22 | -------------------------------------------------------------------------------- /vm/tests/t12.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (define (thing1 a b c) (+ a 1)) 5 | (define (thing2 a b c) (+ b 1)) 6 | (define (thing3 a b c) (+ c 1)) 7 | 8 | (print (thing1 10 11 12)) 9 | (print (thing2 10 11 12)) 10 | (print (thing3 10 11 12)) 11 | -------------------------------------------------------------------------------- /vm/tests/t13.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (define a 1) 5 | (define b 2) 6 | 7 | (set! b 99) 8 | (set! a 12) 9 | (print a) 10 | (print b) 11 | 12 | 13 | -------------------------------------------------------------------------------- /vm/tests/t14.scm: -------------------------------------------------------------------------------- 1 | 2 | (include "lib/core.scm") 3 | 4 | (print (>= 20 10)) 5 | (print (>= 10 20)) 6 | (print (>= 10 10)) 7 | -------------------------------------------------------------------------------- /vm/tests/t15.scm: -------------------------------------------------------------------------------- 1 | 2 | #xdeadbeef 3 | -------------------------------------------------------------------------------- /vm/tests/t16.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (datatype list 4 | (:nil) 5 | (:cons 'a (list 'a)) 6 | ) 7 | 8 | (list:cons 1 (list:cons 2 (list:nil))) 9 | -------------------------------------------------------------------------------- /vm/tests/t17.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (datatype list 6 | (:nil) 7 | (:cons 'a (list 'a)) 8 | ) 9 | 10 | (define range 11 | 0 acc -> acc 12 | n acc -> (range (- n 1) (list:cons n acc)) 13 | ) 14 | 15 | (range 5 (list:nil)) 16 | 17 | -------------------------------------------------------------------------------- /vm/tests/t18.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define thing 6 | 0 -> 1 7 | 2 -> 3 8 | n -> (+ n 100) 9 | ) 10 | 11 | (print (thing 7)) 12 | (print (thing 2)) 13 | (print (thing 0)) 14 | 15 | -------------------------------------------------------------------------------- /vm/tests/t19.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define (thing) 6 | (let loop ((n 10000)) 7 | (if (= n 100) 8 | (%exit #f 42) 9 | (loop (- n 1))))) 10 | 11 | (thing) 12 | 13 | -------------------------------------------------------------------------------- /vm/tests/t2.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | (- (+ 19 34) 3) 4 | 5 | -------------------------------------------------------------------------------- /vm/tests/t20.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (datatype list 6 | (:nil) 7 | (:cons 'a (list 'a)) 8 | ) 9 | 10 | (define (length l) 11 | (define fun 12 | () acc -> acc 13 | (hd . tl) acc -> (fun tl (+ 1 acc))) 14 | (fun l 0)) 15 | 16 | (length (list:cons 1 (list:cons 2 (list:cons 3 (list:nil))))) 17 | -------------------------------------------------------------------------------- /vm/tests/t21.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/frb.scm") 6 | 7 | ;; test tree/make macro 8 | 9 | (let ((t (tree/make < 10 | (1 #\t) 11 | (2 #\f) 12 | (3 #\l) 13 | (4 #\a) 14 | (5 #\b) 15 | ))) 16 | (print t) 17 | (tree/member t < 5) 18 | ) 19 | -------------------------------------------------------------------------------- /vm/tests/t22.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (let ((a "testing") 4 | (b "testing")) 5 | b) 6 | 7 | 8 | -------------------------------------------------------------------------------- /vm/tests/t23.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | 6 | (+ 12 (length '(1 2 3 4))) 7 | 8 | 9 | -------------------------------------------------------------------------------- /vm/tests/t24.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define thing #(0 1 2 3 4 5)) 6 | (set! thing[2] 19) 7 | (print thing[4]) 8 | (print thing[2]) 9 | (print (%make-vector #f 10 23)) 10 | 11 | 12 | -------------------------------------------------------------------------------- /vm/tests/t25.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define thing1 {a=1 b=#\b c="c"}) 6 | (define thing2 {c="hey" b=#\b a=12}) 7 | (print thing1) 8 | (print thing2) 9 | (print thing1.a) 10 | (print thing2.c) 11 | 12 | -------------------------------------------------------------------------------- /vm/tests/t26.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define thing1 {a=0 x=1 y=2}) 6 | (define thing2 {x=3 y=4 z=7}) 7 | 8 | (define (fun1 p) 9 | (+ p.x 10) 10 | ) 11 | 12 | (print (fun1 thing1)) 13 | (print (fun1 thing2)) 14 | 15 | 16 | -------------------------------------------------------------------------------- /vm/tests/t27.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | 4 | #(#(0 1)#(1 2)#(3 4)) 5 | -------------------------------------------------------------------------------- /vm/tests/t28.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (define x (:thing 1 2 #\A)) 4 | (define y (:other "testing")) 5 | 6 | (define myfun 7 | (:thing _ two _) -> two 8 | (:other _) -> 19 9 | ) 10 | 11 | (:zorb 12 | (myfun x) 13 | (myfun y) 14 | (myfun (:thing 7 12 #\X)) 15 | ) 16 | 17 | 18 | -------------------------------------------------------------------------------- /vm/tests/t29.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define thing1 {a=1 b=#\b c="c"}) 6 | (define thing2 {c="hey" b=#\b a=12}) 7 | 8 | (set! thing2.c "there") 9 | (set! thing1.a 34) 10 | 11 | (print thing1) 12 | (print thing2) 13 | (print thing1.a) 14 | (print thing2.c) 15 | 16 | -------------------------------------------------------------------------------- /vm/tests/t3.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | (if (= 3 3) 4 | (if (= 1 2) 5 | 19 6 | 34) 7 | 27) 8 | -------------------------------------------------------------------------------- /vm/tests/t30.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | ;; test op_rset. 6 | 7 | (define (^fun1 p) 8 | (set! p.y 1001) 9 | (+ p.x 10) 10 | ) 11 | 12 | (let ((thing1 {a=0 x=1 y=2 b="what?"}) 13 | (thing2 {x=3 y=4 z=7})) 14 | (set! thing1.x 27) 15 | (set! thing2.x 19) 16 | (print (^fun1 thing1)) 17 | (print (^fun1 thing2)) 18 | (print thing1) 19 | (print thing2) 20 | ) 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /vm/tests/t31.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | (include "lib/frb.scm") 7 | (include "lib/symbol.scm") 8 | 9 | ;; not until we figure out how to call back into irken... 10 | 11 | (printn '(a b c d e)) 12 | (printn (list->vector '(a b c d e))) 13 | (printn (string->symbol "f")) 14 | (let ((lx '(a b c d e))) 15 | (printn (string->symbol "f")) 16 | (printn the-symbol-table) 17 | (for-map k v the-symbol-table 18 | (printf "k= " (string k) " v=" (sym v) " index=" (int (symbol->index v)) "\n") 19 | )) 20 | -------------------------------------------------------------------------------- /vm/tests/t32.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (define (get-closure) 6 | (%%cexp (-> (irken-closure (string -> int))) "getc")) 7 | 8 | (define (thing s) 9 | (let ((closure (get-closure))) 10 | (%%cexp ((irken-closure (string -> int)) int string -> int) "irk" closure 1 s) 11 | )) 12 | 13 | (print (thing "--- testing ---\n")) 14 | (print (thing "... and testing again!\n")) 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /vm/tests/t33.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (printf "testing, testing. 0=" (int 0) " A=" (char #\A) "\n") 8 | -------------------------------------------------------------------------------- /vm/tests/t34.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (printn (char->ascii #\A)) 8 | (printn (ascii->char 97)) 9 | -------------------------------------------------------------------------------- /vm/tests/t3_2.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | (+ (if (= 3 3) 19 34) 4 | (if (= 3 4) 27 17) 5 | (if (< 3 5) 12 11)) 6 | -------------------------------------------------------------------------------- /vm/tests/t4.scm: -------------------------------------------------------------------------------- 1 | (lambda (x) 3) 2 | -------------------------------------------------------------------------------- /vm/tests/t5.scm: -------------------------------------------------------------------------------- 1 | ((lambda () 3)) 2 | -------------------------------------------------------------------------------- /vm/tests/t6.scm: -------------------------------------------------------------------------------- 1 | ((lambda (x) 3) 5) 2 | -------------------------------------------------------------------------------- /vm/tests/t7.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | ((lambda (x) ((lambda (y) (+ x y)) 19)) 34) 4 | 5 | -------------------------------------------------------------------------------- /vm/tests/t8.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | (let ((x 7) 4 | (y 3)) 5 | (+ x y)) 6 | -------------------------------------------------------------------------------- /vm/tests/t9.scm: -------------------------------------------------------------------------------- 1 | (include "lib/core.scm") 2 | 3 | (let loop ((n 1000000)) 4 | ;;(print n) 5 | (if (= 0 n) 6 | 42 7 | (loop (- n 1)))) 8 | 9 | -------------------------------------------------------------------------------- /vm/tests/t_alist.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/alist.scm") 6 | 7 | (define l0 (alist/make)) 8 | 9 | (alist/push l0 19 34) 10 | (alist/push l0 21 19) 11 | (alist/push l0 47 12) 12 | 13 | (print l0) 14 | (print (alist/lookup l0 47)) 15 | (print (alist/lookup l0 33)) 16 | 17 | -------------------------------------------------------------------------------- /vm/tests/t_cmp.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (printf (cmp-repr (magic-cmp "thing1" "thing2")) "\n") 8 | 9 | -------------------------------------------------------------------------------- /vm/tests/t_ffi.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | ;; test ffi from irken-vm 6 | 7 | (defmacro make-ffi 8 | (make-ffi name rtype nargs (formal0 ...) (ftype0 ...)) 9 | -> (let (($pfun (%%cexp (string -> int) "dlsym" name))) 10 | (lambda (formal0 ...) 11 | (%%cexp (int char int ftype0 ...) 12 | "ffi" 13 | $pfun rtype nargs 14 | formal0 ...)))) 15 | 16 | (define (tmpnam) 17 | ((make-ffi "tmpnam\x00" #\s 0 () (-> string)))) 18 | 19 | (define (write fd s) 20 | ((make-ffi "write\x00" 21 | #\i 3 22 | (fd s slen) 23 | (int string int -> int)) 24 | fd s (string-length s))) 25 | 26 | (write 1 "yabba dabba dooooooo\n") 27 | (printn (tmpnam)) 28 | -------------------------------------------------------------------------------- /vm/tests/t_heap.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (for-range i 1000 8 | (make-string (* 1024 1024 5))) 9 | -------------------------------------------------------------------------------- /vm/tests/t_plat.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (%%cexp (-> (list string)) "plat") 6 | -------------------------------------------------------------------------------- /vm/tests/t_plat2.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/posix.scm") 6 | 7 | (uname) 8 | -------------------------------------------------------------------------------- /vm/tests/t_prints.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | 5 | (print-string "four score and seven years ago...\n") 6 | -------------------------------------------------------------------------------- /vm/tests/t_readf.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/frb.scm") 5 | (include "lib/pair.scm") 6 | (include "lib/string.scm") 7 | (include "lib/symbol.scm") 8 | (include "lib/alist.scm") 9 | (include "lib/lisp_reader.scm") 10 | 11 | (define (vm-read-file path) 12 | (string-concat 13 | (%%cexp (string -> (list string)) "readf" path) 14 | )) 15 | 16 | (for-list exp (read-string (vm-read-file "ffi/socket_ffi.scm")) 17 | (pp exp 0)) 18 | 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /vm/tests/t_string.scm: -------------------------------------------------------------------------------- 1 | ;; -*- Mode: Irken -*- 2 | 3 | (include "lib/core.scm") 4 | (include "lib/pair.scm") 5 | (include "lib/string.scm") 6 | 7 | (let ((s "0123456789")) 8 | (print (string-ref "0123456789" 5)) 9 | (string-set! s 0 #\A) 10 | s) 11 | 12 | 13 | --------------------------------------------------------------------------------