├── bin ├── conf ├── pubpriv ├── install.sh ├── mbfixbin ├── pfrepl ├── pfront ├── repl ├── pfhighlight ├── pftexprint ├── uninstall_all.sh └── test.sh ├── misc ├── footer.tex ├── flowtop.hl ├── flowdll.hl ├── header.html ├── scripts1.js ├── footer.html ├── stylesheets.css ├── header.tex └── demos │ ├── calc.hl │ ├── 03calc.al │ ├── 04calc.al │ ├── 01calc.al │ └── 00calc.al ├── doc ├── doc.tex ├── pfdoc.tex ├── scripts1.js ├── stylesheets.css └── template.tex ├── src ├── l │ ├── tests │ │ ├── level2 │ │ │ ├── readme │ │ │ └── test_w.al │ │ ├── level1 │ │ │ └── readme │ │ ├── level3 │ │ │ └── readme │ │ ├── level4 │ │ │ └── test.al │ │ └── common.al │ ├── lib │ │ ├── ssa │ │ │ ├── bootstrap.sh │ │ │ ├── bootstrap.hl │ │ │ ├── bootstrap.al │ │ │ ├── genlive-ast.hl │ │ │ ├── ssa-lib.hl │ │ │ ├── ssa-ast.hl │ │ │ ├── doc.tex │ │ │ ├── ssa-fold-typing.hl │ │ │ ├── domtree.hl │ │ │ └── ssa-fold-algebra.hl │ │ ├── wam │ │ │ ├── mbaselogic.hl │ │ │ ├── lib.hl │ │ │ ├── prologdoc.tex │ │ │ ├── prolog_backend_lib.hl │ │ │ └── prolog_repl.hl │ │ ├── parsing │ │ │ ├── packrat.al │ │ │ ├── pegtemp.al │ │ │ ├── lib.al │ │ │ ├── pegbasics.peg │ │ │ ├── basics.peg │ │ │ ├── backend-ast.al │ │ │ └── ast.al │ │ ├── ml │ │ │ ├── mllib.al │ │ │ ├── mldll.al │ │ │ ├── mlcomp.al │ │ │ ├── mlcore-parser2.al │ │ │ ├── mlprelude.al │ │ │ ├── mlrepl.al │ │ │ ├── mllexer.peg │ │ │ ├── mlcore-ast.al │ │ │ └── mlfront.al │ │ └── pfront │ │ │ ├── front.al │ │ │ ├── pfrepl.al │ │ │ ├── pfrepl2.al │ │ │ ├── pftexprint.al │ │ │ ├── backport.al │ │ │ ├── parser.al │ │ │ ├── pliter.peg │ │ │ ├── pfront.al │ │ │ ├── pftexincludeinv.al │ │ │ └── sexp.hl │ ├── boot │ │ ├── initlib2.al │ │ ├── stagec.al │ │ ├── extra.al │ │ ├── stage2.al │ │ ├── stage3.al │ │ ├── stage4.al │ │ ├── stage5.al │ │ └── common.al │ ├── version.al │ ├── core │ │ ├── asmlib_hooks.al │ │ ├── ccerrors.al │ │ ├── asmlib_load.al │ │ ├── environment.al │ │ ├── graphsort.al │ │ ├── pmatchcomp.al │ │ ├── cc-anntexpand.al │ │ ├── cc-plugins.al │ │ ├── cc-sanitise.al │ │ ├── fccase.al │ │ ├── cc-cons.al │ │ ├── unit.al │ │ ├── asmlib_common.al │ │ ├── list.al │ │ ├── parsing_chars.al │ │ ├── utils.al │ │ ├── final.al │ │ ├── envhandling.al │ │ ├── netlib_fields.al │ │ ├── cc-tail.al │ │ ├── cc-expand.al │ │ ├── cc-ast-flat.al │ │ ├── native.al │ │ ├── parsing_0.al │ │ ├── cc-netdefs.al │ │ ├── records.al │ │ ├── cc-optimise.al │ │ └── compiler.al │ ├── ext │ │ ├── ast2-initvector.al │ │ ├── raise.al │ │ ├── unittests.al │ │ ├── tarjan.al │ │ ├── extra.al │ │ ├── ast2.al │ │ ├── float.al │ │ ├── tcprepl.al │ │ ├── nrecord.al │ │ └── texprint.al │ ├── util │ │ ├── makeasmlib.al │ │ └── update_pure.al │ └── options.al └── cs │ └── dll │ ├── AssemblyInfo.cs │ └── version.cs └── COPYING /bin/conf: -------------------------------------------------------------------------------- 1 | MONO=mono 2 | -------------------------------------------------------------------------------- /misc/footer.tex: -------------------------------------------------------------------------------- 1 | 2 | \end{document} 3 | -------------------------------------------------------------------------------- /bin/pubpriv: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/combinatorylogic/mbase/HEAD/bin/pubpriv -------------------------------------------------------------------------------- /doc/doc.tex: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/combinatorylogic/mbase/HEAD/doc/doc.tex -------------------------------------------------------------------------------- /src/l/tests/level2/readme: -------------------------------------------------------------------------------- 1 | Tests covering an interpreted .NET compiler functionality -------------------------------------------------------------------------------- /bin/install.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | ls MBase*.dll | xargs -I {} gacutil /i {} 4 | 5 | -------------------------------------------------------------------------------- /src/l/lib/ssa/bootstrap.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | pfront /dumpal ssa.al ./bootstrap.hl 4 | 5 | -------------------------------------------------------------------------------- /src/l/tests/level1/readme: -------------------------------------------------------------------------------- 1 | Tests covering L1 functionality without .NET compiler. 2 | 3 | -------------------------------------------------------------------------------- /src/l/tests/level3/readme: -------------------------------------------------------------------------------- 1 | Tests covering fully compiled L1' + extra libraries, including NOT.NET 2 | backend. 3 | 4 | -------------------------------------------------------------------------------- /misc/flowtop.hl: -------------------------------------------------------------------------------- 1 | #(sysdll MBaseExtra) 2 | #(sysdll FlowCharts) 3 | 4 | function main() { 5 | fc_main() 6 | } 7 | 8 | 9 | -------------------------------------------------------------------------------- /src/l/lib/ssa/bootstrap.hl: -------------------------------------------------------------------------------- 1 | 2 | 3 | include "ssa-ast.hl" 4 | include "domtree.hl" 5 | include "ssa-trans.hl" 6 | include "ssa-analysis.hl" 7 | 8 | -------------------------------------------------------------------------------- /src/l/lib/wam/mbaselogic.hl: -------------------------------------------------------------------------------- 1 | #(include "../../version.al") 2 | #(n.module MBaseLogic) 3 | 4 | include "./lib.hl"; 5 | 6 | #(force-class-flush) 7 | 8 | #(n.save) -------------------------------------------------------------------------------- /bin/mbfixbin: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set +e 4 | editbin /stack:9000000 $1 5 | 6 | CorFlags.exe /Force /32BIT+ $1 7 | sn -Ra $1 pubpriv 8 | 9 | set -e 10 | 11 | -------------------------------------------------------------------------------- /bin/pfrepl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | REPL_PATH="`dirname \"$0\"`" 4 | REPL_PATH="`( cd \"$REPL_PATH\" && pwd )`" 5 | 6 | . $REPL_PATH/conf 7 | 8 | $MONO $0.exe $* 9 | 10 | -------------------------------------------------------------------------------- /bin/pfront: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | REPL_PATH="`dirname \"$0\"`" 4 | REPL_PATH="`( cd \"$REPL_PATH\" && pwd )`" 5 | 6 | . $REPL_PATH/conf 7 | 8 | $MONO $0.exe $* 9 | 10 | -------------------------------------------------------------------------------- /bin/repl: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | REPL_PATH="`dirname \"$0\"`" 4 | REPL_PATH="`( cd \"$REPL_PATH\" && pwd )`" 5 | 6 | . $REPL_PATH/conf 7 | 8 | $MONO $0.exe $* 9 | 10 | -------------------------------------------------------------------------------- /bin/pfhighlight: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | REPL_PATH="`dirname \"$0\"`" 4 | REPL_PATH="`( cd \"$REPL_PATH\" && pwd )`" 5 | 6 | . $REPL_PATH/conf 7 | 8 | $MONO $0.exe $* 9 | 10 | -------------------------------------------------------------------------------- /bin/pftexprint: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | REPL_PATH="`dirname \"$0\"`" 4 | REPL_PATH="`( cd \"$REPL_PATH\" && pwd )`" 5 | 6 | . $REPL_PATH/conf 7 | 8 | $MONO $0.exe $* 9 | 10 | -------------------------------------------------------------------------------- /src/l/lib/wam/lib.hl: -------------------------------------------------------------------------------- 1 | litinclude ("./prolog") "./prolog.hl"; 2 | litinclude ("./prolog_backend") "./prolog_backend.hl"; 3 | litinclude ("./prolog_backend_lib") "./prolog_backend_lib.hl"; 4 | 5 | -------------------------------------------------------------------------------- /misc/flowdll.hl: -------------------------------------------------------------------------------- 1 | #(include "../src/l/version.al") 2 | #(sysdll MBaseExtra) 3 | #(n.module FlowCharts) 4 | 5 | include "./extra.hl" 6 | htmlinclude "./flowchart.hl" 7 | 8 | #(force-class-flush) 9 | #(n.save) 10 | 11 | -------------------------------------------------------------------------------- /bin/uninstall_all.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if [ -z "$SED" ]; 4 | then 5 | SED=sed 6 | fi 7 | 8 | gacutil /l | grep d53ce51f54584d25 | $SED -s "s/ //g" | $SED -s "s/,Custom=null//g" | xargs -I {} gacutil /uf "{}" 9 | 10 | -------------------------------------------------------------------------------- /src/l/lib/ssa/bootstrap.al: -------------------------------------------------------------------------------- 1 | 2 | (with-macros ((hlevl-file (fun (x) `(begin ))) 3 | (top-begin (fun (x) `(begin ,@(cdr x)))) 4 | (pfront.debugpoint (fun (x) `(inner.debugpoint ,@(cdr x)))) 5 | ) 6 | (include "./ssa.al")) 7 | 8 | -------------------------------------------------------------------------------- /src/l/lib/wam/prologdoc.tex: -------------------------------------------------------------------------------- 1 | \input ../../../../misc/header 2 | \begin{document} 3 | \setlength{\parindent}{0pt} 4 | 5 | \tableofcontents 6 | 7 | \newpage 8 | 9 | \input prolog 10 | \input prolog_backend 11 | \input prolog_backend_lib 12 | 13 | \end{document} 14 | -------------------------------------------------------------------------------- /doc/pfdoc.tex: -------------------------------------------------------------------------------- 1 | \input ../misc/header 2 | 3 | \title{PFront manual} 4 | \author{Meta Alternative Ltd.} 5 | \date{Apr 2017} 6 | 7 | \begin{document} 8 | 9 | \maketitle 10 | 11 | \tableofcontents 12 | 13 | \newpage 14 | 15 | \input pfrontdoc 16 | 17 | \end{document} 18 | -------------------------------------------------------------------------------- /src/l/lib/ssa/genlive-ast.hl: -------------------------------------------------------------------------------- 1 | %literate: 2 | 3 | \pfcode{ 4 | ast genlivebb { 5 | bbs is (.*bb:bbs); 6 | bb = genbb(lblident:lbl, *useident:uses, *defident:defs, *instr:is); 7 | instr = use(ident:id) 8 | | kill(ident:id) 9 | | usekill(ident:id) 10 | | next(lblident:dst) 11 | ; 12 | }} 13 | 14 | %%%%%%%%%%%%% 15 | 16 | -------------------------------------------------------------------------------- /src/l/lib/ssa/ssa-lib.hl: -------------------------------------------------------------------------------- 1 | #(include "../../version.al") 2 | #(n.module MBaseExtra) 3 | 4 | include "ssa-ast.hl" 5 | include "domtree.hl" 6 | include "ssa-trans.hl" 7 | include "ssa-analysis.hl" 8 | 9 | litinclude ("./ssa-fold") "ssa-fold.hl" 10 | 11 | include "ssa-backend.hl" 12 | include "genlive.hl" 13 | 14 | include "genpprint.hl" 15 | 16 | #(force-class-flush) 17 | #(n.save) 18 | -------------------------------------------------------------------------------- /src/l/boot/initlib2.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (include "../core/netlib.al") 12 | (include "../core/macrolib.al") 13 | (include "../core/morelib.al") 14 | 15 | -------------------------------------------------------------------------------- /src/l/lib/parsing/packrat.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (ctimex (define compiler-debug-enabled #t)) 11 | (include "../../version.al") 12 | (n.module MBasePackrat) 13 | 14 | (include "./lib.al") -------------------------------------------------------------------------------- /src/l/tests/level2/test_w.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (define ENV (cc:newenv)) 11 | (cc:env:defmodule ENV "testl2" 'dll) 12 | 13 | (cc:toplevel-devour ENV '(include "./test.al")) 14 | 15 | -------------------------------------------------------------------------------- /src/l/tests/level4/test.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (n.module test4 exe) 11 | (sysdll MBaseFront) 12 | 13 | (include "../common.al") 14 | 15 | (hlevl-file "./test.hl") 16 | 17 | (include "./auto.al") 18 | 19 | 20 | -------------------------------------------------------------------------------- /src/l/lib/ml/mllib.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (include "./mlcore.al") 11 | 12 | (define ml:env (mkhash)) 13 | (define ml:prev (mkhash)) 14 | 15 | (force-class-flush) 16 | 17 | (ctime `(ml-file ,(cpath "./mlprelude.ml"))) 18 | -------------------------------------------------------------------------------- /src/l/version.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (ctime (define *VERSION* "1.0.2.20")) 11 | (ctime `(#define version ,*VERSION*)) 12 | (ctimex (define assembly-version *VERSION*)) 13 | (ctimex (define assembly-keyfile "pubpriv")) 14 | 15 | -------------------------------------------------------------------------------- /src/l/core/asmlib_hooks.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (define m_Call_Generic (cons m_Call_Generic_00 nil)) 11 | 12 | (define ms_Call_Generics (cons ms_Call_Generics_00 nil)) 13 | 14 | (define ms_Call_RevGenerics (cons ms_Call_RevGenerics_00 nil)) 15 | 16 | 17 | -------------------------------------------------------------------------------- /misc/header.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | Literate output 10 | 11 | 12 | 13 | 14 |
15 | 16 | -------------------------------------------------------------------------------- /src/l/boot/stagec.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \section{Stage $1^c$ --- building the interpreted compiler} 12 | ;- 13 | 14 | (ctimex (println "Bootstrap stage: C")) 15 | (include "../core/compiler.al") 16 | (force-class-flush) 17 | (gensym-counter-set (ctime (cdr *gensym-counter-storage*))) -------------------------------------------------------------------------------- /src/l/lib/pfront/front.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (include "../../version.al") 11 | (n.module MBaseFront) 12 | (sysdll MBasePackrat) 13 | 14 | (force-class-flush) 15 | 16 | (unit-tests-use) 17 | 18 | (include "./lib.al") 19 | 20 | 21 | (force-class-flush) 22 | 23 | (unit-tests-dump (4 "../src/l/tests/level4/auto.al")) -------------------------------------------------------------------------------- /src/l/lib/ssa/ssa-ast.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \subsection{AST for the generic SSA DSL} 4 | 5 | \pfcode{ 6 | ast genssa { 7 | top is (*varident:allocas, code:c); 8 | code is (.*bblock:bs); 9 | bblock = 10 | b(labident:name, *oppair:ops, *labident:nexts); 11 | oppair is (varident:name, iop:op); 12 | iop = phi(varident:orig,*labident:prevs,*varident:vals) 13 | | load(varident:v) 14 | | store(varident:dst, varident:src) 15 | | remap(varident:v) 16 | | use(.*varident:ids) 17 | ; 18 | varident is id:v; 19 | labident is id:v; 20 | } 21 | } 22 | 23 | 24 | %%% 25 | %%% -------------------------------------------------------------------------------- /src/l/lib/ml/mldll.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (include "../../version.al") 11 | (n.module MBaseML) 12 | (sysdll MBasePackrat) 13 | (macro save-gensym () 14 | (let ((gctr (cdr *gensym-counter-storage*))) 15 | `(set-cdr! *gensym-counter-storage* ,(+ gctr 10001)))) 16 | 17 | (include "./mllib.al") 18 | 19 | (ml-saveenv) 20 | 21 | (save-gensym) 22 | 23 | -------------------------------------------------------------------------------- /doc/scripts1.js: -------------------------------------------------------------------------------- 1 | function srcref_over(dstid, id) { 2 | SvgConnectors.manage(); 3 | let x = document.getElementById(dstid); 4 | document.getElementById('dummy_to').childNodes[0].removeAttribute('id'); 5 | document.getElementById('dummy_from').childNodes[0].removeAttribute('id'); 6 | x.childNodes[0].id = 'too'; 7 | id.childNodes[0].id = 'frm'; 8 | SvgConnectors.manage(); 9 | } 10 | 11 | function srcref_leave(dstid, id) { 12 | SvgConnectors.manage(); 13 | let x = document.getElementById(dstid); 14 | document.getElementById('dummy_to').childNodes[0].id = 'too'; 15 | document.getElementById('dummy_from').childNodes[0].id = 'frm'; 16 | x.childNodes[0].removeAttribute('id'); 17 | id.childNodes[0].removeAttribute('id'); 18 | SvgConnectors.manage(); 19 | } 20 | -------------------------------------------------------------------------------- /misc/scripts1.js: -------------------------------------------------------------------------------- 1 | function srcref_over(dstid, id) { 2 | SvgConnectors.manage(); 3 | let x = document.getElementById(dstid); 4 | document.getElementById('dummy_to').childNodes[0].removeAttribute('id'); 5 | document.getElementById('dummy_from').childNodes[0].removeAttribute('id'); 6 | x.childNodes[0].id = 'too'; 7 | id.childNodes[0].id = 'frm'; 8 | SvgConnectors.manage(); 9 | } 10 | 11 | function srcref_leave(dstid, id) { 12 | SvgConnectors.manage(); 13 | let x = document.getElementById(dstid); 14 | document.getElementById('dummy_to').childNodes[0].id = 'too'; 15 | document.getElementById('dummy_from').childNodes[0].id = 'frm'; 16 | x.childNodes[0].removeAttribute('id'); 17 | id.childNodes[0].removeAttribute('id'); 18 | SvgConnectors.manage(); 19 | } 20 | -------------------------------------------------------------------------------- /src/l/ext/ast2-initvector.al: -------------------------------------------------------------------------------- 1 | (macro ast2-init-n-vector vlst 2 | (with-syms (fldnm arnm) 3 | `(straise 4 | (not.neth () 5 | (lift-initfield ,fldnm 6 | ((public) (static)) 7 | ,@(foreach-mappend (v vlst) 8 | (int->ibytes v))) 9 | (lift-field (field (array int) ,arnm (public) (static))) 10 | (if (isnull (this # ,arnm)) 11 | (begin 12 | (this # ,arnm <- (mkarr int ,(length vlst))) 13 | (System.Runtime.CompilerServices.RuntimeHelpers 14 | @ InitializeArray 15 | ((System.Array)(this # ,arnm)) 16 | ((System.RuntimeFieldHandle)(fieldtoken (this # ,fldnm))) 17 | ))) 18 | (leave ((object) (this # ,arnm))))))) 19 | 20 | -------------------------------------------------------------------------------- /src/l/lib/ml/mlcomp.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (n.module mlcomp exe) 11 | (sysdll MBaseML) 12 | 13 | (function compile-ml (src tgt) 14 | (read-compile-eval `(n.module ,(Sm<< tgt) exe)) 15 | (read-compile-eval `(ml-file ,src)) 16 | (read-compile-eval '(n.save))) 17 | 18 | (function main ( ) 19 | (shashput (getfuncenv) 'main nil) 20 | (p:match (a->l *CMDLINE*) 21 | (($src) 22 | (compile-ml src "mlout")) 23 | (($src $tgt) 24 | (compile-ml src tgt)) 25 | (else 26 | (println "Usage:\n mlcomp []\n")))) 27 | 28 | -------------------------------------------------------------------------------- /src/l/util/makeasmlib.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (include "../core/ccerrors.al") 11 | (include "../core/emit.al") 12 | (include "../version.al") 13 | (include "../options.al") 14 | 15 | (include "../core/asmlib_common.al") 16 | (include "../core/asmlib_build.al") 17 | (define _asmlib_asm (make-strong-assembly "bootasm" assembly-version assembly-keyfile)) 18 | (define _asmlib_module (make-module-s _asmlib_asm "DYNAMIC" "bootasm.dll" #f)) 19 | 20 | (asmlib:build _asmlib_asm _asmlib_module "bootasm.") 21 | 22 | ;; yes, save it now: 23 | (asm-save _asmlib_asm "bootasm.dll") 24 | -------------------------------------------------------------------------------- /src/l/options.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (ctimex (begin 11 | (#define prefix-tail #t) ; use .tail call isntructions 12 | (#define debug-compiler #t) ; allow inspecting intermediate code 13 | (#define optimise-case nil) ; legacy case optimisation 14 | 15 | (#define option-asserts #t) ; compile asserts 16 | 17 | (#define optimise-cache #t) ; use code and const cache 18 | (#define optimise-cache-threshold 200) 19 | (#define optimise-cache-length-threshold 3000) 20 | 21 | (#define copyright "(c) by Meta Alternative Ltd., 2005-2017") 22 | 23 | )) 24 | -------------------------------------------------------------------------------- /src/l/lib/parsing/pegtemp.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (include "./peg.al") 11 | 12 | (function peg-translate (out sources) 13 | (call-with-output-file out 14 | (fun (fo) 15 | (foreach (s sources) 16 | (alet x (lex-and-parse peg-lexer parse-peg-decls 17 | (read-file-list 18 | (S<< (corelib:get-lookup-path) "/" s))) 19 | (foreach (xi x) (fprintln fo (to-string xi))) 20 | ))))) 21 | 22 | 23 | (peg-translate "./temporary-source.al" '("./basics.peg" "./pegbasics.peg" "./peg.peg")) 24 | 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /src/l/boot/extra.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (include "../ext/ibinder.al") 12 | (include "../ext/float.al") 13 | (include "../ext/extra.al") 14 | (include "../ext/rules.al") 15 | (include "../ext/collections.al") 16 | (include "../ext/threading.al") 17 | (include "../ext/tarjan.al") 18 | (include "../ext/sexp.al") 19 | (include "../ext/xml.al") 20 | (include "../ext/nettypes.al") 21 | 22 | 23 | 24 | (include "../ext/notnet-ast.al") 25 | (include "../ext/notnet-core.al") 26 | (include "../ext/notnet-backend.al") 27 | (include "../ext/notnet-frontend.al") 28 | 29 | (include "../ext/nrecord.al") 30 | (include "../ext/raise.al") 31 | (include "../ext/extutils.al") 32 | 33 | (include "../ext/ast2.al") 34 | 35 | -------------------------------------------------------------------------------- /misc/footer.html: -------------------------------------------------------------------------------- 1 | 2 |
3 |   4 |   5 |
6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 |
28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /bin/test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | . ./conf 4 | 5 | MBASE="$MONO ./mb0.exe" 6 | REPL="$MONO ./repl.exe" 7 | TDIR=../src/l/tests/ 8 | 9 | echo "L1" 10 | $MBASE /I boot2.alc $TDIR/level1/test.al | grep -v OK 11 | echo "L2: boot2.alc, libnet.alc, int" 12 | $MBASE /I boot2.alc /I libnet.alc $TDIR/level2/test.al | grep -v OK 13 | echo "L2: boot2.alc, libnet.alc, comp" 14 | $MBASE /I boot2.alc /I libnet.alc $TDIR/level2/test_w.al | grep -v OK 15 | echo "L2: boot2c.dll, libnet.alc, comp" 16 | $MBASE /D boot2c.dll /I libnet.alc $TDIR/level2/test_w.al | grep -v OK 17 | echo "L2: boot3.dll, comp" 18 | $MBASE /D boot3.dll $TDIR/level2/test_w.al | grep -v OK 19 | echo "L2: boot4.dll, comp" 20 | $MBASE /D boot4.dll $TDIR/level2/test_w.al | grep -v OK 21 | echo "L3: repl" 22 | $REPL $TDIR/level3/test.al | grep -v OK 23 | echo "L3: repl, exe comp" 24 | $REPL /emit $TDIR/level3/test.al | grep -v OK 25 | echo "L3: repl, exe run" 26 | $MONO ./test.exe | grep -v OK 27 | 28 | echo "L4: pfront" 29 | $REPL $TDIR/level4/test.al | grep -v OK 30 | 31 | -------------------------------------------------------------------------------- /src/l/core/ccerrors.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (function mkexcp (arg) 12 | (r_raise (new t_MBaseException (object arg))) 13 | ) 14 | 15 | (function ccerror (arg) 16 | "Raises [MBaseException] with a given argument." 17 | (if (shashget (getfuncenv) 'debug-compiler-failure) 18 | (begin 19 | (writeline `(EXCEPTION: ,arg)) 20 | (exit -1) 21 | ) 22 | (mkexcp arg))) 23 | 24 | (define *WARNINGS* (mkref)) 25 | 26 | (function ccwarning (arg) 27 | "Adds a warning to the global list of warnings." 28 | (set-cdr! *WARNINGS* (cons arg *WARNINGS*)) 29 | (print "WARNING: ") 30 | (println (to-string arg))) 31 | 32 | (function getwarnings () 33 | "Returns the current list of warnings." 34 | (cdr *WARNINGS*)) 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /src/l/util/update_pure.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;; Rebuilds Pure.cs 11 | 12 | (define MAXARGS 20) 13 | 14 | (iter println '( 15 | "using System;" 16 | "using System.Collections;" 17 | "using System.IO;" 18 | "using System.Reflection;" 19 | "" 20 | "" 21 | "namespace Meta.Scripting" 22 | "{")) 23 | 24 | (for (i 0 MAXARGS) 25 | (println 26 | (S<< "public delegate Object AltFun" i "(" 27 | (if (> i 0) (strinterleave (formap (j 0 i) (S<< "Object a" j)) ",") "") 28 | ");")) 29 | (println 30 | (S<< "public interface AltClosure" i " {")) 31 | (println 32 | (S<< " Object run(" 33 | (if (> i 0) (strinterleave (formap (j 0 i) (S<< "Object a" j)) ",") "") 34 | ");}")) 35 | ) 36 | 37 | 38 | (println "}") 39 | 40 | 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /src/cs/dll/AssemblyInfo.cs: -------------------------------------------------------------------------------- 1 | ////////////////////////////////////////////////////////////////////////////// 2 | // 3 | // OpenMBase 4 | // 5 | // Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | // 7 | // 8 | ////////////////////////////////////////////////////////////////////////////// 9 | 10 | using System.Reflection; 11 | using System.Runtime.CompilerServices; 12 | using System.Security; 13 | 14 | 15 | [assembly: AssemblyTitle(AssemblyVersion.kDescription)] 16 | [assembly: AssemblyDescription(AssemblyVersion.kDescription)] 17 | [assembly: AssemblyConfiguration("")] 18 | [assembly: AssemblyCompany(AssemblyVersion.kCompanyName)] 19 | [assembly: AssemblyProduct(AssemblyVersion.kProductName)] 20 | [assembly: AssemblyCopyright(AssemblyVersion.kCopyright)] 21 | [assembly: AssemblyTrademark("")] 22 | [assembly: AssemblyCulture("")] 23 | [assembly: AssemblyVersion(AssemblyVersion.kFileVersion)] 24 | 25 | 26 | [assembly: AssemblyDelaySign(true)] 27 | //[assembly: AssemblyKeyFile("")] 28 | //[assembly: AssemblyKeyName("")] 29 | [assembly:AssemblyKeyFile("pubpriv")] 30 | -------------------------------------------------------------------------------- /src/l/ext/raise.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;;; raise static ref 11 | 12 | (macro straise2 (code) 13 | (with-syms (nm xnm) 14 | `(begin 15 | (not.neth () 16 | (lift-field (field object ,nm (private) (static))) 17 | (leave null) 18 | ) 19 | (if (null? (not.neth () (leave ((object)(this # ,nm))))) 20 | (alet ,xnm ,code 21 | (not.neth ((object ,xnm)) 22 | (this # ,nm <- ,xnm) 23 | (leave ,xnm))) 24 | (not.neth () 25 | (leave ((object)(this # ,nm)))))))) 26 | 27 | 28 | 29 | (unit-test 3 (let ((abc (fun (x) (list (straise2 (cons x x)) x)))) 30 | (list (abc 10) (abc 20) (abc 30))) 31 | ( ((10 . 10) 10) 32 | ((10 . 10) 20) 33 | ((10 . 10) 30))) 34 | 35 | 36 | -------------------------------------------------------------------------------- /src/l/boot/stage2.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \section{Stage 2 --- compiling the core library} 12 | ;- 13 | 14 | (_Clean_Deps) 15 | (include "../options.al") 16 | 17 | (ctimex (println "Bootstrap stage: 2")) 18 | 19 | (define ENV (cc:newenv)) 20 | (cc:env:defmodule ENV "boot2c" 'dll) 21 | 22 | (define compiled-environment #t) 23 | 24 | ;;(define debug-compiler-drivertop #t) 25 | 26 | (begin 27 | (cc:toplevel-devour ENV '(top-begin 28 | (include "../boot/boot.al") 29 | (include "../boot/initlib.al") 30 | (include "../boot/dotnetlib.al") 31 | (include "../boot/common.al") 32 | (define core-environment-compiled #t) 33 | )) 34 | ) 35 | (cc:dump-module ENV) 36 | -------------------------------------------------------------------------------- /src/l/core/asmlib_load.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (define _t_call_generic (ctime `(dotnet ,(S<< generic_pfx "CALL_GENERIC")))) 12 | (define m_Call_Generic_00 (r_mtd _t_call_generic "call_generic" 13 | t_object_array t_object)) 14 | 15 | (define ms_Call_Generics_00 16 | (ctime `(noconst (list 17 | ,@(formap (i 0 SMAXARGS) 18 | `(r_mtd _t_call_generic ,(buildstring "call_generic__" i) ,@(formap (j 0 i) 't_object) t_object)))))) 19 | 20 | (define ms_Call_RevGenerics_00 21 | (ctime `(noconst (list 22 | ,@(formap (i 0 SMAXARGS) 23 | `(r_mtd _t_call_generic ,(buildstring "call_r_generic__" i) ,@(formap (j 0 i) 't_object) t_object)))))) 24 | 25 | ;;; now register the delegate callback: 26 | (let ((register (r_sbind _t_call_generic "register"))) 27 | (register)) 28 | -------------------------------------------------------------------------------- /src/l/boot/stage3.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \section{Stage 3 --- compiling the core library $+$ compiler} 12 | 13 | 14 | (_Clean_Deps) 15 | (include "../options.al") 16 | 17 | (ctimex (println "Bootstrap stage: 3")) 18 | 19 | (define ENV (cc:newenv)) 20 | (cc:env:defmodule ENV "boot3" 'dll) 21 | 22 | (define compiled-environment #t) 23 | 24 | (begin 25 | (cc:toplevel-devour ENV '(top-begin 26 | (define core-environment-compiled #t) 27 | (include "../boot/boot.al") 28 | (include "../boot/initlib.al") 29 | (include "../boot/dotnetlib.al") 30 | (include "../boot/common.al") 31 | (include "../core/compiler.al") 32 | )) 33 | ) 34 | (cc:dump-module ENV) 35 | -------------------------------------------------------------------------------- /src/l/lib/ml/mlcore-parser2.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (function peg-function-mltypename (n) 12 | (p:match n 13 | ((T $v . $args) `(,v ,@args)) 14 | (else (ccerror `(ML:TYPENAME ,n)))) 15 | ) 16 | 17 | (function peg-function-mltypeargcheck (a) 18 | (p:match a ((T $id) (list id)) 19 | (else (ccerror `(ML:TYPENAME ,a)))) 20 | ) 21 | 22 | (function peg-function-mlmaketype (a b) 23 | (let* ((l (cons a b)) 24 | (tl (cuttail l)) 25 | (lt (car (lasttail l)))) 26 | `(T ,lt ,@tl)) 27 | ) 28 | 29 | (define <*ML-INFIX*> (mkhash)) 30 | 31 | (function peg-function-definfix (str) 32 | (hashput <*ML-INFIX*> str #t)) 33 | 34 | (function peg-checkfunction-ml_check_infix (str) 35 | (if (hashget <*ML-INFIX*> str) #t nil)) 36 | 37 | 38 | (packrat-file "./mllexer.peg") 39 | (packrat-file "./mlparser.peg") 40 | 41 | 42 | -------------------------------------------------------------------------------- /COPYING: -------------------------------------------------------------------------------- 1 | Copyright (c) 2005-2017 Meta Alternative Ltd. 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in 11 | all copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 19 | THE SOFTWARE. 20 | -------------------------------------------------------------------------------- /doc/stylesheets.css: -------------------------------------------------------------------------------- 1 | #source { 2 | left: 60%; 3 | top: 60%; 4 | } 5 | #target { 6 | left: 120%; 7 | top: 120%; 8 | } 9 | svg { 10 | position: absolute; 11 | left: 0; 12 | top: 0; 13 | pointer-events: none; 14 | } 15 | line { 16 | stroke: grey; 17 | stroke-width: 2; 18 | stroke-opacity: 0.5; 19 | } 20 | 21 | 22 | .ident { color: #000099; } 23 | .keyword { color: blue; } 24 | .comment { color: green; } 25 | .lexic { color: #0099ff; } 26 | .pattern { text-shadow: 1px 1px 2px rgba(190, 190, 190, 1); } 27 | .code { font-family: monospace; border-style: dotted; border-width: 1px; font-size: 100%; } 28 | .democode { font-family: monospace; border-style: solid; border-width: 1px; font-size: 80%; } 29 | .const { color: #0099ff; } 30 | .symbol { color: #0099ff; } 31 | .column { width: 800px; text-align: justify; } 32 | 33 | .withhint { position: relative; } 34 | .hint { display: none; } 35 | 36 | .withhint:hover .hint { 37 | display: block; 38 | position: absolute; 39 | bottom: 1em; 40 | padding: 0.5em; 41 | color: #000000; 42 | background: #ebf4fb; 43 | border: 0.1em solid #b7ddf2; 44 | border-radius: 0.5em; 45 | } 46 | -------------------------------------------------------------------------------- /src/l/core/environment.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ; A new, cleaner way of handling the compilation environment. 11 | 12 | (using ("System.Threading") 13 | 14 | (define t_mutex (dotnet "System.Threading.Mutex")) 15 | (force-class-flush) 16 | 17 | (function thr:mkmutex () 18 | (new t_mutex)) 19 | 20 | (function thr:mutex_wait (mtx) 21 | ((r_tbind t_mutex "WaitOne") mtx)) 22 | 23 | (function thr:mutex_release (mtx) 24 | ((r_tbind t_mutex "ReleaseMutex") mtx)) 25 | 26 | ) 27 | 28 | (macro block-on (wh . body) 29 | (with-syms (res ex) 30 | `(begin 31 | (thr:mutex_wait ,wh) 32 | (let ((,res (try 33 | (begin ,@body) 34 | t_Exception 35 | (fun (,ex) 36 | (thr:mutex_release ,wh) 37 | (r_raise ,ex))))) 38 | (thr:mutex_release ,wh) 39 | ,res)))) 40 | 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /src/cs/dll/version.cs: -------------------------------------------------------------------------------- 1 | ////////////////////////////////////////////////////////////////////////////// 2 | // 3 | // OpenMBase 4 | // 5 | // Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | // 7 | // 8 | ////////////////////////////////////////////////////////////////////////////// 9 | 10 | 11 | /* 12 | [assembly: AssemblyTitle(AssemblyVersion.kDescription)] 13 | [assembly: AssemblyDescription(AssemblyVersion.kDescription)] 14 | [assembly: AssemblyConfiguration("")] 15 | [assembly: AssemblyCompany(AssemblyVersion.kCompanyName)] 16 | [assembly: AssemblyProduct(AssemblyVersion.kProductName)] 17 | [assembly: AssemblyCopyright(AssemblyVersion.kCopyright)] 18 | [assembly: AssemblyTrademark("")] 19 | [assembly: AssemblyCulture("")] 20 | [assembly: AssemblyVersion(AssemblyVersion.kFileVersion)] 21 | */ 22 | 23 | 24 | internal class AssemblyVersion 25 | { 26 | public const System.String kCopyright = ""; 27 | public const System.String kProductName = "MBase"; 28 | public const System.String kDescription = "MBase"; 29 | public const System.String kCompanyName = "Meta Alternative Ltd."; 30 | public const System.String kFileVersion = "0.2017.03.24"; 31 | } 32 | 33 | -------------------------------------------------------------------------------- /misc/stylesheets.css: -------------------------------------------------------------------------------- 1 | #source { 2 | left: 60%; 3 | top: 60%; 4 | } 5 | #target { 6 | left: 120%; 7 | top: 120%; 8 | } 9 | .svgarrows { 10 | position: absolute; 11 | left: 0; 12 | top: 0; 13 | pointer-events: none; 14 | } 15 | line { 16 | stroke: grey; 17 | stroke-width: 2; 18 | stroke-opacity: 0.5; 19 | } 20 | 21 | 22 | .ident { color: #000099; } 23 | .keyword { color: blue; } 24 | .comment { color: green; } 25 | .lexic { color: #0099ff; } 26 | .pattern { text-shadow: 1px 1px 2px rgba(190, 190, 190, 1); } 27 | .code { font-family: monospace; border-style: dotted; border-width: 1px; font-size: 100%; } 28 | .democode { font-family: monospace; border-style: solid; border-width: 1px; font-size: 80%; } 29 | .const { color: #0099ff; } 30 | .symbol { color: #0099ff; } 31 | .column { width: 60%; text-align: justify; } 32 | 33 | .withhint { position: relative; } 34 | .hint { display: none; } 35 | 36 | .withhint:hover .hint { 37 | display: block; 38 | position: absolute; 39 | bottom: 1em; 40 | padding: 0.5em; 41 | color: #000000; 42 | background: #ebf4fb; 43 | border: 0.1em solid #b7ddf2; 44 | border-radius: 0.5em; 45 | } 46 | 47 | body { font-family: sans-serif; font-weight: 100; } 48 | -------------------------------------------------------------------------------- /src/l/core/graphsort.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- A naive but fast linear sorting engine for graph colouring 11 | ;- 12 | ;- The idea is simple: range of numbers is typically quite small, so we can allocate an 13 | ;- array for a known range, fill it in a linear time and build a list out of it. 14 | ;- This must be significantly faster than quick sorting lists. 15 | ;- 16 | 17 | (function __array_sort (rng) 18 | (if rng 19 | (let ((mn 65536) 20 | (mx 0)) 21 | (foreach (r rng) 22 | (alet v (cadr r) 23 | (if (< v mn) (n.stloc! mn v)) 24 | (if (> v mx) (n.stloc! mx v)))) 25 | (let* ((nn (+ 1 (- mx mn))) 26 | (ar (anew t_object nn))) 27 | (foreach (r rng) 28 | (let* ((pos (- (cadr r) mn)) 29 | (vlu ([ pos ] ar))) 30 | (aset ar pos (cons r vlu)))) 31 | (alet res nil 32 | (for (i 0 nn) 33 | (alet vv ([ i ] ar) 34 | (if vv (foreach (v vv) (n.stloc! res (cons v res)))))) 35 | res))))) 36 | 37 | 38 | -------------------------------------------------------------------------------- /src/l/lib/parsing/lib.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (ctimex 11 | (#define packrat-optimised #t)) 12 | 13 | (ctimex 14 | (#define packrat-hist nil)) 15 | 16 | (include "./ast.al") 17 | (include "./util.al") 18 | (include "./ranges.al") 19 | (include "./compiler.al") 20 | (include "./lrengine.al") 21 | (include "./backend.al") 22 | 23 | (include "./temporary-source.al") 24 | 25 | (macro packrat-file (nm) 26 | (alet fp (generic-filepath nm) 27 | `(generic-include ,nm 28 | ,(alet res (peg:easyparse2 peg_pegparser 29 | (peg:file->stream fp)) 30 | (p:match res 31 | (((FAIL: . $err) . $r) (ccerror `(PEG: ,err ,(__peg:displaypos r)))) 32 | (else (car res))))))) 33 | 34 | (macro packrat-top-s (str) 35 | (alet res (peg:easyparse2 peg_pegparser 36 | (peg:str->stream str)) 37 | (p:match res 38 | (((FAIL: . $err) . $r) (ccerror `(PEG: ,err ,(__peg:displaypos r)))) 39 | (else (car res))))) 40 | 41 | (include "./highlight.al") -------------------------------------------------------------------------------- /src/l/boot/stage4.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (_Clean_Deps) 11 | 12 | (include "../options.al") 13 | 14 | (ctimex (println "Bootstrap stage: 4")) 15 | 16 | (define ENV (cc:newenv)) 17 | (cc:env:defmodule ENV "boot4" 'dll) 18 | 19 | (define compiled-environment #t) 20 | (define compiler-final #t) 21 | 22 | (begin 23 | (cc:toplevel-devour ENV '(top-begin 24 | (define compiler-final #t) 25 | (define compiled-environment #t) 26 | (define core-environment-compiled #t) 27 | (include "../boot/boot.al") 28 | (include "../boot/initlib.al") 29 | (include "../boot/dotnetlib.al") 30 | (include "../boot/common.al") 31 | ;;;;; 32 | 33 | (include "../core/compiler.al") 34 | (include "../core/unit.al") 35 | )) 36 | (cc:dump-module ENV) 37 | ) 38 | -------------------------------------------------------------------------------- /src/l/lib/ml/mlprelude.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | 12 | (function mlprint (x) (print (ml-pprint-value x))) 13 | 14 | (function terpri (x) (println "")) 15 | 16 | (function mlmkhash (x) (mkhash)) 17 | 18 | (function mlstringtolist (str) 19 | (let loop ((l (string->list str))) 20 | (p:match l 21 | (($a . $b) `(Cons ,a ,(loop b))) 22 | (() `(Nil))))) 23 | 24 | (function mllisttostring (lst) 25 | (list->string 26 | (let loop ((l lst)) 27 | (p:match l 28 | ((Cons $a $b) `(,a ,@(loop b))) 29 | ((Nil) nil))))) 30 | 31 | (function ml-setcar! (l c) 32 | (set-car! (cdr l) c)) 33 | 34 | (function ml-setcdr! (l c) 35 | (set-car! (cddr l) c)) 36 | 37 | (function ml-mkref (v) (cons v nil)) 38 | 39 | (function ml-deref (v) (car v)) 40 | (function ml-setref (v n) (set-car! v n)) 41 | 42 | 43 | (function lispclass (v) 44 | (p:match v 45 | (() '(FNull)) 46 | ($$N '(FNumber)) 47 | ($$S '(FString)) 48 | ($$M '(FSymbol)) 49 | ($$L '(FList)) 50 | (else 51 | (if (char? v) '(FChar) '(FOther))))) 52 | 53 | (function ml-lispnull (_) nil) 54 | 55 | 56 | -------------------------------------------------------------------------------- /src/l/lib/parsing/pegbasics.peg: -------------------------------------------------------------------------------- 1 | ////////////////////////////////////////////////////////////////////////////// 2 | // 3 | // OpenMBase 4 | // 5 | // Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | // 7 | // 8 | ////////////////////////////////////////////////////////////////////////////// 9 | 10 | .peg: 11 | 12 | parser pegbasics extends basics ( 13 | ignoring Spaces; 14 | 15 | pegbasics := .; 16 | 17 | keyword0 := 'rule'/'token'/'term'/'ignoring'/'define'/ 18 | 'parser'/'extends'/'dynhook'/'check'; 19 | keyword := keyword0 !IdentRest; 20 | 21 | rule lexical := lexical => {ctoken = lexic}; 22 | 23 | IdentRest := alpha/digit/'_'; 24 | token ident0 := !keyword (alpha IdentRest*) => {ctoken=ident}; 25 | token ident1x := (alpha/'_'/'-'/'*'/'@'/'^'/'$'/'%'/'&'/digit)+ 26 | => {ctoken=ident}; 27 | term ident := { ident0:i => $sval(i)} 28 | / { '[[' ident1x:x ']]' => $sval(x)}; 29 | 30 | comment := (('/*' (!'*/' .) * '*/') / ('//' (!(NEWLINE) .)* NEWLINE)) => {state=comment}; 31 | token innerchar := . ; 32 | token tString := SQUOTE ( !SQUOTE . ) * SQUOTE; 33 | token tComment := '"' ( !'"' . ) * '"' => {state=comment}; 34 | 35 | term string := tString:t => {ctoken = const} $stripval(t); 36 | term tcomment := tComment:t => $stripval(t); 37 | Spaces := (whitespace / comment) +; 38 | ) 39 | 40 | -------------------------------------------------------------------------------- /doc/template.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | \usepackage{alltt} 3 | \usepackage{rotating} 4 | \usepackage[usenames]{color} 5 | \usepackage[framemethod=tikz]{mdframed} 6 | 7 | \global\mdfdefinestyle{codeblock}{% 8 | outerlinewidth=2pt,innerlinewidth=0pt, 9 | outerlinecolor=gray,roundcorner=3pt 10 | } 11 | 12 | 13 | 14 | \newcommand{\colobox}[1]{ 15 | \begin{tikzpicture} 16 | [execute at end picture=% 17 | { 18 | \begin{pgfonlayer}{background} 19 | \path[fill=black!10,thick,draw=black!40,rounded corners=0.8mm] 20 | (current bounding box.south west) rectangle 21 | (current bounding box.north east); 22 | \end{pgfonlayer} 23 | }] 24 | \node (box) { 25 | \begin{minipage}{\textwidth} 26 | #1 27 | \end{minipage} 28 | }; 29 | \end{tikzpicture}\\} 30 | 31 | \newcommand{\commentbox}[1]{\colobox{\sl #1}} 32 | 33 | \newcommand{\lspspc}{{\color{white}{\tt{\_}}}} 34 | \newcommand{\lsplp}{(} 35 | \newcommand{\lsprp}{)} 36 | 37 | \newcommand{\docstring}[1]{\sl #1} 38 | \newcommand{\docentry}[1]{\sl #1} 39 | 40 | \newenvironment{pfcodeblock}[1]{}{} 41 | \newcommand{\pfcodeblockbegin}{\begingroup\setlength{\parindent}{0cm}\vskip1mm\begin{mdframed}[style=codeblock]} 42 | \newcommand{\pfcodeblockend}{\end{mdframed}\vskip1mm\endgroup} 43 | 44 | 45 | \definecolor{light-gray}{gray}{0.5} 46 | 47 | 48 | \begin{document} 49 | 50 | \tableofcontents 51 | 52 | \newpage 53 | 54 | \input generated 55 | 56 | \end{document} 57 | -------------------------------------------------------------------------------- /src/l/ext/unittests.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (define t_exception (dotnet "Exception")) 11 | (recfunction deep-comp (a b) 12 | (cond 13 | ((and (null? a) (null? b)) #t) 14 | ((and (list? a) (list? b)) 15 | (and (deep-comp (car a) (car b)) 16 | (deep-comp (cdr a) (cdr b)) )) 17 | (else (eq? a b)))) 18 | 19 | (function test-to-string (expr) 20 | (to-string 21 | (let loop ((e expr)) 22 | (cond 23 | ((null? e) e) 24 | ((list? e) 25 | (cond 26 | ((and (car e) 27 | (eqv? (car e) '-test-hide-)) 28 | (cadr e)) 29 | (else 30 | (cons (loop (car e)) 31 | (loop (cdr e)))))) 32 | (else e))))) 33 | 34 | (macro u:etest (expr res0) 35 | `(begin 36 | (print ,(test-to-string expr)) 37 | (let ((rval ,res0) 38 | (res (try ,expr t_exception to-string)) ) 39 | (print " = ") 40 | (print (to-string res)) 41 | (println (if (deep-comp res rval) " [OK]" 42 | (buildstring " [FAILED], exp: " 43 | (to-string rval)))) 44 | ))) 45 | 46 | (macro u:test (expr rest) 47 | `(u:etest ,expr (quote ,rest))) -------------------------------------------------------------------------------- /src/l/ext/tarjan.al: -------------------------------------------------------------------------------- 1 | (function tarjan (g v0) 2 | (let* ((g.l (mkhash)) (g.i (mkhash)) 3 | (myval (fun (x) 4 | (if (null? x) -1 x))) 5 | (mymin (fun (a b) 6 | (let ((a* (myval a)) (b* (myval b))) 7 | (if (< a* b*) a* b*)))) 8 | (stack (mkref nil)) 9 | (index (mkref 0))) 10 | (collector (SCCadd SCC) 11 | (use-ohash (g g.l g.i) 12 | (let loop ((v v0)) 13 | (g.i! v (deref index)) 14 | (g.l! v (deref index)) 15 | (r! index (+ 1 (deref index))) 16 | (r! stack (cons v (deref stack))) 17 | (foreach (n (g> v)) 18 | (if (= (myval (g.i> n)) -1) 19 | (begin 20 | (loop n) 21 | (g.l! v (mymin (g.l> v) (g.l> n)))) 22 | (when (memq n (deref stack)) 23 | (g.l! v (mymin (g.l> v) (g.i> n))) 24 | ))) 25 | (when (= (g.l> v) (g.i> v)) 26 | (format 27 | (let iloop ((s (deref stack)) (c nil)) 28 | (alet nc (cons (car s) c) 29 | (if (eqv? (car s) v) (list nc (cdr s)) 30 | (iloop (cdr s) nc)))) 31 | (c s) 32 | (r! stack s) 33 | (SCCadd c))))) 34 | (return (SCC))))) 35 | 36 | (function graph2graph (g) 37 | (with-ohash (h) 38 | (foreach (e g) 39 | (h! (car e) (cdr e))) 40 | (return h))) 41 | 42 | -------------------------------------------------------------------------------- /src/l/lib/ssa/doc.tex: -------------------------------------------------------------------------------- 1 | \documentclass{article} 2 | \usepackage{alltt} 3 | \usepackage{rotating} 4 | \usepackage[usenames]{color} 5 | \usepackage[framemethod=tikz]{mdframed} 6 | \usepackage{hyperref} 7 | 8 | \global\mdfdefinestyle{codeblock}{% 9 | outerlinewidth=2pt,innerlinewidth=0pt, 10 | outerlinecolor=gray,roundcorner=3pt 11 | } 12 | 13 | 14 | 15 | \newcommand{\colobox}[1]{ 16 | \begin{tikzpicture} 17 | [execute at end picture=% 18 | { 19 | \begin{pgfonlayer}{background} 20 | \path[fill=black!10,thick,draw=black!40,rounded corners=0.8mm] 21 | (current bounding box.south west) rectangle 22 | (current bounding box.north east); 23 | \end{pgfonlayer} 24 | }] 25 | \node (box) { 26 | \begin{minipage}{\textwidth} 27 | #1 28 | \end{minipage} 29 | }; 30 | \end{tikzpicture}\\} 31 | 32 | \newcommand{\commentbox}[1]{\colobox{\sl #1}} 33 | 34 | \newcommand{\lspspc}{{\color{white}{\tt{\_}}}} 35 | \newcommand{\lsplp}{(} 36 | \newcommand{\lsprp}{)} 37 | 38 | \newcommand{\docstring}[1]{\sl #1} 39 | \newcommand{\docentry}[1]{\sl #1} 40 | 41 | \newenvironment{pfcodeblock}[1]{}{} 42 | \newcommand{\pfcodeblockbegin}{\begingroup\setlength{\parindent}{0cm}\vskip1mm\begin{mdframed}[style=codeblock]} 43 | \newcommand{\pfcodeblockend}{\end{mdframed}\vskip1mm\endgroup} 44 | 45 | 46 | \definecolor{light-gray}{gray}{0.5} 47 | 48 | \begin{document} 49 | \setlength{\parindent}{0pt} 50 | 51 | \tableofcontents 52 | 53 | \newpage 54 | 55 | \newcommand*{\docpath}{./}% 56 | \input{\docpath/ssa-fold} 57 | 58 | \end{document} 59 | -------------------------------------------------------------------------------- /src/l/core/pmatchcomp.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;; 11 | ;; A tail recursion-friendly reimplementation of pattern matching 12 | ;; 13 | 14 | (expand-if (shashget (getfuncenv) 'compiler-final) 15 | (top-begin 16 | (cmacro pm:ptn-try (cnd body) 17 | `(if ,cnd ,body 18 | (pm:ptn-failed-m))) 19 | 20 | (cmacro p:match (val . ptns) 21 | (with-syms (lop agr cnt res) 22 | `(let ,lop ((,agr ,val) (,cnt 0)) 23 | (switch ,cnt 24 | ,@(let loop ((ps ptns) (n 0)) 25 | (cond 26 | ((null? ps) `((,n nil))) 27 | ((eqv? 'else (caar ps)) 28 | `((,n ,(cadar ps)))) 29 | (else 30 | `((,n 31 | (with-macros ((pm:ptn-failed-m (fun (_) 32 | (list (quote ,lop) (quote ,agr) ,(+ n 1))))) 33 | ,(pm:ptn-unroll 34 | (pm:ptn-process (caar ps)) 35 | agr 36 | `(begin ,@(cdar ps))))) 37 | ,@(loop (cdr ps) (+ n 1)))) 38 | )))))) 39 | )) 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /src/l/ext/extra.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;;; some extra common macros 11 | ;;; UNDOCUMENTED - for internal use only! 12 | 13 | (recfunction extra:find-opt-argvalue (lst nm) 14 | (p:match lst 15 | (() 'nil) 16 | ((=nm $v . $rest) v) 17 | (($x $v . $rest) (extra:find-opt-argvalue rest nm)) 18 | (else 'nil))) 19 | 20 | (macro extra:with-optional-args ( rlist alist . body) 21 | (let ((code 22 | (foreach-map (a alist) 23 | `(,a ,(extra:find-opt-argvalue rlist 24 | (string->symbol 25 | (S<< ":" a))))))) 26 | `(let ,code 27 | ,@body))) 28 | 29 | 30 | (macro extra:generic-include ( reader fnm ) 31 | (let* 32 | ((misc-reader (eval reader)) 33 | (oxpath (corelib:get-lookup-path)) 34 | (fn (buildstring oxpath "/" fnm)) 35 | (fi (mkreader (io-open-read fn))) 36 | (res `(top-begin 37 | (ctimex (corelib:set-lookup-path ,(_getpath fn))) 38 | ,@(let loop () (let ((r (misc-reader fi))) 39 | (if (null? r) nil 40 | (cons r (loop))))) 41 | (ctimex (corelib:set-lookup-path ,oxpath)) 42 | ))) 43 | (xio-close fi) 44 | res)) 45 | 46 | 47 | -------------------------------------------------------------------------------- /src/l/lib/ml/mlrepl.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (n.module mlrepl exe) 11 | (sysdll MBaseML) 12 | 13 | (function ml-read-eval-print (lst) 14 | (alet res (read-compile-eval `(ml ,(list->string lst))) 15 | (println (S<< ":>> " (ml-pprint-value res))) 16 | )) 17 | 18 | (define sem (car (string->list ";"))) 19 | (function ml-read-eval-print-loop (redr) 20 | (let loop ((buf nil)) 21 | (if (null? buf) (print "<< ")) 22 | (format 23 | (p:match buf 24 | (($a $b . $r) (list a b)) 25 | (else (list 0 0))) (a b) 26 | (if (and (eq? a sem) (eq? b sem)) 27 | (begin 28 | (ml-read-eval-print (reverse buf)) 29 | (loop nil)) 30 | (alet chr (not.neth ((System.IO.StreamReader redr)) 31 | (chr = (redr@Read)) 32 | (object ret = null) 33 | (if (>= chr 0) (ret <- ((object)((char)chr)))) 34 | (leave ret)) 35 | (if (not chr) nil 36 | (loop (cons chr buf)))))))) 37 | 38 | (function main () 39 | (shashput (getfuncenv) 'main nil) 40 | (read-int-eval `(n.module DefaultML)) 41 | (ml-read-eval-print-loop 42 | (not.neth () 43 | (leave ((object)(new System.IO.StreamReader 44 | (System.Console@OpenStandardInput))))))) 45 | 46 | -------------------------------------------------------------------------------- /src/l/tests/common.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (expand-if (not (shashget (getfuncenv) 'test-to-string)) 12 | 13 | (define t_exception (dotnet "Exception")) 14 | (recfunction deep-comp (a b) 15 | (cond 16 | ((and (null? a) (null? b)) #t) 17 | ((and (list? a) (list? b)) 18 | (and (deep-comp (car a) (car b)) 19 | (deep-comp (cdr a) (cdr b)) )) 20 | (else (eq? a b)))) 21 | 22 | (function test-to-string (expr) 23 | (to-string 24 | (let loop ((e expr)) 25 | (cond 26 | ((null? e) e) 27 | ((list? e) 28 | (cond 29 | ((and (car e) 30 | (eqv? (car e) '-test-hide-)) 31 | (cadr e)) 32 | (else 33 | (cons (loop (car e)) 34 | (loop (cdr e)))))) 35 | (else e))))) 36 | 37 | (macro u:etest (expr res0) 38 | `(begin 39 | (print ,(test-to-string expr)) 40 | (let ((rval ,res0) 41 | (res (try ,expr t_exception to-string)) ) 42 | (print " = ") 43 | (print (to-string res)) 44 | (println (if (deep-comp res rval) " [OK]" 45 | (buildstring " [FAILED], exp: " 46 | (to-string rval)))) 47 | ))) 48 | ) 49 | 50 | (macro u:test (expr rest) 51 | `(u:etest ,expr (quote ,rest))) 52 | 53 | (macro test (expr rest) 54 | `(u:etest ,expr (quote ,rest))) 55 | 56 | (macro etest rest 57 | `(u:etest ,@rest)) 58 | 59 | -------------------------------------------------------------------------------- /src/l/lib/parsing/basics.peg: -------------------------------------------------------------------------------- 1 | ////////////////////////////////////////////////////////////////////////////// 2 | // 3 | // OpenMBase 4 | // 5 | // Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | // 7 | // 8 | ////////////////////////////////////////////////////////////////////////////// 9 | 10 | .peg: 11 | 12 | parser basics ( 13 | alpha := [a-z]/[A-Z] ; 14 | digit := [0-9] ; 15 | lcalpha := [a-z]; 16 | ucalpha := [A-Z]; 17 | 18 | CR := 13; 19 | SQUOTE := 0x27; 20 | TAB := 9; 21 | NEWLINE := 10; 22 | whitespace := (' '/CR/TAB/NEWLINE)+ ; 23 | 24 | fpnumber := '-'? digit+ ('.' digit+)? ; 25 | intnumber := '-'? digit+ ; 26 | word := alpha+ ; 27 | define cslist := 28 | {a:head b cslist:tail => $cons(head,tail)} 29 | / {a:head => $wrap(head)}; 30 | 31 | define ecslist := 32 | {a:head b ecslist:tail => $cons(head,tail)} 33 | / {a:head => $wrap(head)} 34 | / {!a => $nil() }; 35 | 36 | define slist := {a:head slist:tail => $cons(head,tail)} 37 | / {a:head => $wrap(head)}; 38 | 39 | 40 | define eslist := {a:head eslist:tail => $cons(head,tail)} 41 | / {!a => $nil() }; 42 | 43 | define plist := {a b:head plist:tail => $cons(head, tail) } 44 | / {a b:head => $wrap(head) }; 45 | 46 | define eplist := {a b:head eplist:tail => $cons(head, tail) } 47 | / {a b:head => $wrap(head) } 48 | / {!(a b) => $nil() }; 49 | 50 | basics := whitespace; 51 | token empty := ! ..; 52 | ) 53 | 54 | -------------------------------------------------------------------------------- /src/l/lib/pfront/pfrepl.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (n.module pfrepl exe) 11 | (sysdll MBaseFront) 12 | 13 | (function pf-read-eval-print (lst) 14 | (alet res (read-compile-eval `(pfront-expand-string ,(list->string lst))) 15 | (println (S<< ":>> " (to-string res))) 16 | )) 17 | 18 | (define sem (car (string->list ";"))) 19 | (function pf-read-eval-print-loop (redr) 20 | (let loop ((buf nil)) 21 | (if (null? buf) (print "<< ")) 22 | (format 23 | (p:match buf 24 | (($a $b . $r) (list a b)) 25 | (else (list 0 0))) (a b) 26 | (if (and (eq? a sem) (eq? b sem)) 27 | (begin 28 | (pf-read-eval-print (reverse (cddr buf))) 29 | (loop nil)) 30 | (alet chr (not.neth ((System.IO.StreamReader redr)) 31 | (chr = (redr@Read)) 32 | (object ret = null) 33 | (if (>= chr 0) (ret <- ((object)((char)chr)))) 34 | (leave ret)) 35 | (if (not chr) nil 36 | (loop (cons chr buf)))))))) 37 | 38 | (function main () 39 | (shashput (getfuncenv) 'main nil) 40 | (corelib:set-lookup-path (not.neth () (leave 41 | (System.IO.Directory@GetCurrentDirectory)))) 42 | (read-int-eval `(n.module DefaultPF)) 43 | (pf-read-eval-print-loop 44 | (not.neth () 45 | (leave ((object)(new System.IO.StreamReader 46 | (System.Console@OpenStandardInput))))))) 47 | 48 | -------------------------------------------------------------------------------- /src/l/ext/ast2.al: -------------------------------------------------------------------------------- 1 | ;; TODO!!!! 2 | ;; derived AST new tags must be *appended* to the original AST tags. 3 | ;; When deriving from more than one sources, "newtags" flag must be added 4 | ;; which should force a tag rewrite (i.g., marking all the variant nodes for a 5 | ;; visitor attention. 6 | 7 | 8 | ;; TODO!!!! 9 | ;; Check if source and destination definitions match sanely 10 | 11 | ;; TODO!!!! 12 | ;; Use the destination format for explicit and implicit builders, not the source one 13 | 14 | 15 | ;; All the high-level ASTs 16 | (include "./ast2-ast.al") 17 | ;; Translating the frontend macro language into AST 18 | (include "./ast2-frontend.al") 19 | ;; Maintaining the AST hierarchy 20 | (include "./ast2-hier.al") 21 | ;; Fusing AST definition into a visitor 22 | (include "./ast2-fuse.al") 23 | ;; Lowering a visitor into an executable code 24 | (include "./ast2-lowering.al") 25 | ;; Platform-specific backend 26 | (include "./ast2-backend.al") 27 | ;; Integration 28 | (include "./ast2-macros.al") 29 | 30 | ;; Translation sequence: 31 | ; ast-front-lower + ast-merge-inherited for each def:ast macro 32 | ; ast-variant-hash 33 | ; \ 34 | ; ----> for each ast:visit:new macro 35 | ; / 36 | ; ast-visitor-lower 37 | ; -> 38 | ; ast-visitor-fuse (with the ast source, not hash) 39 | ; -> visitor-inject-listnodes 40 | ; -> visitor-backend-prepare 41 | ; -> visitor-refine-else 42 | ; -> visitor-backend-lowering 43 | ; -> visitor-populate-varids 44 | ; -> visitor-lower-further 45 | ; 46 | ; For list-formatted input, after visitor-refine-else: 47 | ; ast-listform-lowering 48 | ; 49 | ; For each AST, list->ast and ast->list transformers are generated. 50 | ; -------------------------------------------------------------------------------- /src/l/core/cc-anntexpand.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (recfunction cc:aexpand (mcenv l postn) 11 | (alet amcenv (cons *cmhash* mcenv) 12 | (cond 13 | ((null? l) l) 14 | ((asymbol? l) 15 | (alet l (asymbol l) 16 | (if (corelib:symbol-starts-with '## l) 17 | (let ((v (hashget-seq amcenv l))) (if v ((hashget-seq amcenv l)) '#f)) 18 | l 19 | ))) 20 | ((list? l) 21 | (cond 22 | ((aeqv? (car l) 'quote) (a:sanitise l)) 23 | ((aeqv? (car l) 'inner-expand-with) 24 | (let ((nenv (cons (cadr l) mcenv)) 25 | (code (caddr l))) 26 | (cc:aexpand nenv code postn))) 27 | ((aeqv? (car l) 'inner-expand-first) 28 | (cc:aexpand mcenv 29 | (map (lambda (v) (cc:aexpand mcenv v)) (cdr l)) 30 | postn 31 | )) 32 | (else 33 | (let ((sh (if (asymbol? (car l)) 34 | (hashget-seq amcenv (asymbol (car l))) 35 | #f))) 36 | (if sh 37 | (try 38 | (let ((pso (asymbol-pos (car l))) 39 | (res (sh l))) 40 | (cc:aexpand amcenv res pso)) 41 | t_Exception 42 | (lambda (x) 43 | (cc:comperror 44 | `(CC04:EXPANDING ,(cc:elaborate-exception x) IN ,l)) 45 | ) 46 | ) 47 | (map (lambda (ll) (cc:aexpand amcenv ll postn)) l) 48 | ))))) 49 | (else l)))) 50 | 51 | (function cc:adefexpand (expr) 52 | (cc:aexpand (getmacroenv) expr nil)) -------------------------------------------------------------------------------- /src/l/core/cc-plugins.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (define cc:core-plugins-list (mkref)) 11 | (define cc:pre-lift-plugins-list (mkref)) 12 | (define cc:after-lift-plugins-list (mkref)) 13 | (define cc:flat-plugins-list (mkref)) 14 | (define cc:dotnet-plugins-list (mkref)) 15 | 16 | (function cc:apply-plugins (lst0 e0) 17 | (let loop ((lst (cdr lst0)) (e e0)) 18 | (if (null? lst) e 19 | (alet res ((car lst) e) 20 | (loop (cdr lst) res))))) 21 | 22 | (function cc:core-plugins (e) 23 | (cc:apply-plugins cc:core-plugins-list e)) 24 | 25 | (function cc:pre-lift-plugins (e) 26 | (cc:apply-plugins cc:pre-lift-plugins-list e)) 27 | 28 | (function cc:after-lift-plugins (e) 29 | (cc:apply-plugins cc:after-lift-plugins-list e)) 30 | 31 | (function cc:flat-plugins (e) 32 | (cc:apply-plugins cc:flat-plugins-list e)) 33 | 34 | (function cc:dotnet-plugins (e) 35 | (cc:apply-plugins cc:dotnet-plugins-list e)) 36 | 37 | (function cc:add-plugin (part fn) 38 | ("Add a plugin function to the compilation chain." 39 | "Possible part names are: core, pre-lift, after-lift, flat, dotnet." 40 | "Plugin function takes one argument and returns the value of the same format as its argument." 41 | ) 42 | (alet wh 43 | (case part 44 | ((core) cc:core-plugins-list) 45 | ((pre-lift) cc:pre-lift-plugins-list) 46 | ((after-lift) cc:after-lift-plugins-list) 47 | ((flat) cc:flat-plugins-list) 48 | ((dotnet) cc:dotnet-plugins-list) 49 | (else (ccerror `(NO-SUCH-STAGE ,part)))) 50 | (set-cdr! wh (cons fn (cdr wh))) 51 | (cdr wh) 52 | )) 53 | 54 | 55 | -------------------------------------------------------------------------------- /src/l/core/cc-sanitise.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (function cc:sanitise-type (t) 11 | `(othertype ,(S<< t))) 12 | 13 | (function cc:sanitise-method (m) 14 | `(othermethod ,(S<< ((r_tbind "System.Reflection.MemberInfo" "get_DeclaringType") m)) 15 | ,((r_bind t_MethodInfo "get_Name") m) 16 | ,(foreach-map (a (a->l ((r_bind t_MethodInfo "GetParameters") m))) 17 | ((r_tbind "System.Reflection.ParameterInfo" "get_ParameterType") a)) 18 | )) 19 | 20 | (function cc:sanitise-constructor (m) 21 | `(otherctor ,(S<< ((r_tbind "System.Reflection.MemberInfo" "get_DeclaringType") m)) 22 | ,(foreach-map (a (a->l ((r_bind t_ConstructorInfo "GetParameters") m))) 23 | ((r_tbind "System.Reflection.ParameterInfo" "get_ParameterType") a)) 24 | )) 25 | 26 | (function cc:sanitise-field (f) 27 | `(otherfield ,(S<< ((r_tbind "System.Reflection.MemberInfo" "get_DeclaringType") f)) 28 | ,((r_tbind "System.Reflection.FieldInfo" "get_Name") f))) 29 | 30 | (function cc:core-sanitise-tokens-inner (body) 31 | (let loop ((bd body)) 32 | (p:match bd 33 | (($a . $b) 34 | (cons (loop a) 35 | (loop b))) 36 | ($$M bd) 37 | ($$S bd) 38 | ($$N bd) 39 | (() nil) 40 | (else 41 | (type-case-hier bd 42 | (t_Type 43 | (cc:sanitise-type bd)) 44 | (t_MethodInfo 45 | (cc:sanitise-method bd)) 46 | (t_ConstructorInfo 47 | (cc:sanitise-constructor bd)) 48 | (t_FieldInfo 49 | (cc:sanitise-field bd)) 50 | (else (ccerror `(CC:SANITISE-UNKNOWN-TYPE ,(S<< (r_GetType bd))))))) 51 | ))) 52 | -------------------------------------------------------------------------------- /src/l/lib/pfront/pfrepl2.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (n.module pfrepl2 exe) 11 | (sysdll MBaseFront) 12 | 13 | (function pf-very-lazy-reader (redr) 14 | (__peg:lst2stream 15 | (let loop () 16 | (alet chr (not.neth ((System.IO.StreamReader redr)) 17 | (chr = (redr@Read)) 18 | (object ret = null) 19 | (if (>= chr 0) (ret <- ((object)((char)chr)))) 20 | (leave ret)) 21 | (writeline `(C: ,chr)) 22 | (if (not chr) nil 23 | (cons chr loop)))) nil)) 24 | 25 | (function pf-read-eval-print (lst) 26 | (alet res (read-compile-eval (hlevel-compile lst)) 27 | (println (S<< ":>> " (to-string res))) 28 | (print ">>") 29 | )) 30 | 31 | (function peg-function-PFrepltoplev (s) 32 | (pf-read-eval-print s)) 33 | 34 | (pfront-expand-string 35 | "parser pftehrepl (pfront) { 36 | pftehrepl := { [pfeexpr]:e [Spaces]* [pftehrepl]:rst => $nil() } 37 | / { ![otopexpr] [Spaces]* => $nil() }; 38 | pfeexpr := { [otopexpr]:e => $PFrepltoplev(e) }; 39 | otopexpr := [topexpr]:e ([CR]/\";\") => e; 40 | } ") 41 | 42 | (force-class-flush) 43 | 44 | (function main () 45 | (shashput (getfuncenv) 'main nil) 46 | (corelib:set-lookup-path (not.neth () (leave 47 | (System.IO.Directory@GetCurrentDirectory)))) 48 | (read-int-eval `(n.module DefaultPF)) 49 | (print ">>") 50 | 51 | (peg:easyparse peg_pftehrepl 52 | (pf-very-lazy-reader 53 | (not.neth () 54 | (leave ((object)(new System.IO.StreamReader 55 | (System.Console@OpenStandardInput)))))))) 56 | 57 | 58 | 59 | -------------------------------------------------------------------------------- /misc/header.tex: -------------------------------------------------------------------------------- 1 | \documentclass[10pt,a4paper]{article} 2 | \usepackage[top=30pt,bottom=40pt,left=48pt,right=46pt]{geometry} 3 | \usepackage{alltt} 4 | \usepackage{rotating} 5 | \usepackage[usenames]{color} 6 | \usepackage{multicol} 7 | \usepackage[framemethod=tikz]{mdframed} 8 | \usepackage[hidelinks]{hyperref} 9 | 10 | \definecolor{purple}{rgb}{0.5,0,0.5} 11 | \global\mdfdefinestyle{codeblock}{% 12 | outerlinewidth=2pt,innerlinewidth=0pt, 13 | outerlinecolor=gray,roundcorner=3pt 14 | } 15 | 16 | \global\mdfdefinestyle{demoblock}{% 17 | outerlinewidth=0.5pt,innerlinewidth=0pt, 18 | outerlinecolor=blue,roundcorner=0pt 19 | } 20 | 21 | 22 | 23 | \newcommand{\colobox}[1]{ 24 | \begin{tikzpicture} 25 | [execute at end picture=% 26 | { 27 | \begin{pgfonlayer}{background} 28 | \path[fill=black!10,thick,draw=black!40,rounded corners=0.8mm] 29 | (current bounding box.south west) rectangle 30 | (current bounding box.north east); 31 | \end{pgfonlayer} 32 | }] 33 | \node (box) { 34 | \begin{minipage}{\textwidth} 35 | #1 36 | \end{minipage} 37 | }; 38 | \end{tikzpicture}\\} 39 | 40 | \newcommand{\commentbox}[1]{\colobox{\sl #1}} 41 | 42 | \newcommand{\lspspc}{{\color{white}{\tt{\_}}}} 43 | \newcommand{\lsplp}{(} 44 | \newcommand{\lsprp}{)} 45 | 46 | \newcommand{\docstring}[1]{\sl #1} 47 | \newcommand{\docentry}[1]{\sl #1} 48 | 49 | \newenvironment{pfcodeblock}[1]{}{} 50 | \newcommand{\pfcodeblockbegin}{\begingroup\setlength{\parindent}{0cm}\vskip1mm\begin{mdframed}[style=codeblock]} 51 | \newcommand{\pfcodeblockend}{\end{mdframed}\vskip1mm\endgroup} 52 | 53 | \newenvironment{pficodeblock}[1]{}{} 54 | \newcommand{\pficodeblockbegin}{\begingroup} 55 | \newcommand{\pficodeblockend}{\endgroup} 56 | 57 | \newcommand{\pfdemoblockbegin}{\begin{minipage}[t]{0.8\linewidth}\begingroup\fontsize{8}{8}\selectfont\setlength{\parindent}{0cm}\vskip1mm\begin{mdframed}[style=demoblock]} 58 | \newcommand{\pfdemoblockend}{\end{mdframed}\vskip1mm\endgroup\end{minipage}} 59 | 60 | 61 | \definecolor{light-gray}{gray}{0.5} 62 | -------------------------------------------------------------------------------- /src/l/core/fccase.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (macro fccase_sw (arg . elts0) 12 | (let* ((s (gensym)) (ss (gensym)) 13 | (h (gensym)) 14 | (mp (mkhash)) 15 | (tcnt (mkref 0)) 16 | (cnt (mkref 0)) 17 | (ts (tailsplit (fun (x) (eqv? (car x) 'else)) elts0)) 18 | (elts (cdr ts)) 19 | (deflt (car ts)) 20 | ) 21 | (foreach (k elts) 22 | (when (list? (car k)) 23 | (foreach (i (car k)) 24 | (alet chk (ohashget mp i) 25 | (if chk 26 | (ccerror `(FCCASE-DUPLICATE ,i)))) 27 | (ohashput mp i (deref cnt)) 28 | (r! tcnt (+ (deref tcnt) 1)) 29 | ) 30 | (r! cnt (+ (deref cnt) 1)) 31 | )) 32 | (if (> (deref tcnt) 7) 33 | `(let* ( 34 | (,h (straise 35 | (let ((,h (mkhash))) 36 | ,@(foreach-mappend (k elts) 37 | (foreach-map (i (car k)) 38 | `(ohashput ,h (quote ,i) ,(ohashget mp i)))) 39 | ,h 40 | ))) 41 | (,s ,arg) 42 | (,ss (ohashget ,h (car ,s))) 43 | ) 44 | (if ,ss 45 | (switch ,ss 46 | ,@(foreach-map (k elts) 47 | (format k (syms fm . body) 48 | `(,(ohashget mp (car syms)) 49 | (format (cdr ,s) ,fm 50 | ,@body))))) 51 | ,(if deflt 52 | (format (car deflt) (_ . body) 53 | `(begin ,@body)) 54 | 'nil 55 | ))) 56 | `(fccase.inner ,arg ,@elts0) 57 | ))) 58 | 59 | (cmacro fccase rest `(fccase_sw ,@rest)) 60 | 61 | (unit-test 3 (fccase '(a 1 2) ((a) _ 10) ((b c) _ 20)) 10) 62 | 63 | 64 | -------------------------------------------------------------------------------- /src/l/core/cc-cons.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (function cc:constant-p ( expr ) 11 | (cc:mbcoreast:visit expr expr 12 | (expr DEEP 13 | ((Num #t) 14 | (Str #t) 15 | (Chr #t) 16 | (Bool #t) 17 | (Symbol #t) 18 | (Nil #t) 19 | (Quote #t) 20 | (Car e) 21 | (Cdr e) 22 | (Cons (and a b)) 23 | (Cons1 a) 24 | 25 | (NullP a) 26 | (PairP a) 27 | (Not a) 28 | (Eqv (and a b)) 29 | (BinOp (and left right)) 30 | 31 | (else nil))))) 32 | 33 | (function cc:get-arithop (op) 34 | (case op 35 | ((Add) '+) 36 | ((Sub) '-) 37 | ((Mul) '*) 38 | ((Div) '/) 39 | (else (ccerror 'ARITHOP)))) 40 | 41 | (function cc:constant-eval ( expr ) 42 | (let* ((code 43 | (cc:mbcoreast:visit expr expr 44 | (expr DEEP 45 | ((Num n) 46 | (Str s) 47 | (Chr c) 48 | (Bool b) 49 | (Symbol `(quote ,s)) 50 | (Nil 'nil) 51 | (Quote `(quote ,l)) 52 | (Car `(car ,e)) 53 | (Cdr `(cdr ,e)) 54 | (Cons `(cons ,a ,b)) 55 | (Cons1 `(cons ,a nil)) 56 | 57 | (NullP `(null? ,a)) 58 | (PairP `(pair? ,a)) 59 | (Not `(not ,a)) 60 | (Eqv `(eqv? ,a ,b)) 61 | (BinOp `(,(cc:get-arithop op) ,left ,right)) 62 | (else (ccerror '(IMPOSSIBLE))))))) 63 | (v (read-int-eval code))) 64 | `(Quote ,v))) 65 | 66 | ; A simple constant folding pass 67 | (recfunction cc:constant-fold ( expr ) 68 | (cc:mbcoreast:visit expr expr 69 | (expr _ 70 | ((NoConst node) 71 | (else-deep 72 | ((else (if (cc:constant-p node) 73 | (cc:constant-eval node) 74 | node)))))))) -------------------------------------------------------------------------------- /src/l/lib/pfront/pftexprint.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (n.module pftexprint exe) 11 | 12 | (sysdll MBaseFront) 13 | 14 | (define ofname (mkref "output")) 15 | 16 | (function main () 17 | (shashput (getfuncenv) 'main nil) 18 | (corelib:set-lookup-path (not.neth () (leave 19 | (System.IO.Directory@GetCurrentDirectory)))) 20 | (let loop ((args (a->l *CMDLINE*))) 21 | (p:match args 22 | (("/i" $fnm . $rest) 23 | (read-compile-eval '(n.module temp)) 24 | (read-compile-eval `(hlevl-file ,fnm)) 25 | (loop rest) 26 | ) 27 | 28 | (("/inv" $ofl $fnm . $rest) 29 | (begin 30 | (r! ofname ofl) 31 | (read-compile-eval '(n.module front)) 32 | (read-compile-eval `(hlevl-file1-texinv ,(deref ofname) ,fnm)) 33 | (if rest (loop rest)) 34 | )) 35 | 36 | (($ofl $fnm) 37 | (begin 38 | (r! ofname ofl) 39 | (read-compile-eval '(n.module front)) 40 | (read-compile-eval `(hlevl-file1-tex ,(deref ofname) ,fnm)))) 41 | 42 | (($ofl "/c" $exenm $fnm) 43 | (begin 44 | (r! ofname ofl) 45 | (read-compile-eval `(n.module ,(Sm<< exenm) exe)) 46 | (read-compile-eval `(hlevl-file1-tex ,(deref ofname) ,fnm)) 47 | (read-compile-eval `(n.save)))) 48 | 49 | (($ofl "/d" $exenm $fnm) 50 | (begin 51 | (r! ofname ofl) 52 | (read-compile-eval `(n.module ,(Sm<< exenm))) 53 | (read-compile-eval `(hlevl-file1-tex ,(deref ofname) ,fnm)) 54 | (read-compile-eval `(n.save)))) 55 | 56 | (else 57 | (iter println ' 58 | ("Usage:" 59 | " pfront.exe - execute a file" 60 | " pfront.exe /c - compile a file" 61 | " pfront.exe /d - compile a file into a dll" 62 | ))) 63 | ))) -------------------------------------------------------------------------------- /src/l/core/unit.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ; Simple unit tests generation framework. 11 | 12 | (recfunction deep-comp (a b) 13 | (cond 14 | ((and (null? a) (null? b)) #t) 15 | ((and (list? a) (list? b)) 16 | (and (deep-comp (car a) (car b)) 17 | (deep-comp (cdr a) (cdr b)) )) 18 | (else (eq? a b)))) 19 | 20 | (cmacro unit-test (level src exp) 21 | (alet tests (shashget (getfuncenv) 'unit-tests-destination) 22 | (when tests 23 | (set-car! tests (cons (list level 'T src exp) (car tests)))) 24 | `(begin ))) 25 | 26 | (cmacro unit-test-defn (level code) 27 | (alet tests (shashget (getfuncenv) 'unit-tests-destination) 28 | (when tests 29 | (set-car! tests (cons (list level 'I code nil) (car tests)))) 30 | `(begin ))) 31 | 32 | 33 | (macro unit-tests-use () 34 | (shashput (getfuncenv) 'unit-tests-destination (noconst (cons nil nil))) 35 | `(begin )) 36 | 37 | (macro unit-tests-dump outs 38 | (alet tests (shashget (getfuncenv) 'unit-tests-destination) 39 | (when tests 40 | (with-hash (lvls) 41 | (foreach (i (car tests)) 42 | (format i (lvl md src exp) 43 | (lvls! lvl (cons (list md src exp) (lvls> lvl))))) 44 | (foreach (o outs) 45 | (format o (level fname) 46 | (alet ii (lvls> level) 47 | (call-with-output-file (S<< fname) 48 | (fun (fo) 49 | (foreach (i ii) 50 | (format i (md src exp) 51 | (case md 52 | ((T) 53 | (fprintln fo (to-string `(u:test ,src ,exp)))) 54 | ((I) 55 | (fprintln fo (to-string src))) 56 | )) 57 | ))))) 58 | )))) 59 | `(begin ) 60 | ) 61 | 62 | 63 | -------------------------------------------------------------------------------- /src/l/lib/pfront/backport.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (define pfront-macros-defined #t) 12 | 13 | (macro flatbegin-inside-begin-with-defs code 14 | `(begin-with-defs ,@code)) 15 | 16 | (macro pfront.debugpoint x 17 | 'nil) 18 | 19 | (cmacro pfront.debugpoint x 20 | `(inner.debugpoint ,@x)) 21 | 22 | (macro pfront.fixlocal x 23 | 'nil) 24 | 25 | (cmacro pfront.fixlocal x 26 | `(inner.fixlocal ,@x)) 27 | 28 | (macro pfront.with-format (e f body) 29 | `(p:match ,e 30 | (,f ,body) 31 | (else (ccerror (list 'FORMAT-FAILED ,(list 'quasiquote f)))))) 32 | 33 | (macro pfront-collector (args . body) 34 | (format args (addnm getnm) 35 | (with-syms (clec cren v v1) 36 | `(let* ((,cren (noconst (cons nil nil))) 37 | (,clec (mkref ,cren))) 38 | (let-metadata 39 | ((,(cdr addnm) (fun (,v) (alet ,v1 (cons ,v nil) 40 | (set-cdr! (deref ,clec) ,v1) 41 | (r! ,clec ,v1) 42 | ,v))) 43 | (,(cdr getnm) (fun () (cdr ,cren)))) 44 | ,@body))))) 45 | 46 | 47 | (macro begin-with-defs code 48 | `(begin 49 | ,@(let loop ((c code)) 50 | (p:match c 51 | (((flatbegin-inside-begin-with-defs . $r1) . $rest) 52 | (loop `(,@r1 ,@rest))) 53 | (((inblock-def (var $nm . $md) $v) . $rest) 54 | `((let-metadata (((,nm ,@md) ,v)) 55 | ,@(if (shashget (getfuncenv) 'compiler-debug-enabled) 56 | `((pfront.fixlocal ,nm)) nil) 57 | (begin-with-defs ,@rest)))) 58 | (((inblock-def-format $f $v) . $rest) 59 | `((p:match ,v (,f (begin-with-defs ,@rest)) 60 | (else (ccerror (list 'FORMAT-FAILED ,(list 'quasiquote f))))))) 61 | (($hd . $tl) 62 | (cons hd (loop tl))) 63 | (() nil))))) 64 | 65 | -------------------------------------------------------------------------------- /src/l/core/asmlib_common.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (define MAXARGS 20) 11 | (define SMAXARGS 11) 12 | (define SSMAXARGS (- SMAXARGS 1)) 13 | 14 | (net.types SimpleCode Code Closure Symbol Pair IntPtr Runtime MiscCall AltClosure Delegate) 15 | (net.types Exception MulticastDelegate) 16 | 17 | (define m_SimpleCode_Invoke (r_mtd t_SimpleCode "Invoke" t_object_array)) 18 | (define m_Code_Run (r_mtd t_Code "run" t_object_array t_object_array)) 19 | (define f_Closure_frame (r_getField t_Closure "frame")) 20 | (define f_Closure_c (r_getField t_Closure "c")) 21 | (define scons (r_typer "System.Console")) 22 | (define m_writeline (r_mtd scons "WriteLine" t_string)) 23 | 24 | (function __mkname (n i) 25 | (string-append n (any->string i))) 26 | 27 | (function __mksname (n i) 28 | (string->symbol (__mkname n i))) 29 | 30 | (ctime `(top-begin 31 | ,@(formap (i 0 MAXARGS) 32 | `(define ,(__mksname "AltFun" i) 33 | (dotnet ,(__mkname "AltFun" i)))) 34 | ,@(formap (i 0 MAXARGS) 35 | `(define ,(__mksname "AltClosure" i) 36 | (dotnet ,(__mkname "AltClosure" i)))) 37 | ,@(formap (i 0 MAXARGS) 38 | `(define ,(__mksname "AltClFun" i) 39 | (r_mtd ,(__mksname "AltClosure" i) 40 | "run" ,@(formap (j 0 i) 'object)))) 41 | 42 | (define AltFuns (list ,@(formap (i 0 MAXARGS) 43 | (__mksname "AltFun" i)))) 44 | (define AltClosures (list ,@(formap (i 0 MAXARGS) 45 | (__mksname "AltClosure" i)))) 46 | (define AltClFuns (list ,@(formap (i 0 MAXARGS) 47 | (__mksname "AltClFun" i)))) 48 | )) 49 | 50 | (define t_nint32 (r_typebyname "System.Int32")) 51 | ;; 1st try loading the existing dll 52 | 53 | 54 | 55 | -------------------------------------------------------------------------------- /src/l/ext/float.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (define flt:format 11 | ((r_tbind "System.Globalization.CultureInfo" "get_NumberFormat") 12 | ((r_tsbind "System.Globalization.CultureInfo" "get_InvariantCulture")))) 13 | 14 | (function flt:parse (s) 15 | "Parse a string into a double (using System.Double.Parse method)" 16 | ((r_tsbind "System.Double" "Parse" string "System.IFormatProvider") 17 | s flt:format )) 18 | 19 | (function flt1:parse (s) 20 | "Parse a string into a single precision float (using System.Single.Parse method)" 21 | ((r_tsbind "System.Single" "Parse" string "System.IFormatProvider") 22 | s flt:format )) 23 | 24 | (define flt:abs (r_tsbind "System.Math" "Abs" "System.Double")) 25 | 26 | (macro f.op (nm op) 27 | `(function ,nm (a b) 28 | ,(S<< "Floating point " op) 29 | (n.asm ( a b ) 30 | (expr a) 31 | (Unbox ,t_Double) 32 | (Ldind_R8) 33 | (expr b) 34 | (Unbox ,t_Double) 35 | (Ldind_R8) 36 | (,op) 37 | (Box ,t_Double) 38 | ))) 39 | 40 | (f.op f+ Add) 41 | (f.op f- Sub) 42 | (f.op f* Mul) 43 | (f.op f/ Div) 44 | 45 | ;;; TODO: BUG BUG BUG! 46 | ;;; r_tbind fails here! 47 | (function f> (a b) 48 | (> 49 | ((r_bind t_Double "CompareTo" t_object) a b) 50 | 0)) 51 | (function f= (a b) 52 | (eq? 53 | ((r_bind t_Double "CompareTo" t_object) a b) 54 | 0)) 55 | 56 | (macro f# (str) 57 | `(n.asm () (Ldc_R8 ,(flt:parse str)) (Box ,t_Double))) 58 | 59 | (net.types Convert) 60 | 61 | (force-class-flush) 62 | 63 | (define f->i (r_tsbind t_Convert "ToInt32" t_Double)) 64 | (define i->f (r_tsbind t_Convert "ToDouble" t_Int32)) 65 | 66 | (define rgen (new "System.Random")) 67 | (define rnext (r_tbind "System.Random" "Next" int)) 68 | (function random () 69 | (let* ((n (rnext rgen 100000)) 70 | (nf (f- (f/ (i->f n) (f# "50000")) (f# "1")))) 71 | nf)) 72 | 73 | (function gauss () 74 | (f/ (foldl f+ (f# "0") (formap (i 0 12) (random))) (f# "6"))) 75 | 76 | 77 | 78 | -------------------------------------------------------------------------------- /src/l/lib/ml/mllexer.peg: -------------------------------------------------------------------------------- 1 | ////////////////////////////////////////////////////////////////////////////// 2 | // 3 | // OpenMBase 4 | // 5 | // Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | // 7 | // 8 | ////////////////////////////////////////////////////////////////////////////// 9 | 10 | .peg: 11 | 12 | parser mbasemlcore ( 13 | ignoring Spaces; 14 | 15 | mbasemlcore := 'nop'; 16 | 17 | define cslist := 18 | {a:head b cslist:tail => $cons(head,tail)} 19 | / {a:head => $wrap(head)}; 20 | 21 | define slist := {a:head slist:tail => $cons(head,tail)} 22 | / {a:head => $wrap(head)}; 23 | 24 | NEWLINE := 10; 25 | CR := 13; 26 | TAB := 9; 27 | QUOTE := 0x27; 28 | token tQUOTE := 0x27; 29 | 30 | LCLetter := [a-z]; 31 | UCLetter := [A-Z]; 32 | Letter := [a-z]/[A-Z]; 33 | Digit := [0-9]; 34 | Digits := Digit+; 35 | Space := ' ' / TAB / CR / NEWLINE / SingleLineComment / MultiLineComment; 36 | Spaces := Space+; 37 | 38 | MultiLineComment := '(*' ((!('*)')) . )* '*)' => {state=comment}; 39 | SingleLineComment := '//' (!(NEWLINE) .)* NEWLINE => {state=comment}; 40 | 41 | KeywordI := 'let'/'rec'/'in'/'match'/'with'/'function'/'type'/'and'/'true'/ 42 | 'false'/'as'/'of'/ 43 | 'fun'/'foreign'/'begin'/'end'/'lisp'/'include'/'val'/ 44 | 'if'/'then'/'else'/'export'/'lazy'; 45 | 46 | Keyword := KeywordI !(IdentRest) ; 47 | 48 | iIdent := LCLetter (IdentRest *) ; 49 | IdentRest := (Letter / Digit / '_') ; 50 | 51 | token Ident := !(Keyword) iIdent => {ctoken = ident} ; 52 | token CapIdent := UCLetter IdentRest* => {ctoken = keyword} ; 53 | infixInner := (Letter / Digit / '@'/'$'/'#'/'?'/'_'/'-'/ 54 | '+'/'!'/'.'/','/ 55 | '/'/'%'/'&'/'|'/'='); 56 | token InfixIdent := ('<' infixInner * '>') => {ctoken = ident} ; 57 | term tInfixIdent := {InfixIdent:i => $sval(i)} 58 | / {"`" Ident:i "`" => $sval(i) } 59 | / {Ident:i check(ml_check_infix) => $sval(i)}; 60 | 61 | token Char := 39 . 39 => {ctoken = const} ; 62 | token String := '"' ( !'"' . ) * '"' => {ctoken = const} ; 63 | token Int := '-'? Digits => {ctoken = const} ; 64 | ) 65 | 66 | 67 | -------------------------------------------------------------------------------- /src/l/core/list.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;;; Basic list comprehensions implementation 11 | 12 | (Section "List comprehensions") 13 | 14 | (function lch:tknize ( right ) 15 | (foreach-map (r right) 16 | (cond 17 | ((symbol? r) 18 | (case r 19 | ((<- & |) `(,r)) 20 | (else `(VAR ,r)))) 21 | (else `(OTHER ,r))))) 22 | 23 | 24 | (bnf-parser 25 | ((comprexpr lch:parse-compr)) 26 | 27 | (comprexpr 28 | ((expr:e | rightexpr:r) `(lch:list-comprehension ,e (generators ,@r)))) 29 | 30 | (expr 31 | ((VAR) $0) 32 | ((OTHER) $0)) 33 | 34 | (rightexpr 35 | ((rightsome:l | rightexpr:r) (cons l r)) 36 | ((rightsome) (list $0))) 37 | 38 | (rightgena 39 | ((expr:v <- expr:e) `(<- ,v ,e))) 40 | 41 | (rightsome 42 | ((rightgena:l & rightexprs:r) `(with ,l ,@r)) 43 | ((rightgena) $0)) 44 | (rightexprs 45 | ((expr:l & rightexprs:r) (cons l r)) 46 | ((expr) (wrap $0))) 47 | 48 | ) 49 | 50 | (function lch:parse ( expr ) 51 | (car ((lch:parse-compr nil) (lch:tknize expr)))) 52 | 53 | (macro lch:list-comprehension ( inner-expr generators ) 54 | (let loop (( v (cdr generators ))) 55 | (p:match v 56 | (() inner-expr) 57 | (((<- $vr $e) . $cdrv) 58 | (let ((nvr (if (list? vr) (gensym) vr))) 59 | `(,(if (null? cdrv) 'foreach-map 'foreach-mappend) (,nvr ,e) 60 | ,(if (list? vr) `(format ,nvr ,vr ,(loop cdrv)) (loop cdrv))))) 61 | (((with ($_ $vr $e) . $qery) . $cdrv) 62 | `(,(if (null? cdrv) 'foreach-map-filter 'foreach-mappend-filter) 63 | (,vr ,e) (and ,@qery) 64 | ,(loop cdrv) 65 | ))))) 66 | 67 | (macro rest 68 | ( 69 | "A list comprehensions macro." 70 | "" 71 | "Format: [[( generator-expression | source-sets*)]]" 72 | "" 73 | "Usage example:" 74 | "[[" 75 | " ( (cons x y) | x <- '(a b) | y <- '(a b) & (not (eqv? x y)))" 76 | "]]" 77 | ) 78 | (lch:parse rest)) 79 | 80 | (macro list-comprehension rest 81 | (lch:parse rest)) 82 | 83 | -------------------------------------------------------------------------------- /src/l/lib/pfront/parser.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (function peg-function-sccval (s) 12 | (list->symbol (cdr (string->list (cdr s))))) 13 | 14 | (function peg-makerfunction-invokeparser (pr) 15 | (alet res 16 | (p:match pr 17 | ((parser $p $e) 18 | (alet c (shashget (getfuncenv) (Sm<< "peg_" p "_Context")) 19 | (if c (car (ohashget c e)) nil))) 20 | (else nil)) 21 | (if res res 22 | (fun (env _lrstk source) 23 | (peg-fail))))) 24 | 25 | (function peg-function-fixpattern (s) 26 | (p:match s 27 | ((binding $i) `(var ,i)) 28 | ((mdbinding $i) i) 29 | (else `(ptn ,s)))) 30 | 31 | 32 | (define pf__dllglobcache (mkhash)) 33 | (define pf_checkdll_external (mkref nil)) 34 | 35 | (function peg-function-pfcheckdll (nm) 36 | (let* ((c0 (deref pf_checkdll_external))) 37 | (if (not c0) 38 | (alet chk (hashget pf__dllglobcache nm) 39 | (if chk nil 40 | (try 41 | (begin 42 | (read-compile-eval `(usedll ,(Sm<< nm))) 43 | (hashput pf__dllglobcache nm nm)) 44 | t_Exception 45 | (fun (e) nil))) 46 | `(pldllref ,nm) 47 | ) 48 | (c0 nm)))) 49 | 50 | (function peg-function-pfchecksysdll (nm) 51 | (alet chk (hashget pf__dllglobcache nm) 52 | (if chk nil 53 | (try 54 | (begin 55 | (read-compile-eval `(sysdll ,(Sm<< nm))) 56 | (hashput pf__dllglobcache nm nm)) 57 | t_Exception 58 | (fun (e) nil))) 59 | `(pldllref ,nm) 60 | )) 61 | 62 | (packrat-file "./pcommon.peg") 63 | (packrat-file "./minipeg.peg") 64 | 65 | ;(debugmacro 'peg-constr-compile) 66 | ;(force-class-flush) 67 | ;(ctimex (define debug-compiler-postlift #t)) 68 | ;(force-class-flush) 69 | 70 | (packrat-file "./pfront.peg") 71 | 72 | (packrat-file "./pliter.peg") 73 | 74 | 75 | 76 | 77 | -------------------------------------------------------------------------------- /src/l/core/parsing_chars.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ; 11 | ; Support for a generalised "characters" for parsing. 12 | ; 13 | 14 | (define *gen-marker* (string->symbol " *g* ")) 15 | 16 | (function gen? (x) 17 | (and 18 | (list? x) 19 | (not (null? (car x))) 20 | (eqv? (car x) *gen-marker*))) 21 | 22 | (function mkgen (v p) 23 | (cons *gen-marker* (cons v p))) 24 | 25 | (function genvalue (v) 26 | (if (gen? v) (cadr v) v)) 27 | 28 | (function genposition (v) 29 | (if (gen? v) (cddr v) nil)) 30 | 31 | (function genchar? (x) 32 | (if (char? x) #t 33 | (if (and 34 | (gen? x) 35 | (char? (cadr x))) 36 | #t 37 | nil))) 38 | 39 | (function genchar (x) 40 | (genvalue x)) 41 | 42 | (function genascii (x) 43 | (ascii (genvalue x))) 44 | 45 | (function genchar=? (cha b) 46 | (eq? (ascii cha) (genascii b))) 47 | 48 | (function genachar=? (chasc b) 49 | (= chasc (genascii b))) 50 | 51 | (function lazylasttail (lz) 52 | (let loop ((lst lz)) 53 | (if (null? lst) nil 54 | (let ((cl (cdr lst))) 55 | (if (null? (cdr lst)) 56 | lst 57 | (if (list? (cdr lst)) 58 | (loop (cdr lst)) 59 | (loop (cl)) 60 | )))))) 61 | 62 | (function rangeposition (lst) 63 | (if (null? lst) nil 64 | (let ((l0 (genposition (car lst)))) 65 | (if l0 66 | (let* ((ll (lazylasttail lst)) 67 | (l1 (if ll (genposition (car ll)) (list -1 -1)))) 68 | `(RANGE ,l0 ,l1)) 69 | nil)))) 70 | 71 | (function genlist->string (lst) 72 | (if (null? lst) "" 73 | (let* ((pos (rangeposition lst)) 74 | (s 75 | (list->string (map genchar lst)))) 76 | (if pos (mkgen s pos) s)))) 77 | 78 | (function genapply (f v) 79 | (if (gen? v) 80 | (mkgen (f (genvalue v)) (genposition v)) 81 | (f v))) 82 | 83 | (function genlist->symbol (lst) 84 | (genapply string->symbol (genlist->string lst))) 85 | 86 | (function sgenlist->string (lst) 87 | (list->string (map genchar lst))) 88 | 89 | (function sgenlist->symbol (lst) 90 | (string->symbol (sgenlist->string lst))) 91 | 92 | -------------------------------------------------------------------------------- /src/l/core/utils.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (macro alet (name value . body) 11 | ("Arc--style {\\tt let} construction") 12 | `(let ((,name ,value)) ,@body)) 13 | 14 | (unit-test 2 (alet x 2 (* x x)) 4) 15 | 16 | (function map-pairs (fn lst) 17 | (let loop ((l lst)) 18 | (p:match l 19 | (($a $b . $rest) (cons (fn a b) (loop rest))) 20 | (() nil) 21 | (else nil)))) 22 | 23 | (unit-test 2 (map-pairs + '(1 2 3 4)) (3 7)) 24 | 25 | (macro awith (namevalues . body) 26 | ("Arc--style {\tt with} construction") 27 | `(let ,(map-pairs (fun (a b) (list a b)) namevalues) ,@body)) 28 | 29 | (unit-test 2 (awith (a 2 b 4 c +) (c a b)) 6) 30 | 31 | 32 | (macro aif body 33 | ("Arc--style {\tt if} construction") 34 | (p:match body 35 | (($a $b) `(if ,a ,b nil)) 36 | (($a $b $c) `(if ,a ,b ,c)) 37 | (($a $b $c . $rest) 38 | `(if ,a ,b (aif ,c ,@rest))))) 39 | 40 | (unit-test 2 (aif nil 1 nil 2 #t 3) 3) 41 | 42 | (macro pipeline> body 43 | ("Makes a pipeline of one argument functions") 44 | `(M@ ,@(reverse body))) 45 | 46 | (unit-test 2 (alet inc (fun (x) (+ x 1)) ((pipeline> inc inc inc) 3)) 6) 47 | 48 | (macro mapn (fn . lsts) 49 | (let* ((nms (map (fun (x) (cons x (gensym))) lsts)) 50 | (len (length lsts)) 51 | (nnms (map cdr nms)) 52 | (inits (foreach-map (n nms) 53 | `(,(cdr n) (noconst (cons ,(car n) nil))))) 54 | (ars (foreach-map (n nnms) 55 | `(caar ,n))) 56 | (updats (foreach-map (n nnms) 57 | `(set-car! ,n (cdr (car ,n))))) 58 | (loopn (gensym)) (resn (gensym)) (rresn (gensym)) 59 | (tmpn (gensym)) (fnn (if (symbol? fn) fn (gensym))) 60 | ) 61 | `(let* ((,resn (noconst (cons nil (cons nil nil)))) 62 | (,rresn (noconst (cdr ,resn))) 63 | ,@(if (symbol? fn) nil `((,fnn ,fn))) 64 | ,@inits) 65 | (let ,loopn () 66 | (let ((,tmpn (cons (,fnn ,@ars) nil))) 67 | (set-cdr! (cdr ,resn) ,tmpn) 68 | (set-cdr! ,resn ,tmpn) 69 | ,@updats 70 | (if (or ,@(foreach-map (n nnms) 71 | `(null? (car ,n)))) 72 | (cdr ,rresn) 73 | (,loopn))))))) 74 | 75 | (unit-test 2 (mapn + '(1 2 3) '(3 2 1)) (4 4 4)) -------------------------------------------------------------------------------- /src/l/core/final.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | 12 | (function *the-init* () ;; delayed default module initialization 13 | (read-int-eval '(n.module Default)) 14 | nil) 15 | 16 | (define *toplevel-module-initp?* (mkref)) 17 | 18 | (function read-compile-eval (lst) 19 | ("Redefinition of [(read-compile-eval ...)], now it is a compiler's frontend." 20 | "It should not normally be used from the user's code, but serves as a default callback for" 21 | "wrappers." 22 | ) 23 | (when (not (car *toplevel-module-initp?*)) 24 | (read-int-eval '(n.module mbase_default_toplevel)) 25 | ) 26 | (let* ((env (shashget (getfuncenv) '*current-cc-env*))) 27 | (cc:toplevel-devour env lst))) 28 | 29 | (function read-compile-eval-t (lst) 30 | (when (not (car *toplevel-module-initp?*)) 31 | (read-int-eval '(n.module mbase_default_toplevel)) 32 | ) 33 | (let* ((env (shashget (getfuncenv) '*current-cc-env*))) 34 | (cc:toplevel-devour-transparent env lst))) 35 | 36 | (macro n.module (name . r) 37 | ("Defines a module with a given {\tt name} and type. Default type is dll," 38 | "other types available are: exe, winexe.") 39 | (let* ((env (alet tst (shashget (getfuncenv) '*current-cc-env*) 40 | (if tst tst (cc:newenv)))) 41 | (sver (shashget (getfuncenv) 'assembly-version)) 42 | (kfile (shashget (getfuncenv) 'assembly-keyfile))) 43 | (set-car! *toplevel-module-initp?* #t) 44 | (cc:env:defmodule:strong env (S<< name) (if r (car r) 'dll) sver kfile) 45 | (shashput (getfuncenv) '*current-cc-env* env) 46 | (add-assembly-inner (env:get: env dotnet-assembly)) 47 | (flush-target-dependencies) 48 | `(top-begin ))) 49 | 50 | (function n.save.f () 51 | (cc:dump-module (shashget (getfuncenv) '*current-cc-env*))) 52 | 53 | (macro n.save () 54 | ("Save the current module to an exe or dll file.") 55 | `(late-ctime (begin (n.save.f) '(top-begin)))) 56 | 57 | (macro n.report () 58 | ("Print a compiler statistics for the current module to the standard output.") 59 | `(late-ctime 60 | (begin 61 | (cc:env:printreport 62 | (cc:env:report 63 | (shashget (getfuncenv) '*current-cc-env*))) 64 | '(top-begin) 65 | ))) 66 | 67 | (function net.env.get (nm) 68 | (cc:extract-method (shashget (getfuncenv) '*current-cc-env*) nm)) 69 | 70 | (function net.current-module () 71 | (alet env (shashget (getfuncenv) '*current-cc-env*) 72 | (cc:env:getmodule env))) 73 | -------------------------------------------------------------------------------- /src/l/ext/tcprepl.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | (using ("System.Net.Sockets" "System.IO" "System") 10 | (module tcprepl 11 | (using threads) 12 | (export spawn-mbase-repl tcprepl) 13 | 14 | 15 | (not.function tcplistener ((int port)) 16 | (return (new System.Net.Sockets.TcpListener port))) 17 | 18 | (not.function tcpwaiter ((System.Net.Sockets.TcpListener l) (object proc)) 19 | (l@Start) ;; start listening 20 | (while true ;; loop endlessly 21 | (client = (l@AcceptTcpClient)) 22 | (mbase proc client) 23 | ) 24 | (l@Stop) 25 | (return null) ; never comes here 26 | ) 27 | 28 | (not.function tcpgetstream ((System.Net.Sockets.TcpClient c)) 29 | (return (c@GetStream))) 30 | 31 | (define treadline (r_tbind "System.IO.TextReader" "ReadLine")) 32 | 33 | (function tprintln ( a b ) 34 | ((r_tbind "System.IO.TextWriter" "WriteLine" string) a b) 35 | ((r_tbind "System.IO.TextWriter" "Flush") a)) 36 | 37 | (function tprint ( a b ) 38 | ((r_tbind "System.IO.TextWriter" "Write" string) a b) 39 | ((r_tbind "System.IO.TextWriter" "Flush") a)) 40 | 41 | (recfunction tcprepl (fi fo) 42 | (try 43 | (let loop () 44 | (print ">>") 45 | (let* ((rdr (fun () (let ((res (treadline fi))) 46 | (if (string=? res "#quit") 47 | nil 48 | res)))) 49 | (a0x (mbase-parse-repl rdr (fun () (tprint fo "%> "))))) 50 | (if a0x 51 | (let ((v (read-compile-eval a0x))) 52 | (tprintln fo (S<< "<< " 53 | (to-string v))) 54 | (loop) 55 | )))) 56 | t_MBaseException 57 | (fun (ex) 58 | (writeline (mbaseerror ex)) 59 | (tcprepl fi fo) 60 | ) 61 | )) 62 | 63 | (function tcpreplproc (client) 64 | (let ((bld *BUILD*) (replfun tcprepl)) 65 | (not.neth ((System.Net.Sockets.TcpClient client) 66 | (string bld) (object replfun)) 67 | (sre = (client@GetStream)) 68 | (sr = (new System.IO.StreamReader ((System.IO.Stream)sre))) 69 | (sw = (new System.IO.StreamWriter ((System.IO.Stream)sre))) 70 | (Runtime@setConsole ((System.IO.TextWriter)sw)) 71 | (sw@WriteLine bld) 72 | (mbase replfun sr sw) 73 | (client@Close) 74 | (leave null) 75 | )) 76 | ) 77 | 78 | (function spawn-mbase-repl (port) 79 | (let* ((t (thr:mkthread (fun () 80 | (tcpwaiter (tcplistener port) tcpreplproc))))) 81 | (thr:start t))) 82 | 83 | 84 | 85 | ) 86 | 87 | ) -------------------------------------------------------------------------------- /src/l/lib/pfront/pliter.peg: -------------------------------------------------------------------------------- 1 | ////////////////////////////////////////////////////////////////////////////// 2 | // 3 | // OpenMBase 4 | // 5 | // Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | // 7 | // 8 | ////////////////////////////////////////////////////////////////////////////// 9 | 10 | .peg: 11 | 12 | parser pliter extends pfront ( 13 | 14 | term TSpace := ' ' / TAB / CR / NEWLINE; 15 | 16 | token bslash := '\' => { state = empty }; 17 | token pltbeg1 := 'pfcode' TSpace* '{' TSpace* => { state = empty}; 18 | token pltbeg2 := 'pfqode' TSpace* '{' TSpace* => { state = empty}; 19 | token pltbeg2a := 'pfiqode' TSpace* '{' TSpace* => { state = empty}; 20 | token pltbeg3 := 'ppcode' TSpace* '{' TSpace* => { state = empty}; 21 | token pltbeg1x := 'phcode' TSpace* '{' TSpace* => { state = empty}; 22 | token pltdll := 'pfdllref' TSpace* '{' TSpace* => { state = empty}; 23 | token pltsysdll := 'pfsysdllref' TSpace* '{' TSpace* => { state = empty}; 24 | token plinclude := 'pfinclude' TSpace* '{' TSpace* => { state = empty }; 25 | token pltend := Space* '}' => {state = empty}; 26 | 27 | term pltbeg4 := 'parse' '[' ident:p ':' ident:e ']' TSpace* '{' TSpace* => {state = empty} [[parser]](p,e) ; 28 | 29 | term pltmetabegin := 'pfdemo' '{' expr:v '}' '[' ident:p ':' ident:e ']' 30 | => {uberstate = empty} [[pfdemo]](v,p,e); 31 | 32 | term pltsimplemeta := 'pfout' '{' expr:v '}' 33 | => {uberstate = empty} v; 34 | 35 | 36 | term pliter := texexpr / pltopexpr0 ; 37 | 38 | term plminipeg := (mininode / miniexpr / miniastx) ';'?; 39 | 40 | term pltopexpr0 := bslash pltopexpr:e => e; 41 | 42 | term pltopexpr "Embedded code" := 43 | {pltbeg1 slist:e pltend => pltopexpr(e)} 44 | / {plinclude string:s pltend => plinclude(s)} 45 | / {pltbeg2a slist:e pltend => pliqexpr(e)} 46 | / {pltbeg2 slist:e pltend => plqexpr(e)} 47 | / {pltbeg3 slist:e pltend => plqexpr(e)} 48 | / {pltbeg1x slist:e pltend => { uberstate = empty } plqhexpr(e)} 49 | / {pltsysdll string:s pltend => { uberstate = empty } $pfchecksysdll(s) } 50 | / {pltdll string:s pltend => { uberstate = empty } $pfcheckdll(s) } 51 | / {pltbeg4:pars #invokeparser:e pltend => plqexpr(e)} 52 | / {pltmetabegin:meta => plqmetaexpr(meta)} 53 | / {pltsimplemeta:meta => plmetaexpr(meta)} 54 | ; 55 | 56 | nottex := !('\pfcode'/'\pfqode'/'\pfiqode'/'\ppcode'/'\phcode'/'\parse'/'\pfdllref'/'\pfsysdllref' 57 | /'\pfdemo'/'\pfout'/'\pfinclude') .; 58 | 59 | token tex := nottex +; 60 | term texexpr := tex:v => {screen=none} {state=texcomment} pltexstring($val(v)); 61 | ) 62 | 63 | -------------------------------------------------------------------------------- /src/l/ext/nrecord.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (function __getnm (f) 12 | (p:match f (($tp $nm) nm) (else f))) 13 | 14 | (function __gettp (f) 15 | (p:match f (($tp $nm) tp) (else 'object))) 16 | 17 | (function nrec.makeacc (REC nm fld) 18 | (with-syms (nREC) 19 | `(let ((,nREC ,REC)) 20 | (not.neth ((,nm ,nREC)) 21 | (leave ((object)(,nREC # ,fld))))))) 22 | 23 | (macro nrec:def (nm . fields) 24 | ( 25 | "Defines a record type [nm] with a list of [fields]." 26 | "To create a new record instance, use the constructor function" 27 | "([nm].new []*)), to get field value, use ([nm].[field] [])," 28 | "Or, alternatively: ([nm].make [: ] ...)" 29 | "to set field value, use ([nm].[field]! [] [])." 30 | ) 31 | (with-syms (val) 32 | `(top-begin 33 | (not.class ,nm (extends System.Object) 34 | ,@(foreach-map (f fields) 35 | (p:match f 36 | (($tp $nm) `(field ,tp ,nm (public))) 37 | ($$M `(field object ,f (public))) 38 | (else (ccerror `(nrec:def-field ,f)))))) 39 | 40 | (not.function ,(string->symbol (S<< nm ".new")) 41 | ,(foreach-map (f fields) 42 | (if (list? f) f `(object ,f))) 43 | (,val = (new ,nm)) 44 | ,@(foreach-map (f fields) 45 | (alet n (__getnm f) 46 | `((,val # ,n) <- ,n))) 47 | (return ((object) ,val))) 48 | 49 | (macro ,(string->symbol (S<< nm ".make")) macroarg 50 | (list 'extra:with-optional-args macroarg 51 | (quote ,(map __getnm fields)) 52 | (quote (,(Sm<< nm ".new") ,@(map __getnm fields))))) 53 | 54 | ,@(foreach-map (f fields) 55 | `(begin 56 | (function ,(string->symbol (S<< nm "." (__getnm f))) 57 | (REC) 58 | (not.neth ((,nm REC)) 59 | (leave ((object)(REC # ,(__getnm f)))))) 60 | (macro ,(string->symbol (S<< nm "." (__getnm f) ".M")) 61 | (REC) 62 | (nrec.makeacc REC (quote ,nm) (quote ,(__getnm f)))))) 63 | 64 | (function ,(Sm<< nm ".copy") (rc) 65 | (,(Sm<< nm ".new") ,@(foreach-map (f fields) 66 | `(,(Sm<< nm "." (__getnm f)) rc)))) 67 | 68 | ,@(foreach-map (f fields) 69 | `(function ,(string->symbol (S<< nm "." (__getnm f) "!")) 70 | (REC VAL) 71 | (not.neth ((,nm REC) (,(__gettp f) VAL)) 72 | (REC # ,(__getnm f) <- VAL) 73 | (leave null)))) 74 | )) 75 | ) -------------------------------------------------------------------------------- /src/l/core/envhandling.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (macro env:makenew () 11 | '(mkhash)) 12 | 13 | (macro env:getpath_: (env path) 14 | `(hashget ,env ,path)) 15 | 16 | (macro env:setpath_: (env path vlu) 17 | `(hashput ,env ,path ,vlu)) 18 | 19 | (function _env:makepath_: (pth) 20 | (p:match pth 21 | ($$M:v (S<< v)) 22 | (($$M:i . $rest) 23 | (to-string (cons (S<< i) rest))))) 24 | 25 | (macro env:makepath_: (pth) 26 | (p:match pth 27 | ($$M:v (S<< v)) 28 | (($$M:i . $rest) 29 | `(to-string (list ,(S<< i) ,@rest))))) 30 | 31 | (macro env:unroll_: envpath 32 | (p:match envpath 33 | ($$M:m m) 34 | (($hd . $tl) 35 | (let loop ((e envpath)) 36 | (p:match e 37 | (($$M:a $$M:b) `(env:getpath_: ,a ,(_env:makepath_: b))) 38 | (($hd . $tl) 39 | `(env:getpath_: ,(loop (cuttail e)) 40 | ,(env:makepath_: ,(car (lasttail e)))))))))) 41 | 42 | (macro env:update_: (env val) 43 | (p:match val 44 | ((:gen $lst) 45 | (with-syms (ss sd) 46 | `(let ((,ss ,lst)) 47 | (foreach (,sd ,ss) 48 | (env:setpath_: ,env (_env:makepath_: (car ,sd)) (cadr ,sd)))))) 49 | (($p $rest) `(env:setpath_: ,env (env:makepath_: ,p) ,rest)))) 50 | 51 | (macro env:check: (e . body) 52 | (format e (env path) 53 | (with-syms (s pth xx ee) 54 | `(let* ((,ee (env:unroll_: ,@env)) 55 | (,pth (env:makepath_: ,path)) 56 | (,s (env:getpath_: ,ee ,pth))) 57 | (if ,s ,s 58 | (let ((,xx (begin ,@body))) 59 | (env:setpath_: ,ee ,pth ,xx) 60 | ,xx)))))) 61 | 62 | (macro env:set: (env . vals) 63 | (with-syms (e) 64 | `(let ((,e (env:unroll_: ,@env))) 65 | ,@(foreach-map (v vals) 66 | `(env:update_: ,e ,v)) 67 | ,e 68 | ))) 69 | 70 | (macro env:get: (env path) 71 | (with-syms (e) 72 | `(let ((,e (env:unroll_: ,@env))) 73 | (env:getpath_: ,e (env:makepath_: ,path))))) 74 | 75 | (macro env:new: vals 76 | (with-syms (e) 77 | `(let ((,e (env:makenew))) 78 | ,@(foreach-map (v vals) 79 | `(env:update_: ,e ,v)) 80 | ,e 81 | ))) 82 | 83 | (macro env:collect: (env path val) 84 | (with-syms (e pth) 85 | `(let* ((,e (env:unroll_: ,@env)) 86 | (,pth (env:makepath_: ,path))) 87 | (env:setpath_: ,e ,pth (noconst (cons ,val (env:getpath_: ,e ,pth))))))) 88 | 89 | (macro env:inc: (env name) 90 | (with-syms (s1 s2) 91 | `(let* ((,s1 (env:get: ,env ,name)) 92 | (,s2 (if ,s1 (+ ,s1 1) 0))) 93 | (env:set: ,env (,name ,s2)) 94 | ,s2))) 95 | 96 | 97 | 98 | 99 | -------------------------------------------------------------------------------- /src/l/core/netlib_fields.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (define r_getFields (r_tbind "System.Type" "GetFields")) 12 | (define r_getField (r_tbind "System.Type" "GetField" string)) 13 | (define r_GetType (r_tbind "System.Object" "GetType")) 14 | (define r_FI-GetValue (r_tbind "System.Reflection.FieldInfo" "GetValue" object)) 15 | 16 | (define r_FI-SetValue (r_tbind "System.Reflection.FieldInfo" "SetValue" object object)) 17 | 18 | (function type_array (tp) 19 | (r_GetType (anew tp 0))) 20 | 21 | (function r_GetTypeX (x) (if (null? x) t_object (r_GetType x))) 22 | (function -> (vl typ fld) 23 | "Gets the field of a given type of [vl]" 24 | (r_FI-GetValue (r_getField (r_typer typ) (any->string fld)) vl)) 25 | 26 | (function :-> (vl fld) 27 | "Get the field [fld] of the object [vl]." 28 | (r_FI-GetValue (r_getField (r_GetType vl) (any->string fld)) vl)) 29 | 30 | (function <- (vl typ fld val) 31 | "Set the field [fld] value of the object [vl] into [val], assuming the given [vl] type [typ]." 32 | (r_FI-SetValue (r_getField (r_typer typ) fld) vl val)) 33 | 34 | (function <-: (vl fld val) 35 | "Set the field [fld] value of the object [vl] into [val]. Type of [vl] is evaluated using [GetType]." 36 | (r_FI-SetValue (r_getField (r_GetType vl) fld) vl val)) 37 | 38 | (function s<-: (vl fld val) 39 | "Sets a property value." 40 | (let* ((t (r_GetType vl)) 41 | (b (r_bind t (string-append "set_" fld) (r_GetType val)))) 42 | (b vl val))) 43 | 44 | (function s-> (typ fld) 45 | "Get a static field value." 46 | (r_FI-GetValue (r_getField (r_typer typ) fld) nil)) 47 | 48 | (function /-> (vl fld) 49 | "Gets a value of the field [fld] of the object [vl]." 50 | (r_FI-GetValue (r_getField (r_GetType vl) fld) vl)) 51 | 52 | (function g-> (vl fld) 53 | "Gets a property value." 54 | (let* ((t (r_GetType vl)) 55 | (b (r_bind t (string-append "get_" fld)))) 56 | (b vl))) 57 | 58 | (function sg-> (t fld) 59 | "Gets a static property value" 60 | (let ((b (r_sbind t (string-append "get_" fld)))) 61 | (b))) 62 | 63 | (define _gt_constr (r_tbind t_type "GetConstructor" "System.Type[]")) 64 | 65 | (macro r_getconstructor (tp . args) 66 | `(let ((t (r_typer ,tp))) 67 | (_gt_constr t ,(if (null? args) `(anew t_type 0) `(vector ,@(map (fun (x) `(r_typer ,x)) args)))))) 68 | 69 | 70 | (function r_getconstructorf (tp args) 71 | (let* ((t (r_typerx tp)) 72 | (res (_gt_constr t (if (null? args) (anew t_type 0) (mkvector (map (fun (x) (r_typerx x)) args)))))) 73 | res)) 74 | 75 | (function instanceof (v t) 76 | (let ((tv (r_GetType v))) 77 | ((r_tbind "System.Type" "IsAssignableFrom" "System.Type") tv t))) 78 | 79 | 80 | -------------------------------------------------------------------------------- /misc/demos/calc.hl: -------------------------------------------------------------------------------- 1 | // AST definition 2 | ast calc{ 3 | expr = plus(expr:a, expr:b) 4 | | minus(expr:a, expr:b) 5 | | mult(expr:a, expr:b) 6 | | div(expr:a, expr:b) 7 | | let(ident:nm, expr:val, expr:body) 8 | | var(ident:nm) 9 | | const(number:v); 10 | } 11 | 12 | // Interpreter 13 | function calc_eval(ex) 14 | do loop(env=[], e=ex) 15 | visit:calc (expr:e) { 16 | once expr { 17 | let -> loop([nm;loop(env, val)]:env, body) 18 | | deep -> { 19 | plus -> %f+(a,b) 20 | | minus -> %f-(a,b) 21 | | mult -> %f*(a,b) 22 | | div -> %f/(a,b) 23 | | const -> v 24 | | var -> %lookup-env-car(env, nm) 25 | | else -> []}}} 26 | 27 | // Compiler 28 | function calc_compile(ex) 29 | visit:calc(expr: ex) { 30 | deep expr { 31 | const -> 'f#'(%->s(v)) 32 | | var -> nm 33 | | let -> 'alet'(nm, val, body) 34 | | plus -> 'f+'(a,b) 35 | | minus -> 'f-'(a,b) 36 | | mult -> 'f*'(a,b) 37 | | div -> 'f/'(a,b)}} 38 | 39 | function calc_compile_dotnet(ex) 40 | visit:calc(expr:ex) { 41 | deep expr { 42 | const -> ['Ldc_R8'(v)] 43 | | var -> ['Ldloc'('var'(nm))] 44 | | let -> ['local'(nm, t_Double); 45 | @val; 46 | 'Stloc'('var'(nm)); 47 | @body] 48 | | plus -> [@a;@b;'Add'()] 49 | | minus -> [@a;@b;'Sub'()] 50 | | mult -> [@a;@b;'Mul'()] 51 | | div -> [@a;@b;'Div'()]}} 52 | 53 | // PEG parser 54 | function %peg-function-fval (v) 55 | %flt:parse(cdr(v)) 56 | 57 | parser calc (pfront) { 58 | !!Spaces; 59 | calc := [calc0]:c [Spaces]* => c; 60 | binary calc0 := 61 | (200) [calc0] "*" [calc0] => mult(L,R) 62 | | (200) [calc0] "/" [calc0] => div(L,R) 63 | | (100) [calc0] "+" [calc0] => plus(L,R) 64 | | (100) [calc0] "-" [calc0] => minus(L,R) 65 | | [atom] 66 | ; 67 | atom := { "(" [expr]:e ")" => e } 68 | / { let [ident]:nm "=" [calc]:v in [calc]:body 69 | => let(nm, v, body) } 70 | / { [ident]:nm => var(nm) } 71 | / { [double]:v => const(v) } 72 | ; 73 | 74 | double := [tkdouble]:v => $fval(v); 75 | @tkdouble := ("-"/"+")? [Digit]+ 76 | ("." [Digit]+)?; 77 | } 78 | 79 | // Interpreted version: 80 | writeline(calc_eval(parse "let x = 2 in 2*2+x*3" as calc)) 81 | 82 | // Compiled version, wrapped into a syntax extension: 83 | syntax in expr, start (calc): ' "calc:" [calc]:c ' 84 | { 85 | return 'lisp'(calc_compile(c)) 86 | } 87 | 88 | // Compiled version, wrapped into a syntax extension: 89 | syntax in expr, start (calc): ' "calcnet:" [calc]:c ' 90 | { 91 | return 'lisp'('n.asm'([],@calc_compile_dotnet(c),'Box'(t_Double))) 92 | } 93 | 94 | ------------- 95 | 96 | writeline(calc: let x = 2 in 2*2+x*3) 97 | println("=======") 98 | writeline(calcnet: let x = 2 in 2*2+x*3) 99 | -------------------------------------------------------------------------------- /src/l/boot/stage5.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (_Clean_Deps) 11 | (include "../version.al") 12 | (include "../options.al") 13 | 14 | (ctimex (println "Bootstrap stage: 5 - final")) 15 | (ctimex (define debug-display-include-paths #t)) 16 | ;;(ctimex (define debug-compiler-prelift #t)) 17 | ;;(ctimex (define debug-compiler-dotnet #t)) 18 | 19 | (define ENV (cc:newenv)) 20 | (cc:env:defmodule:strong ENV "MBaseBin" 'dll assembly-version assembly-keyfile) 21 | 22 | (include "../core/asmlib_build.al") 23 | (asmlib:build (env:get: ENV dotnet-assembly) 24 | (env:get: ENV dotnet-module) 25 | "MBaseBin." 26 | ) 27 | 28 | (define stage5-assembly (env:get: ENV dotnet-assembly)) 29 | (add-assembly-inner stage5-assembly) 30 | 31 | (define generic_pfx "MBaseBin.") 32 | (include "../core/asmlib_load.al") 33 | 34 | (set-car! m_Call_Generic m_Call_Generic_00) 35 | 36 | (set-car! ms_Call_Generics ms_Call_Generics_00) 37 | 38 | (set-car! ms_Call_RevGenerics ms_Call_RevGenerics_00) 39 | 40 | (define asmlib-final #t) 41 | (define compiled-environment #t) 42 | (set-cdr! (shashget (getfuncenv) '*gensym-counter-storage*) 43 | 1) 44 | (define *current-cc-env* ENV) 45 | (define stage-final #t) 46 | 47 | (unit-tests-use) 48 | 49 | (begin 50 | (cc:toplevel-devour ENV '(top-begin 51 | (define compiler-final #t) 52 | (define compiled-environment #t) 53 | (define core-environment-compiled #t) 54 | (include "../boot/boot.al") 55 | (include "../boot/initlib.al") 56 | (include "../boot/dotnetlib.al") 57 | (include "../boot/common.al") 58 | 59 | ;;;;; 60 | 61 | (include "../core/compiler.al") 62 | (include "../core/unit.al") 63 | (include "../core/final.al") 64 | (include "../boot/extra.al") 65 | (include "../core/clibsystem.al") 66 | (include "../ext/tcprepl.al") 67 | (include "../core/native.al") 68 | (include "../ext/unittests.al") 69 | 70 | ;; Things needed to run pfront programs 71 | (include "../lib/pfront/backport.al") 72 | 73 | )) 74 | (cc:env:printreport (cc:env:report ENV)) 75 | (cc:dump-module ENV) 76 | ) 77 | 78 | (doc.defaults) 79 | (doc.files (def "../doc/clib.tex")) 80 | (doc.flush) 81 | 82 | (unit-tests-dump (1 "../src/l/tests/level1/auto.al") 83 | (2 "../src/l/tests/level2/auto.al") 84 | (3 "../src/l/tests/level3/auto.al")) -------------------------------------------------------------------------------- /src/l/ext/texprint.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;; TeX pretty printer to be used with the vsparser thing 11 | 12 | 13 | (define wwTabsX 14 | (strreplacers* 15 | (">" "$>$") 16 | ("<" "$<$") 17 | ("{" "{$\\{$}") 18 | ("}" "{$\\}$}") 19 | ("(" "\\lsplp{}") 20 | (")" "\\lsprp{}") 21 | ("&" "\\&") 22 | ("%" "\\%") 23 | ("_" "\\_") 24 | ("^" "{$\\hat{~}$}") 25 | ("$" "\\$") 26 | ("#" "\\#") 27 | (" " "\\lspspc{}") 28 | ("\n" "~\\\\\n") 29 | ("\\" "{$\\backslash$}") 30 | ("\t" "\\lspspc{}\\lspspc{}\\lspspc{}\\lspspc{}\\lspspc{}\\lspspc{}\\lspspc{}\\lspspc{}"))) 31 | 32 | 33 | (function wwTabs (str) 34 | (strapply* wwTabsX str)) 35 | 36 | 37 | (function print-end () 38 | (print "}") 39 | ) 40 | 41 | (function print-begin (prules c) 42 | (print (S<< "{" (prules c)))) 43 | 44 | (function print-endline () 45 | (println "{}~\\\\")) 46 | 47 | (function nstring=? (a b) 48 | (let ((na (null? a)) 49 | (nb (null? b))) 50 | (cond 51 | ((and na nb) #t) 52 | ((and (not na) (not nb)) 53 | (string=? a b)) 54 | (else nil)))) 55 | 56 | (function state-comp (s1 s2) 57 | (cond 58 | ((null? s1) nil) 59 | ((null? s2) nil) 60 | (else 61 | (format s1 (_ _ fg1 bg1) 62 | (format s2 (_ _ fg2 bg2) 63 | (and (nstring=? fg1 fg2) 64 | (nstring=? bg1 bg2))))))) 65 | 66 | (function pprint-buffer (lexer parser rules prules lines) 67 | (let* ((v (mkovector lines)) 68 | (bpars (lex-and-parse lexer parser 69 | (lazy_strs_reader 70 | v))) 71 | (nl (alength v)) 72 | (cac (rules bpars))) 73 | (let gloop ((l 0) (stt nil)) 74 | (if (>= l nl) nil 75 | (let* ((ln ([ l ] v)) 76 | (stn 77 | (let loop ((i 0) (s (string->list ln)) (st stt)) 78 | (alet c (bnf-chkcache cac i l) 79 | (if (null? s) (begin 80 | (if (not (null? st)) 81 | (print-end)) 82 | (print-endline) 83 | c) 84 | (begin 85 | (cond 86 | ((and c 87 | (not (state-comp st c))) 88 | (begin 89 | (if st (print-end)) 90 | (print-begin prules c))) 91 | ((and st (not c)) 92 | (print-end))) 93 | (print (wwTabs (S<< (car s)))) 94 | (loop (+ i 1) (cdr s) c))))))) 95 | 96 | (gloop (+ l 1) stn)))))) 97 | 98 | 99 | 100 | 101 | 102 | -------------------------------------------------------------------------------- /src/l/core/cc-tail.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \subsection{Simple tail recursion handling} 12 | ;- 13 | ;- This stage should be applied after the lambda lifting pass. 14 | ;- 15 | 16 | ;= Helper function: create names for argument shadowing variables 17 | (function cc:rename-args ( arglist expr ) 18 | (with-hash (ht) 19 | (foreach (a arglist) 20 | (ht! a (Sm<< a "_arg"))) 21 | (cc:mbcoreast:visit expr expr 22 | (expr DEEP 23 | ((Arg (alet tst (ht> id) 24 | (if tst `(Var ,tst) node))) 25 | (else node)))))) 26 | 27 | ;= Convert a simple tail recursive function into a loop, if it is possible. 28 | (function cc:convert-tail ( recname arglist expr ) 29 | (let* ((yesitis (mkref)) 30 | (res 31 | (let loop ((e0 expr)) 32 | (cc:mbcoreast:visit expr e0 33 | (expr _ 34 | ((If (ast:mknode (iftr (loop iftr)) 35 | (iffl (loop iffl)))) 36 | (TryBlock 37 | (ast:mknode (body (loop body)))) 38 | (Begin 39 | (ast:mknode (es (append 40 | (cuttail es) 41 | (list (loop (car (lasttail es)))))))) 42 | (SLet 43 | (ast:mknode (body (loop body)))) 44 | (SLetRec 45 | (ast:mknode (body (loop body)))) 46 | (App ;; The check itself 47 | (p:match fn 48 | (($$M:xx =recname) 49 | (case xx 50 | ((Glob Var Recref) 51 | (begin 52 | (set-car! yesitis #t) 53 | `(SLet ,(foreach-map (a (czip arglist args)) 54 | `(,(Sm<< (car a) "_arg_new") ,(cdr a))) 55 | (Begin 56 | ,@(foreach-map (a arglist args) 57 | `(XSet Var ,(Sm<< a "_arg") 58 | (Var ,(Sm<< a "_arg_new")))) 59 | (GotoLabel ,recname))))) 60 | (else node))) 61 | (else node))) 62 | (else node))))))) 63 | (if (car yesitis) 64 | `(SLet ,(foreach-map (a arglist) 65 | `(,(Sm<< a "_arg") (Arg ,a))) 66 | (Begin 67 | (Label ,recname) 68 | ,(cc:rename-args arglist res))) 69 | expr))) 70 | 71 | ;= Interface function: convert only functions, ignore other expression types. 72 | (function cc:convert-tail-helper ( name expr ) 73 | (p:match expr 74 | ((Fun $rn $args $body) 75 | `(Fun ,rn ,args ,(cc:convert-tail name (bootlib:filter-args args) body))) 76 | (else expr))) 77 | -------------------------------------------------------------------------------- /src/l/core/cc-expand.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (function cc:elaborate-exception (ex) 11 | (if (instanceof ex t_MBaseException) 12 | (mbaseerror ex) 13 | (->s ex))) 14 | 15 | (recfunction cc:expand:inner (expenv stk mcenv l) 16 | (let ((amcenv (cons *cmhash* mcenv)) 17 | (nstk (cons l stk))) 18 | (shashput (getfuncenv) '**cc-expand-stack** nstk) 19 | (cond 20 | ((null? l) l) 21 | ((symbol? l) 22 | (if (corelib:symbol-starts-with '## l) 23 | (let ((v (hashget-seq amcenv l))) (if v ((hashget-seq amcenv l)) 'nil)) 24 | l 25 | )) 26 | ((list? l) 27 | (let ((cl (car l))) 28 | (cond 29 | ((eqv? cl 'quote) l) 30 | ((eqv? cl 'unquote-spec) l) 31 | ((eqv? cl 'inner-expand-with) 32 | (let ((nenv (cons (cadr l) mcenv)) 33 | (code (caddr l))) 34 | (cc:expand:inner expenv nstk nenv code))) 35 | ((eqv? cl 'inner.lambda) 36 | `(inner.lambda ,(cadr l) 37 | ,@(map (lambda (ll) (cc:expand:inner expenv nstk amcenv ll)) (cddr l)))) 38 | ((eqv? cl 'inner.reclambda) 39 | `(inner.reclambda ,(cadr l) ,(caddr l) 40 | ,@(map (lambda (ll) (cc:expand:inner expenv nstk amcenv ll)) (cdddr l)))) 41 | ((eqv? cl 'inner.with-added-metadata) 42 | `(inner.with-added-metadata ,(cadr l) 43 | ,@(map (lambda (ll) (cc:expand:inner expenv nstk amcenv ll)) (cddr l)))) 44 | 45 | ((eqv? cl 'inner-expand-first) 46 | (cc:expand:inner expenv nstk mcenv 47 | (map (lambda (v) (cc:expand:inner expenv nstk mcenv v)) (cdr l)))) 48 | ((eqv? cl 'inner.debugpoint) 49 | (begin (ohashput expenv 'debugpoint (cdr l)) 50 | (return l))) 51 | (else 52 | (let ((sh (p:match cl 53 | ($$M (hashget-seq amcenv cl)) 54 | ((inner.identmetadata $id . $md) 55 | (let ((tmp (hashget-seq amcenv id))) 56 | (if tmp ((deref cc:process-variable-metadata) 57 | 'macro id md)) 58 | tmp)) 59 | (else nil)))) 60 | (if sh 61 | (try 62 | (let ((res (sh l))) 63 | (cc:expand:inner expenv nstk amcenv res)) 64 | t_Exception 65 | (lambda (x) 66 | (alet lastdbg (ohashget expenv 'debugpoint) 67 | (cc:comperror 68 | `(CC04:EXPANDING ,@(if lastdbg `((NEAR ,lastdbg))) ,(cc:elaborate-exception x) IN ,l)) 69 | )) 70 | ) 71 | (map (lambda (ll) (cc:expand:inner expenv nstk amcenv ll)) l) 72 | )))))) 73 | (else l)))) 74 | 75 | (function cc:expand (mcenv l) 76 | (cc:expand:inner (mkhash) nil mcenv l)) 77 | 78 | (function cc:defexpand (expr) 79 | (cc:expand (getmacroenv) expr)) -------------------------------------------------------------------------------- /src/l/lib/wam/prolog_backend_lib.hl: -------------------------------------------------------------------------------- 1 | \section{Prolog core library} 2 | 3 | \pfcode{ 4 | .prolog: { 5 | //Equality 6 | X=X. 7 | 8 | // Logic 9 | and(A,B) :- call(A), call(B). 10 | or(A,B) :- call(A). 11 | or(A,B) :- call(B). 12 | 13 | failwith(M, T) :- call(T). 14 | failwith(M, T) :- raise(M, T). 15 | 16 | // Lists 17 | append([],L,L). 18 | append([H|T],L,[H|A]) :- append(T,L,A). 19 | treclength([],N,N). 20 | treclength([H|T],L,N) :- isadd(NN,1,N), treclength(T,L,NN). 21 | length([],0). 22 | length([H|T], L) :- treclength(T,L,1). 23 | 24 | revert([], []). 25 | revert([H|L], R) :- revert(L, RL), append(RL,[H],R). 26 | 27 | // Infamous Prolog negation 28 | negate(X) :- call(X),!,fail. 29 | negate(X). 30 | // Sets (list-based) 31 | in(E, []) :- fail. 32 | in(E, [E|X]) :- !. 33 | in(E, [X|Y]) :- in(E,Y). 34 | 35 | 36 | setsubelt([E|T], E, T) :- !. 37 | setsubelt([], E, []). 38 | setsubelt([H|T], E, [H|R1]) :- setsubelt(T,E,R1). 39 | setsub(A, [], A). 40 | setsub(A, [H|T], R) :- setsubelt(A, H, X), setsub(X, T, R). 41 | setadd(A, B, AB) :- setsub(A, B, X), append(X, B, AB). 42 | 43 | setxor(A, B, XAB) :- setsub(A, B, AB), setsub(B, A, BA), 44 | append(AB, BA, XAB). 45 | setand(A, B, AAB) :- setadd(A, B, AB), setxor(A,B, XAB), 46 | setsub(AB, XAB, AAB). 47 | 48 | unifiqinner([], R, R). 49 | unifiqinner([H|T], Prev,R) :- in(H,Prev),!,unifiqinner(T,Prev,R). 50 | unifiqinner([H|T], Prev,R) :- unifiqinner(T,[H|Prev],R). 51 | 52 | unifiq([], []) :- !. 53 | unifiq(L, R) :- unifiqinner(L,[],R),!. 54 | 55 | // // // Does not work yet: 56 | // perms(L, [H|T]) :- setsubelt(L,H,R), perms(R,T). 57 | // perms([], []). 58 | 59 | // Assoc lists 60 | find(Key, [[Key, Value]|Rest], Value) :- !. 61 | find(Key, [X|Rest], Value) :- find(Key, Rest, Value). 62 | 63 | amod(K, V, [], []) :- !. 64 | amod(Key, Value, [[Key, OldValue]|Rest], [[Key, Value]|Rest]) :- !. 65 | amod(Key, Value, [X|Rest], [X|R]) :- amod(Key, Value, Rest, R). 66 | 67 | //Peano 68 | natural_number(o). 69 | natural_number(s(N)) :- natural_number(N). 70 | 71 | natural_add(o, N, N). 72 | natural_add(s(A), B, s(C)) :- natural_add(A,B,C). 73 | 74 | natural_mul(o, N, o). 75 | natural_mul(s(N), M, P) :- 76 | natural_mul(N, M, K), 77 | natural_add(K, M, P). 78 | 79 | natural_gr(s(N),o). 80 | natural_gr(s(A),s(B)) :- natural_gr(A,B). 81 | 82 | natural_lt(o,s(N)). 83 | natural_lt(s(A),s(B)) :- natural_lt(A,B). 84 | 85 | natural_max(A,A,A). 86 | natural_max(A,B,A) :- natural_gr(A,B). 87 | natural_max(A,B,B) :- natural_gr(B,A). 88 | 89 | natural_min(A,A,A). 90 | natural_min(A,B,B) :- natural_gr(A,B). 91 | natural_min(A,B,A) :- natural_gr(B,A). 92 | 93 | natural_to_num(o,0). 94 | natural_to_num(s(N), I) :- natural_to_num(N, I1), isadd(I, I1, 1). 95 | 96 | num_to_natural(0,o). 97 | num_to_natural(I, s(N)) :- issub(I1, I, 1), num_to_natural(I1, N). 98 | 99 | }} 100 | 101 | %%%%//////////////// 102 | 103 | 104 | -------------------------------------------------------------------------------- /src/l/boot/common.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \section{Stage 1 --- common to all future passes} 12 | ;- 13 | ;- This sequence controls the compilation of the core library. 14 | ;- It is used in interpretation stage as well as in all the consequent 15 | ;- compiled environment bootstrap builds. 16 | ;- 17 | 18 | ;- Compiler default options, etc.: 19 | (include "../options.al") 20 | 21 | ;- By default, exit on a first error message 22 | (ctimex (define debug-compiler-failure #t)) 23 | 24 | ;- MBase way of communicating compiler internal errors, via MBaseException 25 | (include "../core/ccerrors.al") 26 | 27 | ;- Parsing combinators library 28 | (include "../core/parsing.al") 29 | 30 | ;- Basic pattern matching 31 | (include "../core/pmatch.al") 32 | 33 | ;- Emitting IL via System.Reflection.Emit 34 | (include "../core/emit.al") 35 | 36 | ;- There are two different modes of asmlib embedding. First is to compile it as a separate 37 | ;- dll, and second is to compile it into MBaseBin.dll in the last stage. 38 | 39 | (expand-if (not (shashget (getfuncenv) 'asmlib-final)) 40 | (include "../core/asmlib_common.al") 41 | (add-assembly "bootasm.dll") 42 | (define generic_pfx "bootasm.") 43 | (using ("bootasm") 44 | (include "../core/asmlib_load.al"))) 45 | 46 | (expand-if (shashget (getfuncenv) 'asmlib-final) 47 | (include "../core/asmlib_common.al") 48 | (define generic_pfx "MBaseBin.") 49 | (include "../core/asmlib_load.al")) 50 | 51 | ;- Common to both approaches are asmlib definitions: 52 | (include "../core/asmlib_hooks.al") 53 | 54 | ;- Slightly misleading name: actually it is a global environment lock definition. 55 | (include "../core/environment.al") 56 | 57 | ;- Several aux macros 58 | (include "../core/utils.al") 59 | 60 | ;- A legacy macro, which may be possibly revived later. 61 | (macro notaruntime rest `(top-begin ,@rest)) 62 | 63 | ;- Support for documentation generation. It is actually needed only at the final 64 | ;- stage. 65 | (include "../core/doc.al") 66 | 67 | ;- Basic support for records (array-based) 68 | (include "../core/records.al") 69 | 70 | ;- The core AST processing language definition: the new compiler is based on it. 71 | (include "../core/ast.al") 72 | 73 | ;- Simple lexer wrapper, on top of parsing combinators library. 74 | (include "../core/lexing.al") 75 | 76 | ;- LL(*) parser, used by list comprehensions and infix syntax. 77 | (include "../core/fsmparser.al") 78 | 79 | ;- List comprehensions library 80 | (include "../core/list.al") 81 | 82 | ;- A simple environments handling library - used by the new compiler 83 | (include "../core/envhandling.al") 84 | 85 | ;- Syntax case library 86 | (include "../core/syntax-case.al") 87 | 88 | 89 | ; Register scheduling - 90 | ; used only at the last stage 91 | (ctime (if (shashget (getfuncenv) 'stage-final) 92 | `(include "../core/graphsort.al") 93 | `(begin))) 94 | 95 | (include "../core/liveness.al") 96 | (include "../core/coloring.al") -------------------------------------------------------------------------------- /src/l/lib/pfront/pfront.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (include "../../version.al") 11 | (n.module pfront exe) 12 | (sysdll MBaseFront) 13 | 14 | (function __pfront_register-dumpcore (ofil) 15 | (let ((plugin 16 | (fun (core) 17 | (fprintln ofil (S<< `(inner.verbatimcore (quote ,(cc:core-sanitise-tokens core))))) 18 | core))) 19 | (cc:add-plugin 'pre-lift plugin))) 20 | 21 | (function main () 22 | (alet exitfile (mkref nil) 23 | (shashput (getfuncenv) 'main nil) 24 | (corelib:set-lookup-path (not.neth () (leave 25 | (System.IO.Directory@GetCurrentDirectory)))) 26 | (let iloop ((ln (a->l *CMDLINE*))) 27 | (p:match ln 28 | (("/e" $fnm . $_) 29 | (begin 30 | (read-compile-eval `(hlevl-file ,fnm)) 31 | (read-compile-eval `(n.save)))) 32 | 33 | (("/c" $exenm $fnm . $_) 34 | (begin 35 | (read-int-eval `(n.module ,(Sm<< exenm) exe)) 36 | (read-compile-eval `(hlevl-file ,fnm)) 37 | (read-compile-eval `(n.save)))) 38 | 39 | (("/d" $exenm $fnm . $_) 40 | (begin 41 | (read-int-eval `(n.module ,(Sm<< exenm))) 42 | (read-compile-eval `(hlevl-file ,fnm)) 43 | (read-compile-eval `(n.save)))) 44 | 45 | (("/dbg" . $rest) 46 | (begin 47 | (read-int-eval `(define compiler-debug-enabled #t)) 48 | (iloop rest))) 49 | 50 | (("/b" . $rest) 51 | (begin 52 | (read-int-eval `(define compiler-debug-failure #t)) 53 | (iloop rest))) 54 | 55 | (("/bench" . $rest) 56 | (begin 57 | (r! pfront-benchmark-only #t) 58 | (iloop rest))) 59 | 60 | (("/dumpal" $fnm . $rest) 61 | (let* ((ofil (io-open-write (S<< (corelib:get-lookup-path) "/" fnm)))) 62 | (r! pfront-dump-alfile ofil) 63 | (r! exitfile (cons ofil (deref exitfile))) 64 | (iloop rest))) 65 | 66 | (("/dumpcore" $fnm . $rest) 67 | (let* ((ofil (io-open-write (S<< (corelib:get-lookup-path) "/" fnm)))) 68 | (__pfront_register-dumpcore ofil) 69 | (r! exitfile (cons ofil (deref exitfile))) 70 | (iloop rest))) 71 | 72 | (("/hist" . $rest) 73 | (begin 74 | (r! pfront-mkhist #t) 75 | (iloop rest))) 76 | 77 | (($fnm . $_) 78 | (begin 79 | (read-int-eval '(n.module frontrepl dll)) 80 | (read-compile-eval `(hlevl-file ,fnm)))) 81 | 82 | (else 83 | (iter println ' 84 | ("Usage:" 85 | " pfront [options] : execute a file" 86 | " pfront [options] /c : compile a file" 87 | " pfront [options] /d : compile a file into a dll" 88 | "" 89 | "Options are:" 90 | " /dbg : emit debugging info" 91 | " /b : exit on a first error" 92 | " /dumpal : dump the file as .al" 93 | )))) 94 | ) 95 | (foreach (f (deref exitfile)) 96 | (io-wclose f)) 97 | )) 98 | -------------------------------------------------------------------------------- /src/l/lib/pfront/pftexincludeinv.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (recfunction ploop1_texinv (outfile str p fn) 11 | (let* ((outenv (mkhash)) 12 | (env (PegEnv.new nil 13 | (make-accept-signal-1 outenv pp-defaultmerge) 14 | #t 15 | nil 16 | nil 17 | (mkhash) 18 | )) 19 | (res (peg:easyparse3 env p (deref str))) 20 | (s (p:match (car res) 21 | ((FAIL: . $_) nil) (else #t)))) 22 | (if s 23 | (begin 24 | (fn (car res)) 25 | (p:match (car res) 26 | (else 27 | (begin 28 | (fprint outfile "\\pfcodeblockbegin{}") 29 | (print-rle-stream outfile 30 | ___Tabs_tex 31 | __tex_pfrontcolours 32 | outenv 33 | (deref str) 34 | (cdr res) 35 | rle-tex) 36 | (fprint outfile "\\pfcodeblockend{}") 37 | ))) 38 | (if (peg-alldead? (cdr res)) nil 39 | (begin 40 | (r! str (cdr res)) 41 | (ploop1_texinv outfile str p fn)))) 42 | (begin 43 | (pfront-report-syntax-error (deref str) res) 44 | )))) 45 | 46 | (recfunction hlevl-consume1-texinv (texnm dstream) 47 | (let* ( 48 | (outfile (io-open-write (S<< texnm ".tex"))) 49 | (clect (mkref nil)) 50 | (reallyadd (fun (x) 51 | (r! clect (cons (hlevel-compile x) 52 | (deref clect))))) 53 | (cget (fun () 54 | (let ((res (reverse (deref clect)))) 55 | (r! clect nil) 56 | res))) 57 | (flush (fun () 58 | (alet code (cget) 59 | (try 60 | (try 61 | (cc:flush-bypass-from-macro `(top-begin ,@code)) 62 | t_MBaseException 63 | (fun (e) 64 | (writeline `(MBaseException ,(mbaseerror e) in ,@code)))) 65 | t_Exception 66 | (fun (e) 67 | (writeline `(Exception ,(->s e) in ,@code))) 68 | 69 | )))) 70 | (cadd (fun (x) 71 | (hlevel:iter topexpr x 72 | (topexpr _ 73 | ((topflush (flush)) 74 | (else (reallyadd x)))))))) 75 | (ploop1_texinv outfile 76 | dstream peg_pfront 77 | (fun (x) (writeline `(OOO: ,x)) (cadd x))) 78 | (io-wclose outfile) 79 | (cget))) 80 | 81 | (macro hlevl-file1-texinv (texnm nm) 82 | `(top-begin 83 | ,@(hlevl-consume1-texinv 84 | texnm 85 | (mkref (peg:file->stream nm))))) 86 | 87 | -------------------------------------------------------------------------------- /misc/demos/03calc.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \subsection{03calc.al: compiler} 12 | ;- 13 | ;- 14 | 15 | ;- In previous examples the AST was interpreted. Now we will translate it into MBase language so it 16 | ;- can be compiled and executed as MBase code. 17 | ;- 18 | 19 | ;{{ 20 | (def:ast calc03 ( ) 21 | (*TOP* ) 22 | (expr 23 | (| 24 | (plus ) 25 | (minus ) 26 | (mult ) 27 | (div ) 28 | (let ) 29 | (var ) 30 | (const )))) 31 | ;}} 32 | 33 | ;- This transform is simple again, simpler than the 34 | ;- previous interpreter, since it generates MBase code directly 35 | ;- and MBase itself will deal with variable bindings. 36 | (function compile (ex) 37 | (calc03:visit expr ex 38 | (expr DEEP 39 | ((const `(f# ,v)) 40 | (var nm) 41 | (let `(alet ,nm ,val ,body)) 42 | (plus `(f+ ,a ,b)) 43 | (minus `(f- ,a ,b)) 44 | (mult `(f* ,a ,b)) 45 | (div `(f/ ,a ,b)) 46 | )))) 47 | 48 | ;{{ 49 | (define p.double 50 | ( ((p.digit +*) (?? ("." (p.digit +*)))) 51 | -> list->string)) 52 | (define p.ident0 53 | ( p.alpha (p.alpha *))) 54 | 55 | (make-simple-lexer calclexer 56 | (ident-or-keyword p.ident0 var) 57 | (keywords let in) 58 | (simple-tokens 59 | "-" MINUS "(" LB ")" RB "=" EQ 60 | ) 61 | (regexp-tokens 62 | (("+") -> list->symbol) OP1 63 | (("*" | "/") -> list->symbol) OP2 64 | p.double number) 65 | (ignore p.whitespace) 66 | ) 67 | ;}} 68 | 69 | ;{{ 70 | (function getop (x) 71 | (case x 72 | ((+) 'plus) ((-) 'minus) ((*) 'mult) ((/) 'div))) 73 | ;}} 74 | 75 | ;- The parser is just slightly different, numbers in it are not parsed but 76 | ;- represented as strings instead --- MBase backend will parse them later. 77 | (bnf-parser ((expr calcparser)) 78 | (expr 79 | ((term:l MINUS expr:r) `(minus ,l ,r) ) 80 | ((term:l OP1:o expr:r) `(,(getop o) ,l ,r) ) 81 | ((term) $0)) 82 | (term 83 | ((fact:l OP2:o term:r) `(,(getop o) ,l ,r)) 84 | ((fact) $0)) 85 | (fact 86 | ((let var:v EQ expr:e in expr:b) 87 | `(let ,v ,e ,b)) 88 | ((var) `(var ,$0)) 89 | ((LB expr:x RB) x) 90 | ((number) `(const ,$0)) 91 | ((MINUS fact:e) `(minus (const "0.0") ,e))) 92 | ) 93 | 94 | ;- And in order to add this language to MBase and to be able to use MBase as a 95 | ;- backend, we will define a macro. This example 96 | ;- illustrates how blurred the border between metaprogramming and 97 | ;- compilation is. 98 | (macro calc03# (str) 99 | (compile (lex-and-parse calclexer calcparser str))) 100 | 101 | ;- The usage is quite trivial: 102 | (writeline (calc03# "let x = 2*2 in let y = 1.1 in (2+x)/y")) 103 | 104 | ;- As a side effect of this way of compilation, all the MBase variables are visible: 105 | (writeline (let ((x (f# "2.0"))) 106 | (calc03# "(2+x*x)/1.1"))) -------------------------------------------------------------------------------- /src/l/core/cc-ast-flat.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \subsection{Flat intermediate code AST definition} 12 | ;- 13 | 14 | (def:ast cc:flatast ( ) 15 | (*TOP* ) 16 | (lifted <*liftop:code>) 17 | (liftop 18 | (| 19 | (Init ) 20 | (Simple <*ident:fargs> ) 21 | (Global ) 22 | (Funref ) 23 | (Closure <*ident:args> 24 | <*ident:fargs> ) 25 | )) 26 | (block <*code:cd>) 27 | ;= Expressions are atomic now, including a virtual reference to the stack. 28 | ;= Applications pop arguments from left to right. 29 | (expr 30 | (| 31 | (Var ) 32 | (Arg ) 33 | (Glob ) 34 | (GlobRec ) 35 | (Gencall ) 36 | (Clenv ) 37 | (Meta ) ;; not a value but a reference 38 | (IntPtr ) 39 | 40 | (Str ) 41 | (Num ) 42 | (NBNum ) 43 | (Chr ) 44 | (Bool ) 45 | (Symbol ) 46 | (Quote ) 47 | (Nil) 48 | 49 | (Pop))) 50 | ;= Function body is also a list of flat assembly instructions. 51 | (code 52 | (| 53 | (Local ) 54 | (FixLocal ) 55 | (DebugPoint . <*debugdata:d>) 56 | (Label ) 57 | (Iflabel ) 58 | (Goto ) 59 | (Setlocal ) 60 | (Setglobal ) 61 | (Setnewglobal ) 62 | (Push ) 63 | (Patchclosure . <*patcharg:args>) 64 | (Switch . <*ident:labels>) 65 | 66 | (Pushapp . <*expr:args>) ; Regular call 67 | (Setlocapp . <*expr:args>) 68 | (Retapp . <*expr:args>) ; A tail call 69 | (Dropapp . <*expr:args>) 70 | (Asm <*useident:use> . ) 71 | 72 | (ClosureDummy) 73 | (TryBegin) 74 | (CatchBegin ) 75 | (TryEnd) 76 | 77 | (InitGlobalVar ) 78 | (InitGlobalFun ) 79 | (InitGlobalMac ) 80 | 81 | (Car ) 82 | (Cdr ) 83 | (Cons ) 84 | (Cons1 ) 85 | (Cons0) 86 | 87 | (SetCar ) 88 | (SetCdr ) 89 | (CastPair ) 90 | 91 | (GotoNull ) 92 | (GotoPairP ) 93 | (GotoEqv ) 94 | 95 | (BinOp ) 96 | (IntBox ) 97 | (IntUnbox ) 98 | 99 | (Return ) 100 | (Pop ) 101 | (Nop) 102 | (Gotoif ) 103 | (Gotoifnot ) 104 | )) 105 | (patcharg ( )) 106 | (useident ( )) 107 | 108 | ) -------------------------------------------------------------------------------- /src/l/lib/wam/prolog_repl.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \section{Standalone Prolog REPL} 4 | 5 | \pfcode{ 6 | #(sysdll MBaseLogic) 7 | } 8 | 9 | \pfcode{ 10 | parser prologrepl (prolog) { 11 | !!Spaces; 12 | prologrepl := [prologrepl0]:v [Spaces]* => v; 13 | prologrepl0 := 14 | { next => NEXT() } 15 | / { exit => EXIT() } 16 | / { load [string]:s => LOAD(s) } 17 | / { debug [number]:n => DEBUG(n) } 18 | / { [prolog]:p => PROLOG(p) } 19 | ; 20 | } 21 | } 22 | 23 | \pfcode{ 24 | function prolog_display_result(r) 25 | { match r with 26 | rnum : rmap : next -> { 27 | if (rmap) { 28 | println(%S<<("Solution N", rnum, ":")); 29 | map [n;nv] in rmap do { 30 | println(%S<<(n, " = ", prolog_term_to_string(nv)))} 31 | } else println("Yes."); 32 | return next} 33 | | else -> {println("No."); []}}} 34 | 35 | \pfcode{ 36 | function prolog_repl_once(str, prev) 37 | { 38 | v = parse str as prologrepl; 39 | match v with 40 | 'FAIL:':(v:strm):errs -> println(%S<<("Syntax error at ", %__peg:displaypos(strm), ", expecting: ", %S<<(errs))) 41 | | PROLOG(vv) -> { result = prolog_backend_driver(vv, %read-compile-eval , []); 42 | return prolog_display_result(result) } 43 | | NEXT() -> (if(prev) return prolog_display_result(prev()) else []) 44 | | LOAD(nm) -> { 45 | fpath = %generic-filepath(nm); 46 | src = %peg:file->stream(fpath); 47 | pars = parse stream src as prolog; 48 | app0 = map a in pars do prolog_parse_fix_arity_clause(a); 49 | capp = prolog_compile(app0); 50 | cgen = %map(prolog_codegen, capp); 51 | %read-compile-eval('begin'(@cgen)); 52 | return [] 53 | } 54 | | DEBUG(n) -> { 55 | if(n==0) { 56 | #(read-int-eval '(define debug-prolog-compile nil)); 57 | #(read-int-eval '(define debug-prolog-codegen nil)) 58 | } else if(n==1) { 59 | #(read-int-eval '(define debug-prolog-compile 1)) 60 | } else if(n==2) { 61 | #(read-int-eval '(define debug-prolog-codegen 1)) 62 | }; 63 | return prev 64 | } 65 | | EXIT() -> quit() 66 | } 67 | } 68 | 69 | \pfcode{ 70 | #(define sem (car (string->list ";"))) 71 | #(function plg_read_eval_print_loop (redr) 72 | (let loop ((buf nil) (prev nil)) 73 | (if (null? buf) (print "<< ")) 74 | (format 75 | (p:match buf 76 | (($a $b . $r) (list a b)) 77 | (else (list 0 0))) (a b) 78 | (if (and (eq? a sem) (eq? b sem)) 79 | (let ((nprev (prolog_repl_once 80 | (list->string (reverse (cddr buf))) prev))) 81 | (loop nil nprev)) 82 | (alet chr (not.neth ((System.IO.StreamReader redr)) 83 | (chr = (redr@Read)) 84 | (object ret = null) 85 | (if (>= chr 0) (ret <- ((object)((char)chr)))) 86 | (leave ret)) 87 | (if (not chr) nil 88 | (loop (cons chr buf) prev))))))) 89 | } 90 | 91 | \pfcode{ 92 | function main() 93 | { 94 | #(corelib:set-lookup-path 95 | (not.neth () 96 | (leave 97 | (System.IO.Directory@GetCurrentDirectory)))); 98 | #(plg_read_eval_print_loop 99 | (not.neth () 100 | (leave ((object)(new System.IO.StreamReader 101 | (System.Console@OpenStandardInput))))))}} 102 | 103 | %%%%%%%%%%%%% 104 | -------------------------------------------------------------------------------- /misc/demos/04calc.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \subsection{04calc.al: IL compiler} 12 | ;- 13 | ;- 14 | ;- And finally, here is a ``real'' compiler which generates .NET IL instructions directly. 15 | ;- Surprisingly, it is almost as easy as the previous compiler that generated 16 | ;- a high level language code, thanks to the fact that .NET is a stack machine. 17 | 18 | ;{{ 19 | (def:ast calc04 ( ) 20 | (*TOP* ) 21 | (expr 22 | (| 23 | (plus ) 24 | (minus ) 25 | (mult ) 26 | (div ) 27 | (let ) 28 | (var ) 29 | (const )))) 30 | ;}} 31 | 32 | ;- 33 | ;- [[compile]] function transforms an AST into a flat list of IL instructions. 34 | (function compile (ex) 35 | (calc04:visit expr ex 36 | (expr DEEP 37 | ((const `((Ldc_R8 ,(flt:parse v)))) 38 | (var `((Ldloc (var ,nm)))) 39 | (let `((local ,nm ,t_Double) 40 | ,@val 41 | (Stloc (var ,nm)) 42 | ,@body)) 43 | (plus `(,@a ,@b (Add))) 44 | (minus `(,@a ,@b (Sub))) 45 | (mult `(,@a ,@b (Mul))) 46 | (div `(,@a ,@b (Div))) 47 | )))) 48 | 49 | ;{{ 50 | (define p.double 51 | ( ((p.digit +*) (?? ("." (p.digit +*)))) 52 | -> list->string)) 53 | 54 | (define p.ident0 55 | ( p.alpha (p.alpha *))) 56 | 57 | (make-simple-lexer calclexer 58 | (ident-or-keyword p.ident0 var) 59 | (keywords let in) 60 | (simple-tokens 61 | "-" MINUS "(" LB ")" RB "=" EQ 62 | ) 63 | (regexp-tokens 64 | (("+") -> list->symbol) OP1 65 | (("*" | "/") -> list->symbol) OP2 66 | p.double number) 67 | (ignore p.whitespace) 68 | ) 69 | 70 | (function getop (x) 71 | (case x 72 | ((+) 'plus) ((-) 'minus) ((*) 'mult) ((/) 'div))) 73 | 74 | (bnf-parser ((expr calcparser)) 75 | (expr 76 | ((term:l MINUS expr:r) `(minus ,l ,r) ) 77 | ((term:l OP1:o expr:r) `(,(getop o) ,l ,r) ) 78 | ((term) $0)) 79 | (term 80 | ((fact:l OP2:o term:r) `(,(getop o) ,l ,r)) 81 | ((fact) $0)) 82 | (fact 83 | ((let var:v EQ expr:e in expr:b) 84 | `(let ,v ,e ,b)) 85 | ((var) `(var ,$0)) 86 | ((LB expr:x RB) x) 87 | ((number) `(const ,$0)) 88 | ((MINUS fact:e) `(minus (const "0.0") ,e))) 89 | ) 90 | ;}} 91 | 92 | ;- 93 | 94 | ;- MBase has a 95 | ;- possibility to inline IL code ([[n.asm]]), so we will wrap our 96 | ;- compiler in a macro. 97 | (macro calc04# (str) 98 | `(n.asm () 99 | ,@(compile (lex-and-parse calclexer calcparser str)) 100 | ; Return a boxed object: 101 | (Box ,t_Double))) 102 | 103 | ;- And usage is the same: 104 | (writeline (calc04# "let x = 2*2 in let y = 1.1 in (2+x)/y")) 105 | 106 | ;- A curious reader can print out the compiled code: 107 | (iter writeline 108 | (compile 109 | (lex-and-parse calclexer calcparser 110 | "let x = 2*2 in let y = 1.1 in (2+x)/y" 111 | ))) 112 | 113 | -------------------------------------------------------------------------------- /src/l/lib/ml/mlcore-ast.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (def:ast mlsrc ( ) 11 | (*TOP* ) 12 | ;= Top level expressions: type declarations, [[let]] definitions, 13 | ;= immediate expression statements and compiler control statements. 14 | (topexpr 15 | (| 16 | (mlffi ) 17 | (mlexport ) 18 | (mbinclude ) 19 | (mlinclude ) 20 | (mltype . <*typedef:d>) 21 | (mlannotate ) 22 | (mllet ) 23 | (mlletrec ) 24 | (mlletrecr . <*lrecdef:dfs>) 25 | (mlexpr ))) 26 | ;= Expressions are of a same structure as in any other functional language, 27 | ;= with an addition of pattern matching. Normal [[if]] expressions are not 28 | ;= present here, since they can be represented as boolean constant pattern 29 | ;= matching. Imperative sequencing is present ([[begin]] statements). 30 | (expr 31 | (| 32 | 33 | (begin . <*expr:es>) 34 | 35 | (let ) 36 | (letrec ) 37 | (letrecr <*lrecdef:dfs> ) 38 | (fun ) 39 | 40 | ;= Things to aid parsing, but should be removed before any further AST transforms 41 | (uncurriedfun <*ident:args> ) 42 | (matchfun <*matchptn:ps>) 43 | (apply0 . <*expr:args>) 44 | (makelist . <*expr:args>) 45 | (cons ) 46 | (append ) 47 | (if2 ) 48 | (if3 ) 49 | 50 | 51 | ;= Normal nodes 52 | 53 | 54 | (apply ) 55 | (match . <*matchptn:ps>) 56 | (constr . <*expr:args>) 57 | (tuple . <*expr:args>) 58 | 59 | (var ) 60 | (number ) 61 | (char ) 62 | (string ) 63 | (bool ) 64 | (unit) 65 | )) 66 | 67 | ;= let ... and ... support: 68 | (lrecdef ( )) 69 | 70 | ;= Pattern matching structures: 71 | (matchptn ( )) 72 | (pattern 73 | (| (bind ) 74 | (constr . <*pattern:args>) 75 | (tuple . <*pattern:args>) 76 | (number ) 77 | (char ) 78 | (string ) 79 | (bool ) 80 | (unit) 81 | (any) 82 | ;= And a couple of transitional nodes, same as for expressions: 83 | (cons ) 84 | (bindany ) 85 | 86 | )) 87 | ;= Types in code are only referenced as tuples, named types with arguments 88 | ;= or type variables. 89 | (type (| (T . <*type:args>) 90 | (TPL . <*type:args>) 91 | (F ) 92 | (V ))) 93 | 94 | ;= Type definitions can produce name aliases, named tuples and variants. 95 | (typedef 96 | (| (alias ( . <*type:args>) ) 97 | (variant ( . <*type:args>) . <*vardef:b>))) 98 | (vardef ( . <*type:tpl>)) 99 | ) 100 | 101 | ;{{ 102 | (draw:ast:graph mlsrc "mlsrc.dot") 103 | ;}} 104 | -------------------------------------------------------------------------------- /src/l/core/native.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (using ("System.Reflection" "System.Reflection.Emit" "System.Runtime.InteropServices") 11 | (net.types 12 | MethodBase 13 | MethodBuilder 14 | CallingConventions 15 | CharSet 16 | CallingConvention ;; Note the difference CallingConvention (not CallingConventions) 17 | MethodImplAttributes 18 | ) 19 | 20 | (define _define_pinvoke (r_tbind t_TypeBuilder "DefinePInvokeMethod" string string 21 | t_MethodAttributes t_CallingConventions t_type "System.Type[]" t_CallingConvention t_CharSet)) 22 | 23 | (define _set_impl_flags (r_tbind t_MethodBuilder "SetImplementationFlags" t_MethodImplAttributes)) 24 | 25 | (define _get_impl_flags (r_tbind t_MethodBuilder "GetMethodImplementationFlags")) 26 | 27 | (function emit-pinvoke (cls nm dllname attrs conv ret artyps) 28 | (let* ((iattr (enumOr t_MethodAttributes attrs)) 29 | (iconv (enumOr t_CallingConventions conv)) 30 | (ichst (enumOr t_CharSet '())) 31 | (iccnv (enumOr t_CallingConvention '(Winapi))) 32 | (args (if (null? artyps) 33 | (anew t_Type 0) 34 | (mkvector artyps))) 35 | (mtd (_define_pinvoke cls nm dllname iattr iconv ret args iccnv ichst)) 36 | (en (getEnum t_MethodImplAttributes "PreserveSig"))) 37 | (_set_impl_flags mtd (enum-or en (_get_impl_flags mtd))))) 38 | 39 | (function f.emit-pinvoke (cls dllnm fncnm rtype argtyps) 40 | (emit-pinvoke cls fncnm dllnm '(Public Static PinvokeImpl) 41 | '(Standard) rtype argtyps)) 42 | 43 | (function f.make-pinvoke (dll nm ret ars) 44 | `(pinvoke ,dll ,nm ,ret ,ars)) 45 | 46 | (macro native imports 47 | ("Generates a class with native P$/$Invoke entries." 48 | "Entry format is:" 49 | " [[(import dll-name func-name return-type arg-type ...)]]" 50 | "Optional class name parameter:" 51 | " (classname Namespace.Class)" 52 | ) 53 | (let* ((cnmr (mkref (gensym))) 54 | (body (foreach-mappend (i imports) 55 | (p:match i 56 | ((import $dll $nm $ret . $args) 57 | (let* ((rett (read-int-eval `(r_typerx ,ret))) 58 | (arst (foreach-map (a args) 59 | (read-int-eval `(r_typerx ,a))))) 60 | (list 61 | (f.make-pinvoke (S<< dll) (S<< nm) 62 | rett arst 63 | )))) 64 | ((classname $nm) (begin (r! cnmr nm) nil)) 65 | (else nil) 66 | ))) 67 | (cnm (deref cnmr)) 68 | (icode `(:classwrap ,cnm () 69 | ,@body)) 70 | ) 71 | `(top-begin 72 | ,icode 73 | (force-class-flush) 74 | (net.types ,(Sm<< cnm)) 75 | ,@(foreach-mappend (i imports) 76 | (p:match i 77 | ((import $_ $nm $ret . $args) 78 | (let* ((ars (map (fun (x) (gensym)) args))) 79 | `((define ,(Sm<< nm) 80 | (r_tsbind ,(Sm<< "t_" cnm) ,(S<< nm) ,@args)))))))))) 81 | 82 | (set-car! _pinvoke_maker_hook f.emit-pinvoke) 83 | -------------------------------------------------------------------------------- /src/l/lib/parsing/backend-ast.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ; This ast definition is for reference only, it is not used by the MBase backend 11 | ; (but might be useful for, say, emacs or C backends). 12 | 13 | (def:ast pegtarget () 14 | (*TOP* <*topexpr:es>) 15 | 16 | (pegexpr 17 | (| (peg-ignore <*term:ts> ) 18 | 19 | (peg-ordie . <*any:rest>) 20 | 21 | (peg-node ) 22 | (peg-if ) 23 | (peg-check ) 24 | 25 | (peg-dummy) 26 | (peg-dummy-back) 27 | (peg-loop ) 28 | (peg-bind ) 29 | 30 | ;; Term calls 31 | (peg-call-gen ) 32 | (peg-call-terminal-gen ) 33 | (peg-call-simple ) 34 | (peg-call-terminal ) 35 | 36 | 37 | (peg-trivial ) 38 | 39 | ;; GADT-alike stuff, incomplete 40 | (peg-check-collect ) 41 | (peg-merge-altbranches ) 42 | 43 | ;; "FFI" stuff, potentially not so portable 44 | (peg-call-checker ) 45 | (peg-call-highorder <*ident:args> ) 46 | 47 | ;;;;; 48 | (peg-fail) 49 | )) 50 | 51 | (pred 52 | (| (char ) 53 | (anychar) 54 | (range ) 55 | (or . <*pred:ps>) 56 | (string . ) 57 | (sstring ) 58 | (fail) 59 | )) 60 | 61 | 62 | (termfun 63 | (| (peg-term-function 64 | 65 | 66 | 67 | ) 68 | (none) 69 | )) 70 | 71 | (termfundef ( )) 72 | 73 | (topexpr 74 | (| (peg-parser 75 | 76 | <*ident:parents> 77 | <*termfundef:defs> 78 | <*ident:exports> 79 | <*ident:dhooks> 80 | 81 | <*identpair:nodetypes> ;; for pickling 82 | ) 83 | (none) 84 | )) 85 | 86 | (adcode ( )) 87 | (istruct <*isnode:iss>) 88 | (isnode ( )) 89 | (annot <*apair:as>) 90 | (apair ( )) 91 | (carg 92 | (| (set ) 93 | (append ) 94 | )) 95 | (code 96 | (| 97 | (var ) 98 | (const ) 99 | (fcall . <*code:ars>) 100 | (constr . <*carg:ars>) 101 | 102 | ;; The following three are only available in recform mode 103 | (dconstr . <*carg:ars>) 104 | (list . <*carg:ars>) 105 | (dauto . <*id:tagname>) 106 | 107 | (action ) ;; USE WITH CAUTION 108 | (auto . <*id:tagname>) ;; to be replaced with an automatically inferred code 109 | (nop) 110 | )) 111 | 112 | ) 113 | 114 | 115 | (function peg-backend-verify (topexpr) 116 | (pegtarget:visit topexpr topexpr 117 | (pegexpr DEEP (forall node)))) 118 | 119 | -------------------------------------------------------------------------------- /src/l/lib/ml/mlfront.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | ;- 12 | ;- \subsection{S--expressions ML frontend} 13 | ;- 14 | ;- 15 | ;- Since our implementation is embeddable, having an intermediate list--based 16 | ;- representation could be quite useful for implementing higher level languages 17 | ;- on top of ML. 18 | ;- 19 | 20 | (function mml-constr? (sym) 21 | (matches? p.mlcapident (symbol->string sym))) 22 | 23 | (function mml->ml.pattern (ptrn) 24 | (let loop ((p ptrn)) 25 | (p:match p 26 | ((% . $rest) `(tuple ,@(map loop rest))) 27 | ($$M:v (if (eqv? v '_) '(any) 28 | `(bind ,v (any)))) 29 | (($$M:s . $rest) `(constr ,s ,@(map loop rest))) 30 | ($$S:s `(string ,s)) 31 | ($$N:n `(number ,n)) 32 | (($$F:b (fun (x) (eq? x #t))) `(bool #t)) 33 | (($$F:b (fun (x) (eq? x #f))) `(bool #f))))) 34 | 35 | (function mml->ml.expr (expr) 36 | (let loop ((e expr)) 37 | (p:match e 38 | ((let rec $nm $vl $body) 39 | `(letrec ,nm ,(loop vl) ,(loop body))) 40 | ((let $nm $vl $body) 41 | `(let ,nm ,(loop vl) ,(loop body))) 42 | ((fun $args $body) 43 | (ml-curry-function args (loop body))) 44 | ((begin . $body) 45 | `(begin ,@(map loop body))) 46 | ((match $v with . $pattern) 47 | `(match ,(loop v) ,@(map-over pattern 48 | (fmt (p e) 49 | (list (mml->ml.pattern p) 50 | (loop e)))))) 51 | ((% . $rest) 52 | `(tuple ,@(map loop rest))) 53 | (($$M:s . $rest) 54 | (if (mml-constr? s) 55 | `(constr ,s ,@(map loop rest)) 56 | (mlapply `(var ,s) (map loop rest)))) 57 | (($e . $rest) 58 | (mlapply (loop e) (map loop rest))) 59 | ($$M:s `(var ,s)) 60 | ($$S:s `(string ,s)) 61 | ($$N:n `(number ,n)) 62 | (($$F:b (fun (x) (eq? x #t))) `(bool #t)) 63 | (($$F:b (fun (x) (eq? x #f))) `(bool #f)) 64 | (else (ccerror `(MML:EXPRESSION ,e)))))) 65 | 66 | (function to-string-i (s) 67 | (innerlist outerlist 1 s)) 68 | 69 | (function mml->ml.type (tdef) 70 | (lex-and-parse mllexer mltype (to-string-i tdef))) 71 | 72 | (function mml->ml.typedefs (tdef) 73 | (lex-and-parse mllexer mltypedefs (to-string-i tdef))) 74 | 75 | (recfunction mml->ml (add src) 76 | (p:match src 77 | ((type . $typedefs) 78 | (add `(mltype ,@(mml->ml.typedefs typedefs)))) 79 | ((let rec $nm $expr) 80 | (add `(mlletrec ,nm ,(mml->ml.expr expr)))) 81 | ((let $nm $expr) 82 | (add `(mllet ,nm ,(mml->ml.expr expr)))) 83 | ((foreign $nm $type $fnm) 84 | (add `(mlffi ,nm ,(mml->ml.type type) ,fnm))) 85 | ((mlinclude $$S:fname) 86 | (add `(mlinclude ,fname))) 87 | ((mbinclude $$S:fname) 88 | (add `(mbinclude ,fname))) 89 | ((val $nm $type) 90 | (add `(mlannotate ,nm ,(mml->ml.type type)))) 91 | ($expr 92 | (add `(mlexpr ,(mml->ml.expr expr)))))) 93 | 94 | (macro ml$ rest 95 | (try 96 | (let* ((src1 (collector (add get) 97 | (iter (cut mml->ml add <>) rest) 98 | (get))) 99 | (res (ml-driver ml:env src1))) 100 | `(top-begin 101 | ,@res)) 102 | t_MBaseException 103 | (fun (e) 104 | (writeline `(TOPLEVEL-ERROR: ,(mbaseerror e))) 105 | `(top-begin )))) 106 | -------------------------------------------------------------------------------- /src/l/lib/parsing/ast.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \subsection{An internal AST for PEGs} 12 | ;- 13 | 14 | (def:ast packrat () 15 | (*TOP* ) 16 | 17 | (ntexprs <*ntexpr:es>) 18 | 19 | (ntexpr 20 | (| 21 | (terminal 22 | . <*report:r>) 23 | (binaries 24 | <*binvar:vs> . <*report:r>) 25 | (with-ignore ) 26 | (define <*id:argnames> . <*report:r>) 27 | (rule ) 28 | (dynahook ) 29 | (targetast ) 30 | ;; syntax sugar to be expanded into binaries 31 | (src-binaries 32 | <*srcbinvar:vs> . <*report:r>) 33 | 34 | )) 35 | 36 | (dualcode ( )) 37 | (annot (.<*apair:as>)) 38 | (apair ( )) 39 | (binvar ( . <*report:r>)) 40 | (srcbinvar (| (simple ) 41 | (binary 42 | ))) 43 | (code 44 | (| 45 | (var ) 46 | (const ) 47 | (fcall . <*code:ars>) 48 | (constr . <*carg:ars>) 49 | 50 | ;; The following three are only available in recform mode 51 | (dconstr . <*carg:ars>) 52 | (list . <*carg:ars>) 53 | (dauto . <*id:tagname>) 54 | 55 | (action ) ;; USE WITH CAUTION 56 | (auto . <*id:tagname>) ;; to be replaced with an automatically inferred code 57 | (nop) 58 | )) 59 | (carg 60 | (| (set ) 61 | (append ) 62 | )) 63 | 64 | (expr 65 | (| (seq . <*expr:es>) ; E1 E2 ... 66 | (palt . <*expr:es>) ; E1 / E2 ... 67 | (pdalt . <*expr:es>) ; E1 / E2 ... 68 | 69 | (merge . <*expr:es>) ; merge alternative branches 70 | 71 | (andp ) ; & E 72 | (notp ) ; ! E 73 | (plus ) ; E + 74 | (star ) ; E * 75 | (maybe ) ; E ? 76 | (trivial ) ; trivial recognisers (characters, strings, ...) 77 | (withignore ) 78 | 79 | ; if E fails, fail unconditionally with a message 80 | (ordie . <*code:args>) 81 | 82 | (withfilter ) 83 | 84 | (bind-terminal . <*id:rec>) 85 | (bind ) 86 | (terminal . <*id:rec>) 87 | (simple ) 88 | (lift . <*report:r>) 89 | (rule ) 90 | (macroapp . <*expr:args>) 91 | 92 | (action . <*code:args>) ; Action over environment, 93 | ; does not affect parsing 94 | 95 | (highorder <*id:args> ) 96 | (check ) 97 | (hint <*any:args>) ; backend-specific hint, ignored by parser 98 | ))) 99 | 100 | (def:ast pktrivial () 101 | (*TOP* ) 102 | (pred 103 | (| (char ) 104 | (anychar) 105 | (range ) 106 | (or . <*pred:ps>) 107 | (string . ) 108 | (sstring ) 109 | (fail) ; always fails 110 | ))) 111 | 112 | -------------------------------------------------------------------------------- /misc/demos/01calc.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \subsection{01calc.al: two passes} 12 | ;- 13 | ;- 14 | 15 | ;- Now, to illustrate a more complex approach, we will separate 16 | ;- a parsing pass and an evaluation pass. To do this, we need to define an 17 | ;- abstract syntax tree structure. MBase provides a special mini--language 18 | ;- for defining algebraic data types and verifiable transforms over them: [[def:ast]] 19 | ;- macro. 20 | (def:ast calc01 ( ) 21 | (*TOP* ) ; An entry node 22 | (expr ; Single variant node 23 | (| 24 | (plus ) 25 | (minus ) 26 | (mult ) 27 | (div ) 28 | (const )))) 29 | ;- If you have programmed in ML or Haskell, you will find the definition above somewhat familiar. 30 | ;- [[expr]] is a variant data type, and [[plus]], [[minus]], etc. are constructor 31 | ;- tags. [[expr]] is a recursive type, referencing to itself. 32 | 33 | 34 | ;- 35 | ;- We need such a definition not only for a documenting purposes, but also for 36 | ;- defining visitors and iterators over these AST structures. 37 | ;- The following function, [[eval]], takes [[calc01]] AST as a source and returns 38 | ;- a floating point number, an interpreted value of this tree. In languages like 39 | ;- ML you would have to write a recursive function and use pattern matching, but MBase 40 | ;- way is different --- a visitor recursive function will be generated automatically, 41 | ;- and you only have to declare certain nodes and variant entries transforms 42 | ;- explicitly. 43 | (function eval (e) 44 | ; Visits {\tt e} assuming it contains {\tt expr} node: 45 | (calc01:visit expr e 46 | (expr DEEP ; Transforms {\tt expr} nodes using depth--first strategy 47 | ((const v) ; all {\tt expr} variants are listed here 48 | (plus (f+ a b)) 49 | (minus (f- a b)) 50 | (mult (f* a b)) 51 | (div (f/ a b)) 52 | )))) 53 | 54 | ;- Here and further we will omit definitions that are identical to previous 55 | ;- versions, giving only modified entries. Lexer is the same 56 | ;- as in [[00calc.al]]. 57 | ;- 58 | 59 | ;{{ 60 | (define p.double 61 | ( ((p.digit +*) (?? ("." (p.digit +*)))) 62 | -> list->string)) 63 | 64 | (make-simple-lexer calclexer 65 | (simple-tokens 66 | "-" MINUS "(" LB ")" RB 67 | ) 68 | (regexp-tokens 69 | (("+") -> list->symbol) OP1 70 | (("*" | "/") -> list->symbol) OP2 71 | p.double number) 72 | (ignore p.whitespace) 73 | ) 74 | 75 | ;}} 76 | 77 | ;- Our dispatch function is different now, it translates tokens into tags, not 78 | ;- functions. 79 | (function getop (x) 80 | (case x 81 | ((+) 'plus) ((-) 'minus) ((*) 'mult) ((/) 'div))) 82 | 83 | ;- And the parser is different, it produces [[calc01]] AST instead of evaluating 84 | ;- values immediately. 85 | (bnf-parser ((expr calcparser)) 86 | (expr 87 | ((term:l MINUS expr:r) `(minus ,l ,r) ) 88 | ((term:l OP1:o expr:r) `(,(getop o) ,l ,r) ) 89 | ((term) $0)) 90 | (term 91 | ((fact:l OP2:o term:r) `(,(getop o) ,l ,r)) 92 | ((fact) $0)) 93 | (fact 94 | ((LB expr:x RB) x) 95 | ((number) `(const ,(flt:parse $0))) 96 | ((MINUS fact:e) `(minus (const ,(f# "0")) ,e))) 97 | ) 98 | 99 | ;- The usage is pretty much the same, we only add [[eval]] function call here: 100 | (writeline (eval (lex-and-parse 101 | calclexer 102 | calcparser 103 | "(2+2*2)/1.1"))) 104 | -------------------------------------------------------------------------------- /src/l/lib/ssa/ssa-fold-typing.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \pfsysdllref{"MBaseLogic"} 4 | 5 | \section{Generic type propagation} 6 | 7 | User must provide typing rules for each intrinsic. E.g.: $$x=add(l,r) \to \{T_x = T_l = T_r\}.$$ 8 | 9 | This can be used for propagating types missing from GEP and $\varphi$ nodes, as well as for typing all the nodes. 10 | 11 | \pfcode{ 12 | function genssa2_intrinsic_equations(lenv, env, eqadd, dstreg, dst, args) { 13 | eqnmaker = ohashget(env, '*type-equation-maker*'); 14 | if (eqnmaker) { 15 | eqn = eqnmaker(dst); 16 | if (eqn) eqn(lenv, eqadd, dstreg, dst, args)}}} 17 | 18 | \pfcode{ 19 | function genssa2_make_boolean_type(env) { 20 | btype = ohashget(env, '*boolean-type*'); 21 | if (btype) btype else 'var'('boolean')}} 22 | 23 | \pfcode{ 24 | function genssa2_make_type_maker(lenv, env) { 25 | tmaker = ohashget(env, '*type-maker*'); 26 | if (tmaker) fun(t) tmaker(lenv, t) else fun(tp) 'var'(gensym())}} 27 | 28 | \pfcode{ 29 | function genssa2_make_ctype_maker(lenv, env) { 30 | tmaker = ohashget(env, '*ctype-maker*'); 31 | if (tmaker) fun(t, c) tmaker(lenv, t, c) else fun(tp,vl) 'var'(gensym())}} 32 | 33 | \pfcode{ 34 | function genssa2_type_equations(env, lenv, src) 35 | collector(eqadd, eqsget) { 36 | booltp = genssa2_make_boolean_type(env); 37 | mktype = genssa2_make_type_maker(lenv, env); 38 | mkctype = genssa2_make_ctype_maker(lenv, env); 39 | aeq(l, r) = eqadd('equals'(l, r)); 40 | aeqv(l, r) = eqadd('equals'('var'(l), r)); 41 | visit:genssa2(top: src) { 42 | deep top { f -> aeqv('*return*', mktype(ret)) }; 43 | deep argpair: aeqv(name, mktype(t)); 44 | deep oppair: op(name); 45 | deep phiarg(dstreg) { a -> aeqv(dstreg, v)}; 46 | deep switchdst: v; 47 | deep iop(dstreg) { 48 | phi -> iter a in args do a(dstreg) 49 | | select -> {aeqv(dstreg, t); aeqv(dstreg, f)} 50 | | call -> genssa2_intrinsic_equations(lenv, env, eqadd, dstreg, dst, args)}; 51 | deep term { 52 | brc -> aeq(c, booltp) 53 | | switch -> iter n in ns do aeq(v, n) 54 | | else -> []}; 55 | deep expr { 56 | var -> 'var'(id) 57 | | glob -> 'var'(id) 58 | | const -> mkctype(t,v) 59 | | other -> mkctype(t,v)}}; 60 | return eqsget()}} 61 | 62 | \pfcode{ 63 | function genssa2_eqn_to_prolog(e0) 64 | do loop(e = e0) { 65 | match e with 66 | 'var'(nm) -> 'var'(nm) 67 | // A clumsy way to separate 'foo()' from 'foo' 68 | | [one] -> 'term'(%Sm<<("tp__",one), 'term'('tpx__dummy')) 69 | | 'equals'(l,r) -> 'term'('equals', loop(l), loop(r)) 70 | | [tg;@args] -> 'term'(%Sm<<("tp__",tg), @map a in args do loop(a)) 71 | | else -> 'term'(%Sm<<("tp__", e))}} 72 | 73 | \pfcode{ 74 | parser prologtmp (prologlex) { 75 | prologtmp := {"tp__" [constident]:id => id} 76 | / {[constident]:id => wtf(id)};}} 77 | 78 | \pfcode{ 79 | function genssa2_prolog_to_type(d) { 80 | s(id) = 81 | { t = %S<<(prolog_strip_id(id)); 82 | parse t as prologtmp}; 83 | 84 | do loop(e = d) { 85 | match e with 86 | 'var'(id) -> '*type-var*'(id) 87 | | 'term'(id, 'term'('tpx__dummy/0')) -> [s(id)] 88 | | 'term'(id) -> s(id) 89 | | 'term'(id, @args) -> [s(id);@map(loop, args)]}}} 90 | 91 | \pfcode{ 92 | function genssa2_solve_type_equations(env, lenv, eqns) { 93 | prolog = map e in eqns do genssa2_eqn_to_prolog(e); 94 | result = prolog_backend_driver( 95 | ['query'(@prolog)], 96 | %read-compile-eval , 97 | []); 98 | match result with 99 | num:varmap:nextfn -> { 100 | dvars = map [nm;d] in varmap do { 101 | return [nm; genssa2_prolog_to_type(d)]}; 102 | ht = mkhash(); 103 | iter [nm;d] in dvars do ohashput(ht, nm, d); 104 | return ht} 105 | | else -> mkhash() // Failed to type 106 | }} 107 | 108 | %%%%%%%%%%%%% -------------------------------------------------------------------------------- /src/l/core/parsing_0.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | 12 | ;;; Generic parsing combinators. 13 | 14 | ; Sequence combinator 15 | (function p<+> (p1 p2) 16 | "Sequence combinator." 17 | (fun (l) 18 | (let ((r1 (p1 l))) 19 | (if (p-fail? r1) r1 20 | (let ((r2 (p2 (p-rest r1)))) 21 | (if (p-fail? r2) 22 | (p-mkfail `(,(p-result r1) + ,(p-result r2)) l) 23 | (p-mkresult (append (p-result r1) (p-result r2)) (p-rest0 r2)) 24 | )))))) 25 | 26 | 27 | (macro pm<+> parsers 28 | "Sequence combinator, arbitrary number of parsers." 29 | (if (null? parsers) 'p.any 30 | (if (null? (cdr parsers)) (car parsers) 31 | `(p<+> ,(car parsers) (pm<+> ,@(cdr parsers)))))) 32 | 33 | ; Selection combinator 34 | (function p<|> (p1 p2) 35 | "Variant combinator." 36 | (fun (l) 37 | (let ((r1 (p1 l))) 38 | (if (p-success? r1) 39 | r1 40 | (p2 l))))) 41 | 42 | (macro pm<|> parsers 43 | "Variant combinator, arbitrary number of parsers." 44 | (if (null? parsers) 'p.any 45 | (if (null? (cdr parsers)) (car parsers) 46 | `(p<|> ,(car parsers) (pm<|> ,@(cdr parsers)))))) 47 | 48 | ; Negation combinator 49 | (function p (p) 50 | "Negation combinator" 51 | (fun (l) 52 | (if (null? l) (p-mkfail nil nil) 53 | (let ((r (p l))) 54 | (if (p-success? r) 55 | (p-mkfail `(not ,(p-result r)) l) 56 | (p-mkresult (list (car l)) (cdr l))))))) 57 | 58 | ; Multiplication combinator - N.B. - always gives a result. 59 | (int-only 60 | (function p<*> (p) 61 | "Parse none-or-many combinator." 62 | (fun (l) 63 | (let loop ((ll l) (rs nil)) 64 | (let ((r (p ll))) 65 | (if (p-success? r) 66 | (loop (p-rest r) (append rs (p-result r))) 67 | (p-mkresult rs ll)))))) 68 | ) 69 | (cli-only 70 | (function p<*> (p) 71 | "Parse none-or-many combinator." 72 | (fun (l) 73 | (let* ((res (noconst (cons 1 nil))) 74 | (ll l) 75 | (rs res)) 76 | (n.label LBL) 77 | (let ((r (p ll))) 78 | (if (p-success? r) 79 | (begin 80 | (set-cdr! rs (p-result r)) 81 | (n.stloc! rs (lasttail rs)) 82 | (n.stloc! ll (p-rest r)) 83 | (n.goto LBL) ))) 84 | (p-mkresult (cdr res) ll)))) 85 | ) 86 | 87 | ; One-or-many combinator 88 | (function p<+*> (p) 89 | "Parse-one-or-many combinator." 90 | (p<+> p (p<*> p))) 91 | 92 | 93 | ; Result processing combinator 94 | 95 | (function p (p f) 96 | "Parsing result processing combinator." 97 | (fun (l) 98 | (let ((r (p l))) 99 | (if (p-success? r) 100 | (p-mkresult (f (p-result r)) (p-rest0 r)) 101 | r)))) 102 | 103 | (function p (p f) 104 | (fun (l) 105 | (let ((r (p l))) 106 | (if (p-success? r) 107 | (p-mkresult (f (p-result r) (p-rest r)) (p-rest0 r)) 108 | r)))) 109 | 110 | (function p (p f) 111 | (fun (l) 112 | (let ((r (p l))) 113 | (if (p-success? r) 114 | (p-mkresult (f (p-result r) nil) (p-rest0 r)) 115 | r)))) 116 | 117 | 118 | (function p (p) 119 | (fun (l) 120 | (let ((r (p l))) 121 | (if (p-success? r) r 122 | (p-mkresult nil l))))) 123 | 124 | 125 | (function p (p dr) 126 | (fun (l) 127 | (let ((r (p l))) 128 | (if (p-success? r) r 129 | (p-mkresult (list dr) l))))) 130 | 131 | (function p (p) 132 | (fun (l) 133 | (let ((r (p l))) 134 | (if (p-success? r) 135 | (p-mkresult nil l) 136 | (p-mkfail nil l))))) 137 | 138 | -------------------------------------------------------------------------------- /src/l/core/cc-netdefs.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;{{ 11 | (define t_ConstructorInfo (sdotnet "System.Reflection.ConstructorInfo")) 12 | (define t_PairTrap (sdotnet "Meta.Scripting.PairTrap")) 13 | (define mtd_MkSymbol (r_mtd t_Symbol "make" string)) 14 | (define mtd_Cons (r_getconstructor t_Pair object object)) 15 | (define mtd_ConsTrap (r_getconstructor t_PairTrap object object)) 16 | (define mtd_Cons1 (r_getconstructor t_Pair object)) 17 | (define mtd_Cons0 (r_getconstructor t_Pair)) 18 | (define mtd_reg_docstring_macro (r_mtd t_runtime "_doc_register_macro" 19 | t_string 20 | t_string)) 21 | (define mtd_reg_docstring_function (r_mtd t_runtime "_doc_register_function" 22 | t_string 23 | t_string)) 24 | 25 | (net.types RuntimeMethodHandle RuntimeFieldHandle Precompiler Runtime) 26 | 27 | (define mtd_register_method (r_mtd t_runtime "_register_method" t_Symbol t_RuntimeMethodHandle int)) 28 | (define mtd_register_field (r_mtd t_runtime "_register_field" 29 | t_Symbol t_RuntimeFieldHandle t_object)) 30 | 31 | (define mtd_register_macro (r_mtd t_runtime "_register_macro" 32 | t_string t_object)) 33 | 34 | (define fld_True (r_getField t_runtime "_true")) 35 | (define fld_False (r_getField t_runtime "_false")) 36 | 37 | (define fld_funcdocs (r_getField t_runtime "_function_docs")) 38 | (define fld_macrodocs (r_getField t_runtime "_macro_docs")) 39 | 40 | (define f_Assmblys (r_getField t_runtime "assmblys")) 41 | 42 | (define f_Pc_symbols (r_getField t_Precompiler "symbols")) 43 | (define fld_CompMode (r_getField t_runtime "compmode")) 44 | (define m_getSItem (r_mtd (r_GetType (getfuncenv)) "get_Item" t_Symbol)) 45 | (define m_getItem (r_mtd "System.Collections.Hashtable" "get_Item" t_object)) 46 | (define m_hashSetItem (r_mtd "System.Collections.Hashtable" "set_Item" t_object t_object)) 47 | (define m_hashAdd (r_mtd "System.Collections.Hashtable" "Add" t_object t_object)) 48 | (define t_Hashtable (r_typebyname "System.Collections.Hashtable")) 49 | (define ctr_Hashtable (r_getconstructor t_Hashtable)) 50 | 51 | (define m_WriteLine (r_mtd "System.Console" "WriteLine" t_object)) 52 | 53 | (define m_typefromhandle (r_mtd "System.Type" "GetTypeFromHandle" "System.RuntimeTypeHandle")) 54 | 55 | (define m_getassembly (r_mtd "System.Type" "get_Assembly")) 56 | (define m_getassemblyname (r_mtd "System.Reflection.Assembly" "GetName")) 57 | (define m_getassemblyshortname (r_mtd "System.Reflection.AssemblyName" "get_Name")) 58 | 59 | (define f_Cdr (r_getField t_Pair "cdr")) 60 | 61 | (define cc:boot:getenv (r_tsbind t_runtime "_get_comp_hashes")) 62 | 63 | (define get_BaseType (r_tbind t_type "get_BaseType")) 64 | 65 | (define t_AltClosure (dotnet "AltClosure")) 66 | (define r_metod (r_tbind t_Type "GetMethod" string)) 67 | (define r_iclass (r_tbind t_Type "GetNestedType" string)) 68 | (define mtd_Add_Dependency (r_mtd t_Runtime "_add_dep" t_RuntimeMethodHandle)) 69 | 70 | (define _Get_Deps (r_tsbind t_Runtime "_get_dep")) 71 | (define _Clean_Deps (r_tsbind t_Runtime "_clean_dep")) 72 | (define m_Runtime_setargs (r_mtd t_Runtime "setargs" "System.String[]")) 73 | (define m_Runtime_init (r_mtd t_Runtime "iRuntime")) 74 | (define t_string_array (r_typebyname "System.String[]")) 75 | (define __get_Parameters (r_tbind (dotnet "System.Reflection.MethodBase") 76 | "GetParameters")) 77 | 78 | (define mtd_hash (r_mtd t_Symbol "hash" int)) 79 | (define t_ByteArray (r_typebyname "System.Byte[]")) 80 | (function vector? (v) (t_ass? t_ByteArray (r_GetType v))) 81 | (define mtd_InitializeArray (r_mtd "System.Runtime.CompilerServices.RuntimeHelpers" "InitializeArray" "System.Array" "System.RuntimeFieldHandle")) 82 | 83 | ;}} 84 | -------------------------------------------------------------------------------- /src/l/lib/ssa/domtree.hl: -------------------------------------------------------------------------------- 1 | 2 | 3 | // Convert a symbolic graph into a numeric adj matrix 4 | function graph_sym2num_map(gr) 5 | { 6 | ht = mkhash(); 7 | idx = mkref(0); 8 | add(v) = { 9 | chk = ohashget(ht,v); 10 | if(chk) chk else { 11 | n = ^idx; 12 | ohashput(ht, v, n); 13 | idx := n+1; 14 | return n 15 | } 16 | }; 17 | add('entry'); // Must always be 0 18 | hashiter(fun(k,v) { 19 | add(k); iter v do add(v) 20 | }, gr); 21 | return [ht;^idx] 22 | } 23 | 24 | function graph_sym2num(gr) 25 | { 26 | <[m;n]> = graph_sym2num_map(gr); 27 | NN = n*n; 28 | // writeline(#`(graph N = ,n)); 29 | arr = .net(NN): new int[(int)NN]; 30 | put(x,y) = { 31 | notnet(int[] arr, int x, int y, int n) { 32 | arr[x+y*n] = 1; 33 | leave null; 34 | } 35 | }; 36 | get(x,y) = { 37 | notnet(int[] arr, int x, int y, int n) { 38 | leave arr[x+y*n]; 39 | } 40 | }; 41 | hashiter(fun(k,v) { 42 | y = ohashget(m, k); 43 | iter v do { 44 | x = ohashget(m, v); 45 | put(x,y) 46 | } 47 | }, gr); 48 | return [get;put;n;m] 49 | } 50 | 51 | function graph_getpreds(gr, nd) 52 | { 53 | <[get;put;n;m]> = gr; 54 | collector(a,g) { 55 | x = nd; 56 | do loop(y = 0) { 57 | if(y0) a(y); 59 | loop(y+1)}}; 60 | return g()}} 61 | 62 | function sets_intersect_add(gr, ls, nd1) 63 | { 64 | <[get;put;n;m]> = gr; 65 | ar = .net(n): new int[(int)n]; 66 | nb = length(ls); 67 | iter l in ls do { 68 | iter i in l do { 69 | notnet(int[] ar, int i) { 70 | ar[i] = ar[i]+1; 71 | leave null; 72 | } 73 | }}; 74 | collector(Ad, Gt) { 75 | do loop(nn = 0) { 76 | if(nn = gr; 116 | preds = mkhash(); 117 | N = [0..n]; 118 | iter i in N do { 119 | ohashput(preds, i, graph_getpreds(gr, i)) 120 | }; 121 | return [preds;N;n;m] 122 | } 123 | 124 | function graph_dominators(htgr, nd) 125 | { 126 | gr = graph_dominators_i0(htgr, nd); 127 | <[preds;N;n;m]> = gr; 128 | idom = graph_dominators_inner(N, gr, ohashget(m, nd)); 129 | revmap = mkhash(); 130 | hashiter(fun(k,v) {ohashput(revmap, v, k)}, m); 131 | Dom = mkhash(); 132 | hashiter(fun(k,v) { 133 | nk = ohashget(revmap, k); 134 | nv = map v do ohashget(revmap, v); 135 | ohashput(Dom, nk, nv) 136 | }, idom); 137 | return Dom; 138 | } 139 | 140 | 141 | .unittest 1 code: 142 | function test_dominators() 143 | { 144 | g0 = ['entry'('b','c');'b'('b','d0');'d0'('d');'d'('c');'c'('e');'e'('f');['f']]; 145 | gr = mkhash(); 146 | iter g0 do ohashput(gr, car(g0), cdr(g0)); 147 | Dom = graph_dominators(gr, 'entry'); 148 | return hashmap(fun(a,b) [%Sm<<(a);b], Dom); 149 | } 150 | 151 | .unittest 1: (test_dominators()) expect: 152 | #((b (entry b)) (e (entry e c)) (d0 (entry b d0)) 153 | (d (entry b d0 d)) (entry (entry)) (c (entry c)) 154 | (f (entry e f c))) 155 | 156 | -------------------------------------------------------------------------------- /src/l/core/records.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | (Section "Mutable records") 11 | 12 | (macro rec:def (nm . fields) 13 | ( 14 | "Defines a record type [nm] with a list of [fields]." 15 | "To create a new record instance, use the constructor function" 16 | "([nm].new []*)), to get field value, use ([nm].[field] [])," 17 | "Or, alternatively: ([nm].make [: ] ...)" 18 | "to set field value, use ([nm].[field]! [] [])." 19 | ) 20 | (let* ((ar (mapi (fun (i x) (list x i)) fields)) 21 | (l (length ar))) 22 | `(top-begin 23 | (function ,(string->symbol (S<< nm ".new")) 24 | ,fields 25 | (mkovector (list ,@fields))) 26 | (macro ,(string->symbol (S<< nm ".make")) macroarg 27 | (list 'extra:with-optional-args macroarg 28 | (quote ,fields) 29 | (quote (mkovector (list ,@fields))))) 30 | ,@(foreach-map (f fields) 31 | `(function ,(string->symbol (S<< nm "." f)) 32 | (*REC*) 33 | (aget *REC* ,(lookup-env-car ar f)))) 34 | (function ,(Sm<< nm ".copy") (rc) 35 | (,(Sm<< nm ".new") ,@(foreach-map (f fields) 36 | `(,(Sm<< nm "." f) rc)))) 37 | ,@(foreach-map (f fields) 38 | `(function ,(string->symbol (S<< nm "." f "!")) 39 | (*REC* *VAL*) 40 | (asetx *REC* ,(lookup-env-car ar f) *VAL*)))))) 41 | 42 | 43 | ;;;;;; 44 | 45 | (function mkcollector () 46 | (let* ((col (noconst (cons nil nil))) 47 | (sli (noconst (cons nil col))) 48 | (get (fun () (cdr col))) 49 | (add (fun (x) 50 | (set-cdr! (cdr sli) (cons x nil)) 51 | (set-cdr! sli (cdr (cdr sli))) 52 | ))) 53 | (list add get))) 54 | 55 | (macro collector (nms . body) 56 | ("Initialize a collector context, with given adder and getter names." 57 | "Usage: [(collector ( ) *)]" 58 | "Inside the body expressions you can use [( somevalue)] function to" 59 | "collect values in order, and then [()] to return the collected list of values." 60 | "" 61 | "This macro is particularry useful with AST visitors." 62 | ) 63 | 64 | `(format (mkcollector) (,(car nms) ,(cadr nms)) ,@body)) 65 | 66 | 67 | (macro collectors (defs . body) 68 | (if (null? defs) `(begin ,@body) 69 | `(collector ,(car defs) (collectors ,(cdr defs) ,@body)))) 70 | 71 | (macro mkref rest 72 | `(noconst (cons ,(if (null? rest) 'nil (car rest)) nil))) 73 | 74 | (macro noconst (x) x) 75 | 76 | (macro r! (tgt src) 77 | `(set-car! ,tgt ,src)) 78 | 79 | (macro deref (src) 80 | `(car ,src)) 81 | 82 | 83 | (macro with-sequence ( nam . body) 84 | "Creates a gensym sequence within the [body] context." 85 | (with-syms (stor) 86 | `(let* ((,stor (mkref 0)) 87 | (,(car nam) (fun () 88 | (let* ((v (deref ,stor)) 89 | (nv (+ v 1))) 90 | (r! ,stor nv) 91 | (string->symbol 92 | (S<< ,(S<< "sequence_" (car nam) "_") 93 | v "_")))))) 94 | ,@body))) 95 | 96 | ; Unit tests for the functionality above 97 | ; 98 | (unit-test-defn 1 (rec:def recabc a b c)) 99 | 100 | (unit-test 1 (alet x (recabc.new 1 2 3) (recabc.b! x 9) (recabc.b x)) 9) 101 | 102 | (unit-test 1 (let ((r (mkref))) (r! r "xxx") (deref r)) "xxx") 103 | 104 | (unit-test 1 (with-sequence (s) (list (s) (s) (s))) 105 | (sequence_s_0_ 106 | sequence_s_1_ 107 | sequence_s_2_)) 108 | 109 | (unit-test 1 (collector (a g) (a 1) (a 2) (a 3) (g)) (1 2 3)) 110 | 111 | 112 | -------------------------------------------------------------------------------- /src/l/core/cc-optimise.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | 11 | (function cc:simple-thing? ( mt defexpr ) 12 | (use-hash (mt) 13 | (if (mt> (car defexpr)) nil 14 | (case (car (cadr defexpr)) 15 | ((Str Num FNum Chr Bool Symbol Var Nil Arg Glob Recref Funref Clenv) #t) 16 | (else nil))))) 17 | 18 | (function cc:mutables ( expr ) 19 | (with-hash (mb) 20 | (cc:mbcoreast:iter expr expr 21 | (expr DEEP 22 | ((XSet (mb! nm #t)) 23 | (else nil)))) 24 | mb)) 25 | 26 | (function cc:replace-things (things expr) 27 | (with-hash (th) 28 | (iter (fmt (nm vl) (th! nm vl)) things) 29 | (alet fix (fun (v) 30 | (alet tst (th> (cadr v)) 31 | (if tst tst v))) 32 | (cc:mbcoreast:visit expr expr 33 | (expr DEEP 34 | ((Arg (fix node)) 35 | (Var (fix node)) 36 | (Funref (fix node)) 37 | (Recref (fix node)) 38 | (Clenv (fix node)) 39 | (else node))))))) 40 | 41 | (function cc:estimate ( expr ) 42 | (let ((res (noconst (cons 0 nil)))) 43 | (cc:mbcoreast:iter expr expr 44 | (expr DEEP (forall (set-car! res (+ (car res) 1))))) 45 | (car res))) 46 | 47 | (function cc:notreferenced ( expr varn ) 48 | (let ((res (mkref))) 49 | (cc:mbcoreast:iter expr expr 50 | (expr DEEP 51 | ((Recref (if (eqv? varn id) (set-car! res #t))) 52 | (Var (if (eqv? varn id) (set-car! res #t))) 53 | (else nil)))) 54 | (not (car res)))) 55 | 56 | (function cc:arg->var (args expr) 57 | (with-hash (ah) 58 | (foreach (a args) (ah! a a)) 59 | (cc:mbcoreast:visit expr expr 60 | (expr DEEP 61 | ((Arg (if (ah> id) `(Var ,id) node)) 62 | (else node)))))) 63 | 64 | (recfunction cc:optimise ( expr ) 65 | (cc:mbcoreast:visit expr expr 66 | (expr DEEP 67 | ((Begin 68 | (p:match es 69 | (($one) one) 70 | (else node))) 71 | (App 72 | (p:match fn 73 | ((Fun $rn $fnargs $body) 74 | (if (and 75 | (< (length fnargs) 12) 76 | (< (cc:estimate node) 2000) 77 | (or (not rn) (cc:notreferenced body rn))) 78 | (cc:optimise 79 | `(SLet ,(zip (bootlib:filter-args fnargs) args) 80 | ,(cc:arg->var (bootlib:filter-args fnargs) body))) 81 | node)) 82 | (else node))) 83 | (Cons 84 | (p:match (list a b) 85 | (((Nil) (Nil)) 86 | `(Cons0)) 87 | (($a (Nil)) 88 | `(Cons1 ,a)) 89 | (else node))) 90 | (If 91 | (p:match e 92 | ((NullP $a) `(IfNull ,a ,iftr ,iffl)) 93 | ((PairP $a) `(IfPair ,a ,iftr ,iffl)) 94 | ((Not (NullP $a)) `(IfNull ,a ,iffl ,iftr)) 95 | ((Not (PairP $a)) `(IfPair ,a ,iffl ,iftr)) 96 | ((Not (Eqv $a $b)) 97 | `(IfEqv ,a ,b ,iffl ,iftr)) 98 | ((Eqv $a $b) `(IfEqv ,a ,b ,iftr ,iffl)) 99 | ((Not $a) `(If ,a ,iffl ,iftr)) 100 | (else node))) 101 | (SLet 102 | (p:match (list defs body) 103 | (((($name $value)) 104 | (Var =name . $_)) value) 105 | (else 106 | (let* ((mutabs (cc:mutables body)) 107 | (sthings (filter (cut cc:simple-thing? mutabs <>) defs))) 108 | (if sthings ;; there are some 109 | (let ((nw (filter (fun (x) (not (cc:simple-thing? mutabs x))) defs)) 110 | (bdy (cc:replace-things sthings body))) 111 | (cc:optimise 112 | (if nw 113 | `(SLet ,nw ,bdy) 114 | bdy))) 115 | node))))) 116 | (else node))))) 117 | 118 | -------------------------------------------------------------------------------- /src/l/lib/ssa/ssa-fold-algebra.hl: -------------------------------------------------------------------------------- 1 | % literate: 2 | 3 | \section{Tree--form representation of expressions} 4 | 5 | \pfcode{ 6 | ast genssa2tree : genssa2 () { 7 | expr += op(iop:e) 8 | | indvar(ident:id, loopident:l) 9 | | rec();}} 10 | 11 | \pfcode{ 12 | function genssa2_describe_simple(env, defs, indvars, e) { 13 | vis = mkhash(); 14 | subst(r0) = 15 | do loop(r = r0) { 16 | aif (iv = ohashget(indvars, r)) { 17 | 'indvar'(r, iv) 18 | } else if (ohashget(vis, r)) 'var'(r) 19 | else { 20 | ohashput(vis, r, r); 21 | df = ohashget(defs, r); 22 | if (df) { 23 | nop = visit:genssa2(iop: df) { 24 | deep iop { 25 | phi -> [] 26 | | call -> 27 | if (genssa2_is_value_pure(env, node)) node 28 | else [] 29 | | else -> node}; 30 | deep expr { 31 | var -> loop(id) 32 | | else -> node}}; 33 | if (nop) return 'op'(nop) 34 | else return 'var'(r)} 35 | else 'var'(r)}}; 36 | visit:genssa2(expr: e) { 37 | deep expr { 38 | var -> subst(id) 39 | | else -> node}}}} 40 | 41 | \section{Abstracted algebraic representation of expressions} 42 | 43 | Some of the passes may benefit from an abstract algebraic form of expressions, provided by the 44 | external language interface. 45 | 46 | The algebraic language is following: 47 | 48 | \pfcode{ 49 | ast genssa2alg { 50 | aexpr = 51 | // Arithmetic or alike 52 | add(srcop:op, aexpr:l, aexpr:r) 53 | | mul(srcop:op, aexpr:l, aexpr:r) 54 | | div(srcop:op, aexpr:l, aexpr:r) 55 | | mod(srcop:op, aexpr:l, aexpr:r) 56 | | neg(srcop:op, aexpr:l) 57 | | sub(srcop:op, aexpr:l, aexpr:r) 58 | 59 | // Ordering and comparison 60 | | eq(srcop:op, aexpr:l, aexpr:r) 61 | | neq(srcop:op, aexpr:l, aexpr:r) 62 | | gr(srcop:op, aexpr:l, aexpr:r) 63 | | ge(srcop:op, aexpr:l, aexpr:r) 64 | | lt(srcop:op, aexpr:l, aexpr:r) 65 | | le(srcop:op, aexpr:l, aexpr:r) 66 | 67 | // Abstract 68 | | additive(srcop:op, aexpr:l, aexpr:r) 69 | | multiplicative(srcop:op, aexpr:l, aexpr:r) 70 | | zero(any:c) 71 | | one(any:c) 72 | | true(any:c) 73 | | false(any:c) 74 | 75 | // Flow 76 | | select(aexpr:c, aexpr:l, aexpr:r) 77 | 78 | // Bail-out 79 | | fail(expr:e) 80 | 81 | // Atoms 82 | | var(ident:id) 83 | | indvar(ident:id, loopident:l) 84 | | rec() 85 | | const(any:c) 86 | ; 87 | }} 88 | 89 | \pfcode{ 90 | function genssa2_to_algebraic(env, v) { 91 | visit:genssa2tree(expr: v) { 92 | deep iop { 93 | select -> 'select'(cnd, t, f) 94 | | call -> { 95 | cls = genssa2_classify(env, dst); 96 | if (cls) { 97 | return [cls; dst; @args] 98 | } else 'fail'('op'(node))} 99 | | else -> 'fail'('op'(node))}; 100 | deep expr { 101 | op -> e 102 | | var -> 'var'(id) 103 | | indvar -> 'indvar'(id, l) 104 | | rec -> 'rec'() 105 | | const -> 'const'(node) 106 | | else -> 'fail'(node)}}}} 107 | 108 | \pfcode{ 109 | function genssa2_compop_negate(e) { 110 | visit:genssa2alg (aexpr: e) { 111 | once aexpr { 112 | gr -> // !(a>b) = a<=b 113 | 'le'(l,r) 114 | | ge -> // !(a>=b) = a node 119 | } 120 | } 121 | }} 122 | 123 | \pfcode{ 124 | function genssa2_from_algebraic(env, av) { 125 | visit:genssa2alg(aexpr: av) { 126 | deep aexpr { 127 | var -> 'var'(id) 128 | | const -> c 129 | | else -> [] //TODO! 130 | }}}} 131 | 132 | %%%%%%%%%%%% -------------------------------------------------------------------------------- /misc/demos/00calc.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \subsection{00calc.al: immediate interpretation} 12 | ;- 13 | 14 | ;- This version of a calculator mini--language consists of a parser only. 15 | ;- This is the simplest, widely used design, which is suitable for 16 | ;- many types of interpreted DSLs. 17 | ;- 18 | 19 | ;- MBase provides a number of parsing tools. The most basic one is [[]] macro, which 20 | ;- is mostly used in the form of short regular expressions that recognises lexemes. Our lexer will need 21 | ;- a regular expression to recognise the floating point numbers syntax, so here is a definition: 22 | (define p.double 23 | ( ((p.digit +*) (?? ("." (p.digit +*)))) 24 | -> list->string)) 25 | ;- [[]] is a special mini--language macro. It unrolls into a code, which uses recursive descent 26 | ;- parsing combinators. ``[[+*]]'' postfix operator generates ``one--or--many'' combinator, ``[[??]]'' is for 27 | ;- ``maybe'' combinator, ``[[->]]'' infix defines a transformation combinator for a parsing result, 28 | ;- in our case -- collecting recognised characters into a string. 29 | ;- 30 | ;- A higher level macro [[make-simple-lexer]] is provided for defining lexers. 31 | ;- It is suitable in case your language has whitespaces to 32 | ;- ignore (including comments), identifiers, keywords which forms a subset of identifiers, simple string lexemes 33 | ;- and regular expression recogniseable lexemes. Most languages fits into this scheme. 34 | (make-simple-lexer calclexer 35 | 36 | ;= Simple lexemes are just strings. Definitions goes as pair, at first a string 37 | ;= and then a token. I.e., here ``[[-]]'' lexeme produces [[MINUS]] token. 38 | (simple-tokens 39 | "-" MINUS "(" LB ")" RB 40 | ) 41 | ;= These are more complex cases, token recognisers are defined using the language of [[]] macro. 42 | ;= Definitions are also paired in the same way as for [[simple-tokens]]. 43 | (regexp-tokens 44 | (("+") -> list->symbol) OP1 45 | (("*" | "/") -> list->symbol) OP2 46 | p.double number) 47 | ;= And here are regular expressions to ignore totally, i.e. whitespaces: 48 | (ignore p.whitespace) 49 | ) 50 | 51 | ;- Tokens from a lexer are represented as symbols (N.B. [[list->symbol]] used above), so we 52 | ;- can dispatch them into a floating point arightmetic functions easily: 53 | (function getop (x) 54 | (case x 55 | ((+) f+) ((-) f-) ((*) f*) ((/) f/))) 56 | 57 | ;- And now we will implement a parser and an interpreter in single pass. 58 | ;- MBase provides a special mini--language for 59 | ;- defining simple parsers in BNF--like format. First argument of [[bnf-parser]] macro is a list 60 | ;- of entry points to be exported as functions. It means that [[calcparser]] will be defined for 61 | ;- a parser that accepts [[expr]] syntax. All the rest inside [[bnf-parser]] is a list of entries, 62 | ;- each entry contains patterns and expressions to be evaluated if a pattern is matched. 63 | (bnf-parser ((expr calcparser)) 64 | ;= Top level expression entry, recognising low priority operations (``[[+]]'', ``[[-]]'') first. ``[[MINUS]]'' is 65 | ;= a separate entity here because it can be seen as unary operation as well. 66 | (expr 67 | ((term:l MINUS expr:r) (f- l r) ) 68 | ((term:l OP1:o expr:r) ((getop o) l r) ) 69 | ((term) $0)) 70 | ;= Intermediate expressions entry, dealing with highest priority operations (``[[*]]'', ``[[/]]''). 71 | (term 72 | ((fact:l OP2:o term:r) ((getop o) l r)) 73 | ((fact) $0)) 74 | ;= Atomic expressions, including unary negation. 75 | (fact 76 | ((LB expr:x RB) x) 77 | ((number) (flt:parse $0)) 78 | ((MINUS fact:e) (f- (f# "0.0") e))) 79 | ) 80 | 81 | ;- And now we can use this interpreter by calling a special function [[lex-and-parse]], which 82 | ;- applies a lexer to a string or a stream and applies a given parser to a resulting tokens stream. 83 | (writeline 84 | (lex-and-parse 85 | calclexer 86 | calcparser 87 | "(2+2*2)/1.1")) 88 | -------------------------------------------------------------------------------- /src/l/core/compiler.al: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; 3 | ;; OpenMBase 4 | ;; 5 | ;; Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | ;; 7 | ;; 8 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 9 | 10 | ;- 11 | ;- \section{$L_1'$ compiler} 12 | ;- 13 | 14 | (Section "Compiler") 15 | 16 | ;- 17 | ;- First, some utility functions. 18 | ;- 19 | ;= Report a compiler specific error, to be processed in a main loop. 20 | (function cc:comperror (e) 21 | (ccerror `(COMP ,e))) 22 | 23 | (define t_ass? 24 | (r_tbind "System.Type" "IsAssignableFrom" "System.Type")) 25 | 26 | ;- 27 | ;- 28 | ;- 29 | 30 | (include "./cc-netdefs.al");-I 31 | (include "./cc-ast.al");-I 32 | (include "./cc-core.al");-I 33 | (force-class-flush) 34 | (include "./cc-tail.al");-I 35 | (force-class-flush) 36 | (include "./cc-transforms.al");-I 37 | (include "./cc-optimise.al");-I 38 | (include "./cc-cons.al");-I 39 | (force-class-flush) 40 | (include "./cc-ast-flat.al");-I 41 | (include "./cc-flat.al");-I 42 | (force-class-flush) 43 | (include "./cc-schedule.al");-I 44 | (force-class-flush) 45 | (expand-if (shashget (getfuncenv) 'compiler-final) 46 | (include "./cc-funcache.al");-I 47 | ) 48 | 49 | (include "./cc-plugins.al");-I 50 | 51 | (function cc:compile-stage1 ( env expr ) 52 | ("Performs the first stage of compilation, taking a Core AST as a source" 53 | "and producing a Flat output." 54 | "This stage does not depend on any environment and guaranteed to be stable" 55 | "against given source." 56 | ) 57 | (<> expr 58 | (pipeline> 59 | cc:scope-transform ; make unique names 60 | (fun (e) 61 | (ctime 62 | (if (shashget (getfuncenv) 'compiler-final) 63 | '(cc:constant-fold (cc:optimise e)) 64 | 'e))) 65 | ;;TODO 66 | ;(fun (e) 67 | ; (cc:resolve-globals env e)) 68 | (fun (e) 69 | (when (shashget (getfuncenv) 'debug-compiler-prelift) 70 | 71 | (println '-PRE-LIFT-) 72 | (iter writeline e) 73 | (println '-------------------PRE-LIFT)) 74 | e 75 | ) 76 | 77 | cc:pre-lift-plugins ; Call pre-lifting user code 78 | 79 | cc:lift-lambdas ; lift nested lambda expressions 80 | cc:clean-dummy ; remove trash to maintain correct return values 81 | cc:fix-closures ; add references to closure captured variables 82 | ; and perform tail calls optimisation 83 | 84 | cc:after-lift-plugins ; Call post-lifting user code 85 | (fun (e) 86 | (when (shashget (getfuncenv) 'debug-compiler-postlift) 87 | (println '-POST-LIFT-) 88 | (iter writeline e) 89 | (println '-------------------POST-LIFT)) 90 | e 91 | ) 92 | 93 | (fun (e) 94 | (ctime 95 | (if (shashget (getfuncenv) 'compiler-final) 96 | '(cc:cachetop env e) 97 | 'e))) 98 | cc:compile-lifted ; compile into flat pseudocode 99 | 100 | cc:flat-plugins ; Call flat stage user code 101 | 102 | (fun (e) 103 | (when (shashget (getfuncenv) 'debug-compiler-flat0) 104 | (println '-PRE-SCHEDULE-) 105 | (iter writeline e) 106 | (println '-------------------PRE-SCHEDULE)) 107 | e 108 | ) 109 | (fun (e) 110 | (if (and (shashget (getfuncenv) 'core-environment-compiled) 111 | (not (shashget (getfuncenv) 'compiler-scheduler-off))) 112 | (cc:lifted-reschedule e) ; get rid of redundant local variables 113 | e)) 114 | (fun (e) 115 | (when (shashget (getfuncenv) 'debug-compiler-flat) 116 | (println '-FLAT-) 117 | (iter writeline e) 118 | (println '-------------------FLAT)) 119 | e 120 | ) 121 | ))) 122 | 123 | ;- 124 | ;- Compiler backend components 125 | ;- 126 | 127 | (force-class-flush) 128 | (include "./cc-environment.al");-I 129 | (force-class-flush) 130 | (include "./cc-dotnet.al");-I 131 | (force-class-flush) 132 | (include "./cc-driver.al");-I 133 | (force-class-flush) 134 | (include "./binder.al");-I 135 | -------------------------------------------------------------------------------- /src/l/lib/pfront/sexp.hl: -------------------------------------------------------------------------------- 1 | ////////////////////////////////////////////////////////////////////////////// 2 | // 3 | // OpenMBase 4 | // 5 | // Copyright 2005-2017, Meta Alternative Ltd. All rights reserved. 6 | // 7 | // 8 | ////////////////////////////////////////////////////////////////////////////// 9 | 10 | define %peg-function-lspcharval = 11 | fun(ch) { 12 | v0 = cddr(%string->list(cdr(ch))); 13 | v = %list->string(v0); 14 | match %string->symbol(v) with 15 | 'Newline' -> 10c 16 | | 'Tab' -> 7c 17 | | 'Space' -> 32c 18 | | 'LBR' -> '('c 19 | | 'RBR' -> ')'c 20 | | 'Semicolon' -> ';'c 21 | | else -> car(v0); 22 | }; 23 | 24 | define %peg-function-booltrue = 25 | fun() { true }; 26 | 27 | define %peg-function-boolfalse = 28 | fun() { false }; 29 | 30 | parser mbsexp ( pfront ) { 31 | !!SXSpaces; 32 | 33 | // Inherited 34 | @@Letter := [a-z]/[A-Z]; 35 | @@Digit := [0-9]; 36 | @@Digits := [Digit]+; 37 | @@SXSpace := " " / [TAB] / [CR] / [NEWLINE] / [InlineTexComment] / 38 | [SingleLineTexComment] / [SingleLineComment]; 39 | @@SXSpaces := [SXSpace]+; 40 | @@SingleLineComment := ";" (![NEWLINE] .)* [NEWLINE] => {state=comment}; 41 | @@SingleLineTexCommentBegin := ";" "*" => {state = empty}; 42 | @@SingleLineTexCommentRest := (![NEWLINE] .)* [NEWLINE] => {screen=none}; 43 | @@SingleLineTexComment := 44 | [SingleLineTexCommentBegin] [SingleLineTexCommentRest]; 45 | @@InlineTexComment := [TexComment2Begin] [TexComment2Rest] [TexComment2End]; 46 | @@QUOTE := 39; 47 | @tQUOTE := 39; 48 | @@DQUOTE := 34; 49 | @@BSDQUOTE := "\" 34; 50 | @tDQUOTE := 34; 51 | 52 | @@NEWLINE := 10; 53 | @@CR := 13; 54 | @@TAB := 9; 55 | @tNumber := "-"? [Digit]+; 56 | number := [tNumber]:v => {ctoken = const} $nval(v); 57 | @tString := [DQUOTE] ("\\"/[BSDQUOTE]/( ![DQUOTE] . )) * [DQUOTE]; 58 | string := [tString]:t => {ctoken = const} $stringdescreen($stripval(t)); 59 | // /////////////////////////////////////////////////////////// 60 | 61 | @lspchar := "#\" . ([Letter] *); 62 | 63 | @@sxsymbegin := ([Letter] / "_" / "-" / "+" / "*" / "@" / "=" / "?" / 64 | "/" / "$" / "<" / ">" / "%" / ":" / "!" / "|" / 65 | "&" / "[" / "]" / "#" / "~"); 66 | @@sxsymrest := ([sxsymbegin]/ [Digit] / "@" / "." / ","); 67 | 68 | @sxsymbol1 := ([sxsymbegin] [sxsymrest]*) (?:mbaseglobal); 69 | @sxsymbol2 := ([sxsymbegin] [sxsymrest]*) (?:mbasemacro); 70 | @sxsymbol3 := ([sxsymbegin] [sxsymrest]*); 71 | @sxndots := ".." [sxsymrest]*; 72 | @onedot := "." (!".") => {ctoken=lexic}; 73 | 74 | sxsymbol := 75 | { [sxsymbol2]:s => {ctoken=lexic} $sval(s)} 76 | / { [sxsymbol1]:s => {ctoken=keyword} $sval(s)} 77 | / { [sxsymbol3]:s => {ctoken=ident} $sval(s)} 78 | / { [sxndots]:s => {ctoken=lexic} $sval(s) } 79 | ; 80 | 81 | [lexical:] := [lexical] => {ctoken = lexic}; 82 | 83 | sxnde := {"(" ")" => $nil()} 84 | / {"(" [sxndx]:x ")" => x} 85 | 86 | / {",@" [sxnde]:a => "unquote-splicing"(a) } 87 | / {"," [sxnde]:a => "unquote"(a) } 88 | / {"`" [sxnde]:a => "quasiquote"(a) } 89 | / {"=pf:" [atopexpr]:e => "pfront_top_ast"(e)} 90 | / {[tQUOTE] [sxnde]:a => "quote"(a) } 91 | 92 | / {[lspchar]:c => $lspcharval(c) } 93 | / {"#t" => $booltrue() } 94 | / {"#f" => $boolfalse() } 95 | / {[number]:n => n } 96 | / {[sxsymbol]:s => s } 97 | / {[string]:s => s} 98 | ; 99 | sxndx := {[sxnde]:a [onedot] [sxnde]:b => $cons(a,b)} 100 | / {[sxnde]:a [sxndx]:b => $cons(a,b)} 101 | / {[sxnde]:x => $wrap(x)} 102 | ; 103 | mbsexp := [sxnde]:e [SXSpaces]* => e; 104 | } 105 | 106 | 107 | syntax in expr, start ( mbsexp ): ' "#" [sxnde]:e ' 108 | { 109 | ['lisp';e] 110 | } 111 | 112 | syntax in expr, start ( mbsexp ): ' "!#" [sxnde]:e ' 113 | { 114 | e 115 | } 116 | 117 | macro pfront_top_ast (e) 118 | { 119 | %hlevel-compile(e); 120 | } 121 | --------------------------------------------------------------------------------