├── LICENSE ├── README.md ├── bench ├── .bcdrc ├── .exrc ├── FastTimes30000 ├── Notes ├── Readme ├── SlowTimes30000 ├── Times30000 ├── bst.pns ├── bstmain.pns ├── cbst.c ├── cpbst.c ├── cpibst.c ├── cpigbst.c ├── cpinfbst.c ├── gcbst.c ├── hspbst.hs ├── hsrbst.hs ├── hssbst.hs ├── makefile ├── ml │ ├── mlpbst.sml │ ├── mlrbst.sml │ └── mltbst.cml ├── mlpbst.sml ├── mlrbst.sml └── pbst.pns ├── compiler ├── .bcdrc ├── .exrc ├── Bugs ├── README.md.src ├── Readme ├── Readme.src ├── apply.adt ├── apply.c ├── apply.h ├── apply1.pns ├── builtin.adt ├── builtin.h ├── comp.pl ├── makefile ├── pawns.h └── pawns.pl └── examples ├── .bcdrc ├── Readme ├── addlist.pns ├── apply.c ├── array.pns ├── arrayc.c ├── bst.pns ├── bst1.pns ├── bst_a.pns ├── bst_main.c ├── bst_poly.pns ├── c2pawns.sed ├── cord.pns ├── cord_poly.pns ├── duspec.pns ├── eval.pns ├── evalp.pns ├── ho.pns ├── io.pns ├── isort.pns ├── isort_main.c ├── makefile ├── map.pns ├── mod.pns ├── mod1.pns ├── mod2.pns ├── mod3.pns ├── p1bst.pns ├── pbst.pns ├── pres.pns ├── random.pns ├── rectype.pns ├── state.pns ├── t.pns ├── test.pns ├── testio.pns ├── testq.pns ├── testuf.pns ├── tuple.pns ├── union_find.pns ├── wam.pns └── wam_main.c /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 lee-naish 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Pawns, version 1.250416 2 | 3 | Pawns (Pointer Assignment Without Nasty Surprises) is a 4 | declarative/imperative language. It supports typical features of a strict 5 | functional language such as algebraic data types, polymorphism, higher 6 | order programming and pure (referentially transparent) functions. It also 7 | supports imperative features such as destructive update via pointers and 8 | a form of global variables (including IO). Unlike other declarative/imperative 9 | languages, all data constructor arguments can have pointers to them and 10 | be updated, all side-effects in the code are made obvious by annotations 11 | and impure code can be encapsulated inside a pure function. The 12 | compiler checks annotations and purity by analysis of data structure 13 | sharing. Functions that may update their arguments have additional 14 | declarations concerning update and sharing. 15 | 16 | Language and implementation by 17 | [Lee Naish](https://lee-naish.github.io/). 18 | It's basicaly a proof of concept for what I think are some neat language 19 | ideas that tackle a difficult problem in programming language design - 20 | definitely not a polished product! 21 | 22 | # Pawns home page 23 | Since 2022 the home page has been https://lee-naish.github.io/src/pawns/ 24 | (tinyurl.com/pawns-lang points to an outdated version). 25 | This has links to (among other things): 26 | 27 | - A brief overview of the language: 28 | This is not necessarily up to date, misses some features, 29 | and the syntax is not what is supported - see note below. 30 | 31 | - An informal introduction to the language: 32 | Older than the overview and much harder to read but covers a few more 33 | things. 34 | 35 | - Slides for a couple of talks 36 | 37 | - A paper on the sharing analysis done in the compiler: 38 | The implementation 39 | here has some known bugs corrected in the paper, meaning you can write 40 | dodgey code and the compiler won't complain as it should. See comments 41 | in the source code. However, it also has some enhancements to make sharing 42 | more precise, meaning you can write correct code that passes the compiler 43 | even though the analysis in the paper would result in error messages. 44 | The paper may be updated to reflect this at some point. 45 | 46 | 47 | # Requirements 48 | 49 | The system is also not packaged well currently. My development machine 50 | is laptop running Ubuntu. I've not ported it elsewhere but after doing 51 | several years worth of upgrades it still built with no problems so the 52 | Ubuntu build seems to be on solid foundations. If you can't get it to 53 | work on your chosen platform I will gladly return your money but not 54 | return your time:( 55 | It needs 56 | 57 | - 1) SWI-Prolog: 58 | See https://www.swi-prolog.org/build/unix.html, eg 59 | sudo apt-get install software-properties-common 60 | sudo apt-add-repository ppa:swi-prolog/stable 61 | sudo apt-get update 62 | sudo apt-get install swi-prolog 63 | 64 | - 2) Boehm et al. garbage collector: 65 | sudo apt-get install libgc-dev 66 | 67 | - 3) adtpp tool installed in ~/bin/adtpp: 68 | This is in a public git 69 | repository and requires flex, yacc and gcc. 70 | sudo apt-get install git 71 | git clone https://github.com/lee-naish/adtpp 72 | sudo apt install flex 73 | sudo apt install bison 74 | mkdir ~/bin 75 | cd adtpp/src 76 | make install 77 | 78 | - 4) pawns.h in current directory 79 | 80 | - 5) gcc (other C compilers should be ok also) 81 | 82 | 83 | # Repository contents 84 | 85 | - compiler/: 86 | Source for compiler, pnsc. 87 | "pnsc foo.pns" will compile foo.pns to foo.c and foo.adt (algebraic data 88 | type definitions that adtpp will convert to C). See examples/makefile 89 | for make convenient rules etc 90 | To install the compiler in ~/bin, use: 91 | "cd compiler 92 | make install" 93 | 94 | - examples/: 95 | Example Pawns code (with makefile and other files needed etc) 96 | 97 | - bench: 98 | Some benchmarks (binary tree insertion...) in various languages 99 | 100 | 101 | # Syntax 102 | 103 | People have always argued way too much about the syntax of programming 104 | languages, at the expense of semantics, which is the important thing. 105 | What was that Phil Wadler quote...? There are two things I have done 106 | which may counter this trend for Pawns. First, the papers written so far 107 | have used a fake syntax based on Haskell. Second, I think we can *all* 108 | agree that the actual supported syntax is awful. It was chosen to make 109 | the implementation easy - I had better things to do than write a parser 110 | (which would also require more serious thoughts about syntax) so I just 111 | used Prolog syntax with a bunch of operators declared and used 'read' 112 | in Prolog to do all the parsing. This means various things need to be 113 | terminated with '.', the Prolog tokeniser is used, and various things 114 | need parentheses or braces. I have not properly described the syntax - 115 | best look at examples for now. However, none of this is set in stone. 116 | The start of a Pawns source code file, up to the first blank line, 117 | is ignored as far as code is concerned. It can be used for a #! line, 118 | meta-data, directives etc. These could include a directive to say what 119 | syntax is used in the rest of the file. Currently its just ignored, 120 | so best make sure you start with a block of comments or at least a blank 121 | line, or your first bit of code will mysteriously get ignored. 122 | 123 | -------------------------------------------------------------------------------- /bench/.bcdrc: -------------------------------------------------------------------------------- 1 | alias mkT='make all ; make times >& Times30000' 2 | alias mT='more Times30000' 3 | -------------------------------------------------------------------------------- /bench/.exrc: -------------------------------------------------------------------------------- 1 | set exrc 2 | set ts=8 noet 3 | set ts=4 et 4 | map !! :w :!latex tplp;dvips tplp 5 | map !! :w :!latex tplp 6 | map !! :w :!latex talk;dvips talk 7 | map !! :w :!latex talk 8 | set wrapmargin=8 9 | set wrapscan 10 | map !w :set wrapmargin=0 nowrapscan 11 | map q :wq 12 | map N :w :n 13 | map z :w  14 | map %$ :'c,.s/^/% / 15 | map %^ :'c,.s/^% // 16 | map %t :%s/ / /g 17 | map , Ea,' 18 | map !d :.! date 19 | map !u :.! date -u 20 | map !q Bi``Ea'' 21 | map !t Bi\texttt{Ea} 22 | map !v Bi\verb@Ea@ 23 | map !c Bi\cite{Ea} 24 | map !b bi\textbf{ea} 25 | map !i bi\emph{ea} 26 | map !e :s/^.*$/& &/ i\end{A}-i\begin{A}a 27 | map !r :s/^.*$/& &/ A-i+A 28 | map !f !{fmt 29 | map !h1 0i\section{$a} 30 | map !h2 0i\subsection{$a} 31 | map !h3 0i\subsubsection{$a} 32 | ab veR \begin{verbatim} \end{verbatim} 33 | ab itE \begin{itemize} \item \end{itemize} 34 | ab enU \begin{enumerate} \item \end{enumerate} 35 | ab taB \begin{tabular}{lr} \end{tabular} 36 | ab fiG \begin{figure} \begin{center} \end{center} % \caption{} \label{fig_f} \end{figure} 37 | ab bwS \begin{bwslide} \Heading{x} \end{bwslide} 38 | ab iT \item 39 | -------------------------------------------------------------------------------- /bench/FastTimes30000: -------------------------------------------------------------------------------- 1 | echo 2 | 3 | echo '------------ Pawns with DU' 4 | ------------ Pawns with DU 5 | time ./bst 6 | 30000 7 | Command exited with non-zero status 6 8 | 1.10user 0.00system 0:01.11elapsed 99%CPU (0avgtext+0avgdata 3496maxresident)k 9 | 0inputs+0outputs (0major+935minor)pagefaults 0swaps 10 | make: [times] Error 6 (ignored) 11 | echo 12 | 13 | echo '------------ C with malloc, DU' 14 | ------------ C with malloc, DU 15 | time ./cbst 16 | 30000 17 | Command exited with non-zero status 6 18 | 2.22user 0.01system 0:02.24elapsed 99%CPU (0avgtext+0avgdata 3508maxresident)k 19 | 0inputs+0outputs (0major+938minor)pagefaults 0swaps 20 | make: [times] Error 6 (ignored) 21 | echo 22 | 23 | echo '------------ MLton with Ref, DU' 24 | ------------ MLton with Ref, DU 25 | time ./mlrbst 26 | 30000 27 | 3.28user 0.00system 0:03.29elapsed 99%CPU (0avgtext+0avgdata 4960maxresident)k 28 | 0inputs+0outputs (0major+1501minor)pagefaults 0swaps 29 | echo 30 | 31 | echo '------------ Haskell with STRef, DU' 32 | ------------ Haskell with STRef, DU 33 | time ./hsrbst 34 | 30000 35 | 4.80user 0.00system 0:04.81elapsed 99%CPU (0avgtext+0avgdata 7528maxresident)k 36 | 0inputs+0outputs (0major+1971minor)pagefaults 0swaps 37 | echo 38 | 39 | echo '------------ MLton no DU' 40 | ------------ MLton no DU 41 | time ./mlpbst 42 | 30000 43 | 7.44user 0.15system 0:07.60elapsed 99%CPU (0avgtext+0avgdata 42868maxresident)k 44 | 0inputs+0outputs (0major+64775minor)pagefaults 0swaps 45 | echo 46 | 47 | echo '------------ Pawns no DU' 48 | ------------ Pawns no DU 49 | time ./pbst 50 | 30000 51 | Command exited with non-zero status 6 52 | 16.25user 0.00system 0:16.29elapsed 99%CPU (0avgtext+0avgdata 39336maxresident)k 53 | 0inputs+0outputs (0major+9897minor)pagefaults 0swaps 54 | make: [times] Error 6 (ignored) 55 | echo 56 | 57 | echo '------------ C iterative GC_malloc no free no DU' 58 | ------------ C iterative GC_malloc no free no DU 59 | time ./cpinfbst 60 | 30000 61 | Command exited with non-zero status 6 62 | 15.44user 0.00system 0:15.45elapsed 99%CPU (0avgtext+0avgdata 4572maxresident)k 63 | 0inputs+0outputs (0major+1205minor)pagefaults 0swaps 64 | make: [times] Error 6 (ignored) 65 | echo 66 | 67 | echo '------------ Haskell with seq but no DU' 68 | ------------ Haskell with seq but no DU 69 | time ./hssbst 70 | 30000 71 | 21.75user 0.01system 0:21.79elapsed 99%CPU (0avgtext+0avgdata 6476maxresident)k 72 | 0inputs+0outputs (0major+1716minor)pagefaults 0swaps 73 | echo 74 | 75 | echo '------------ C iterative GC_malloc no DU' 76 | ------------ C iterative GC_malloc no DU 77 | time ./cpigbst 78 | 30000 79 | Command exited with non-zero status 6 80 | 22.13user 0.00system 0:22.15elapsed 99%CPU (0avgtext+0avgdata 3532maxresident)k 81 | 0inputs+0outputs (0major+944minor)pagefaults 0swaps 82 | make: [times] Error 6 (ignored) 83 | echo 84 | 85 | echo '------------ C iterative no DU' 86 | ------------ C iterative no DU 87 | time ./cpibst 88 | 30000 89 | Command exited with non-zero status 6 90 | 21.85user 0.00system 0:21.87elapsed 99%CPU (0avgtext+0avgdata 3528maxresident)k 91 | 0inputs+0outputs (0major+944minor)pagefaults 0swaps 92 | make: [times] Error 6 (ignored) 93 | echo 94 | 95 | echo '------------ C no DU' 96 | ------------ C no DU 97 | time ./cpbst 98 | 30000 99 | Command exited with non-zero status 6 100 | 28.61user 0.00system 0:28.63elapsed 99%CPU (0avgtext+0avgdata 4564maxresident)k 101 | 0inputs+0outputs (0major+1203minor)pagefaults 0swaps 102 | make: [times] Error 6 (ignored) 103 | echo 104 | 105 | echo '------------ Haskell no DU' 106 | ------------ Haskell no DU 107 | time ./hspbst 108 | 30000 109 | 51.36user 0.08system 0:51.50elapsed 99%CPU (0avgtext+0avgdata 6472maxresident)k 110 | 0inputs+0outputs (0major+1716minor)pagefaults 0swaps 111 | -------------------------------------------------------------------------------- /bench/Notes: -------------------------------------------------------------------------------- 1 | Various versions of binary search tree insertion. 2 | 3 | Possibly should try C version which mirrors the "pure" versions, ie it 4 | does a malloc for each node as it traverses down the branch. 5 | 6 | Why is MLton pure version so much faster than pure Pawns version? Is it 7 | that the Pawns code is so nasty gcc can't do a good job, or is GC_malloc 8 | much slower than the equivalent in MLton? 9 | 10 | Could try OCAML version with mutable fields in records to avoid extra 11 | refs, but program structure has to change (somewhat painful, like 12 | inelegant C versions). 13 | 14 | Also a Disciple version?? 15 | 16 | Its puzzling that the C versions are so much slower than the Pawns 17 | version. Could potentially do low level profiling?? 18 | -------------------------------------------------------------------------------- /bench/Readme: -------------------------------------------------------------------------------- 1 | Benchmarks for Pawns 2 | 3 | Currently just a whole bunch of different versions of binary search tree 4 | insertion, in Pawns, C, Haskell, ML 5 | -------------------------------------------------------------------------------- /bench/SlowTimes30000: -------------------------------------------------------------------------------- 1 | echo '------------ Pawns with destructive update' 2 | ------------ Pawns with destructive update 3 | time ./bst 4 | 30000 5 | Command exited with non-zero status 6 6 | 4.83user 0.01system 0:04.86elapsed 99%CPU (0avgtext+0avgdata 3492maxresident)k 7 | 0inputs+0outputs (0major+936minor)pagefaults 0swaps 8 | make: [times] Error 6 (ignored) 9 | echo '------------ C with malloc' 10 | ------------ C with malloc 11 | time ./cbst 12 | 30000 13 | Command exited with non-zero status 6 14 | 9.90user 0.00system 0:09.93elapsed 99%CPU (0avgtext+0avgdata 3504maxresident)k 15 | 0inputs+0outputs (0major+937minor)pagefaults 0swaps 16 | make: [times] Error 6 (ignored) 17 | echo '------------ C with GC_malloc' 18 | ------------ C with GC_malloc 19 | time ./gcbst 20 | 30000 21 | Command exited with non-zero status 6 22 | 9.86user 0.01system 0:09.89elapsed 99%CPU (0avgtext+0avgdata 3496maxresident)k 23 | 0inputs+0outputs (0major+935minor)pagefaults 0swaps 24 | make: [times] Error 6 (ignored) 25 | echo '------------ MLton with Ref' 26 | ------------ MLton with Ref 27 | time ./mlrbst 28 | 30000 29 | 14.35user 0.05system 0:14.42elapsed 99%CPU (0avgtext+0avgdata 4892maxresident)k 30 | 0inputs+0outputs (0major+989minor)pagefaults 0swaps 31 | echo '------------ Haskell with STRef' 32 | ------------ Haskell with STRef 33 | time ./hsrbst 34 | 30000 35 | 21.71user 0.01system 0:21.79elapsed 99%CPU (0avgtext+0avgdata 7532maxresident)k 36 | 0inputs+0outputs (0major+1971minor)pagefaults 0swaps 37 | echo '------------ MLton without destructive update' 38 | ------------ MLton without destructive update 39 | time ./mlpbst 40 | 30000 41 | 31.52user 0.95system 0:32.64elapsed 99%CPU (0avgtext+0avgdata 42788maxresident)k 42 | 0inputs+8outputs (0major+25205minor)pagefaults 0swaps 43 | echo '------------ Pawns without destructive update' 44 | ------------ Pawns without destructive update 45 | time ./pbst 46 | 30000 47 | Command exited with non-zero status 6 48 | 69.42user 0.05system 1:09.70elapsed 99%CPU (0avgtext+0avgdata 39564maxresident)k 49 | 0inputs+0outputs (0major+5864minor)pagefaults 0swaps 50 | make: [times] Error 6 (ignored) 51 | echo '------------ C iterative without destructive update' 52 | ------------ C iterative without destructive update 53 | time ./cpibst 54 | 30000 55 | Command exited with non-zero status 6 56 | 102.00user 0.02system 1:42.25elapsed 99%CPU (0avgtext+0avgdata 3532maxresident)k 57 | 0inputs+0outputs (0major+944minor)pagefaults 0swaps 58 | make: [times] Error 6 (ignored) 59 | echo '------------ C without destructive update' 60 | ------------ C without destructive update 61 | time ./cpbst 62 | 30000 63 | Command exited with non-zero status 6 64 | 131.77user 0.02system 2:12.09elapsed 99%CPU (0avgtext+0avgdata 4564maxresident)k 65 | 0inputs+0outputs (0major+1202minor)pagefaults 0swaps 66 | make: [times] Error 6 (ignored) 67 | echo '------------ Haskell with seq but without destructive update' 68 | ------------ Haskell with seq but without destructive update 69 | time ./hssbst 70 | 30000 71 | 102.45user 0.22system 1:43.03elapsed 99%CPU (0avgtext+0avgdata 6472maxresident)k 72 | 0inputs+0outputs (0major+1717minor)pagefaults 0swaps 73 | echo '------------ Haskell without destructive update' 74 | ------------ Haskell without destructive update 75 | time ./hspbst 76 | 30000 77 | 235.07user 0.40system 3:56.23elapsed 99%CPU (0avgtext+0avgdata 6472maxresident)k 78 | 0inputs+0outputs (0major+1716minor)pagefaults 0swaps 79 | -------------------------------------------------------------------------------- /bench/Times30000: -------------------------------------------------------------------------------- 1 | echo 2 | 3 | echo '------------ Pawns with DU' 4 | ------------ Pawns with DU 5 | time ./bst 6 | 30000 7 | Command exited with non-zero status 6 8 | 1.10user 0.00system 0:01.11elapsed 99%CPU (0avgtext+0avgdata 3496maxresident)k 9 | 0inputs+0outputs (0major+935minor)pagefaults 0swaps 10 | make: [times] Error 6 (ignored) 11 | echo 12 | 13 | echo '------------ C with malloc, DU' 14 | ------------ C with malloc, DU 15 | time ./cbst 16 | 30000 17 | Command exited with non-zero status 6 18 | 2.22user 0.01system 0:02.24elapsed 99%CPU (0avgtext+0avgdata 3508maxresident)k 19 | 0inputs+0outputs (0major+938minor)pagefaults 0swaps 20 | make: [times] Error 6 (ignored) 21 | echo 22 | 23 | echo '------------ MLton with Ref, DU' 24 | ------------ MLton with Ref, DU 25 | time ./mlrbst 26 | 30000 27 | 3.28user 0.00system 0:03.29elapsed 99%CPU (0avgtext+0avgdata 4960maxresident)k 28 | 0inputs+0outputs (0major+1501minor)pagefaults 0swaps 29 | echo 30 | 31 | echo '------------ Haskell with STRef, DU' 32 | ------------ Haskell with STRef, DU 33 | time ./hsrbst 34 | 30000 35 | 4.80user 0.00system 0:04.81elapsed 99%CPU (0avgtext+0avgdata 7528maxresident)k 36 | 0inputs+0outputs (0major+1971minor)pagefaults 0swaps 37 | echo 38 | 39 | echo '------------ MLton no DU' 40 | ------------ MLton no DU 41 | time ./mlpbst 42 | 30000 43 | 7.44user 0.15system 0:07.60elapsed 99%CPU (0avgtext+0avgdata 42868maxresident)k 44 | 0inputs+0outputs (0major+64775minor)pagefaults 0swaps 45 | echo 46 | 47 | echo '------------ Pawns no DU' 48 | ------------ Pawns no DU 49 | time ./pbst 50 | 30000 51 | Command exited with non-zero status 6 52 | 16.25user 0.00system 0:16.29elapsed 99%CPU (0avgtext+0avgdata 39336maxresident)k 53 | 0inputs+0outputs (0major+9897minor)pagefaults 0swaps 54 | make: [times] Error 6 (ignored) 55 | echo 56 | 57 | echo '------------ C iterative GC_malloc no free no DU' 58 | ------------ C iterative GC_malloc no free no DU 59 | time ./cpinfbst 60 | 30000 61 | Command exited with non-zero status 6 62 | 15.44user 0.00system 0:15.45elapsed 99%CPU (0avgtext+0avgdata 4572maxresident)k 63 | 0inputs+0outputs (0major+1205minor)pagefaults 0swaps 64 | make: [times] Error 6 (ignored) 65 | echo 66 | 67 | echo '------------ Haskell with seq but no DU' 68 | ------------ Haskell with seq but no DU 69 | time ./hssbst 70 | 30000 71 | 21.75user 0.01system 0:21.79elapsed 99%CPU (0avgtext+0avgdata 6476maxresident)k 72 | 0inputs+0outputs (0major+1716minor)pagefaults 0swaps 73 | echo 74 | 75 | echo '------------ C iterative GC_malloc no DU' 76 | ------------ C iterative GC_malloc no DU 77 | time ./cpigbst 78 | 30000 79 | Command exited with non-zero status 6 80 | 22.13user 0.00system 0:22.15elapsed 99%CPU (0avgtext+0avgdata 3532maxresident)k 81 | 0inputs+0outputs (0major+944minor)pagefaults 0swaps 82 | make: [times] Error 6 (ignored) 83 | echo 84 | 85 | echo '------------ C iterative no DU' 86 | ------------ C iterative no DU 87 | time ./cpibst 88 | 30000 89 | Command exited with non-zero status 6 90 | 21.85user 0.00system 0:21.87elapsed 99%CPU (0avgtext+0avgdata 3528maxresident)k 91 | 0inputs+0outputs (0major+944minor)pagefaults 0swaps 92 | make: [times] Error 6 (ignored) 93 | echo 94 | 95 | echo '------------ C no DU' 96 | ------------ C no DU 97 | time ./cpbst 98 | 30000 99 | Command exited with non-zero status 6 100 | 28.61user 0.00system 0:28.63elapsed 99%CPU (0avgtext+0avgdata 4564maxresident)k 101 | 0inputs+0outputs (0major+1203minor)pagefaults 0swaps 102 | make: [times] Error 6 (ignored) 103 | echo 104 | 105 | echo '------------ Haskell no DU' 106 | ------------ Haskell no DU 107 | time ./hspbst 108 | 30000 109 | 51.36user 0.08system 0:51.50elapsed 99%CPU (0avgtext+0avgdata 6472maxresident)k 110 | 0inputs+0outputs (0major+1716minor)pagefaults 0swaps 111 | -------------------------------------------------------------------------------- /bench/bst.pns: -------------------------------------------------------------------------------- 1 | % bst stuff: conversion from list of ints to bst of ints destructively, 2 | 3 | import from bstmain. 4 | import print_int from io. 5 | 6 | main :: void -> void 7 | implicit rw io. 8 | main(v) = !bstmain(v). 9 | 10 | type bst ---> mt ; node(bst, int, bst). 11 | type ints = list(int). 12 | type rbst = ref(bst). 13 | 14 | % convert list to bst - note this appears "pure" to callers 15 | list_bst :: ints -> bst. 16 | list_bst(xs) = { 17 | *tp = mt; 18 | list_bst_du(xs, !tp); 19 | return(*tp) 20 | }. 21 | 22 | % destructively add list of ints to tree we have ptr to 23 | list_bst_du :: ints -> rbst -> void 24 | sharing list_bst_du(xs, !tp) = v 25 | pre xs = abstract 26 | post nosharing. 27 | list_bst_du(xs, tp) = { 28 | cases xs of { 29 | case cons(x, xs1): 30 | bst_insert_du(x, !tp); 31 | list_bst_du(xs1, !tp) 32 | case nil: 33 | void 34 | } 35 | }. 36 | 37 | % destructively add int to tree we have ptr to 38 | % - traverse down to leaf and clobber it (while loop would be nice) 39 | bst_insert_du :: int -> rbst -> void 40 | sharing bst_insert_du(x, !tp) = v 41 | pre nosharing 42 | post nosharing. 43 | bst_insert_du(x, tp) = { 44 | cases *tp of { 45 | case mt: 46 | *!tp := node(mt, x, mt) 47 | case node(*lp, n, *rp): 48 | % see how much malloc slows things 49 | % tmp = node(mt, x, mt); 50 | if x <= n then 51 | bst_insert_du(x, !lp) !tp 52 | else 53 | bst_insert_du(x, !rp) !tp 54 | } 55 | }. 56 | -------------------------------------------------------------------------------- /bench/bstmain.pns: -------------------------------------------------------------------------------- 1 | % bst stuff: top level 2 | 3 | % Also needs (XXX should handle recursive imports?) 4 | % import print_int from io. 5 | export_imp bstmain, bst_size, ones, ones_acc, print_tree. 6 | 7 | type bst ---> mt ; node(bst, int, bst). 8 | type ints = list(int). 9 | 10 | bstmain :: void -> void 11 | implicit rw io. 12 | bstmain(v) = { 13 | !print_int(bst_size(list_bst(ones(30000)))) 14 | % t = list_bst(ones(5)); 15 | % !print_tree(t); 16 | % !print_int(bst_size(t)) 17 | }. 18 | 19 | bst_size :: bst -> int. 20 | bst_size(t) = { 21 | cases t of { 22 | case mt: 23 | 0 24 | case node(l, n, r): 25 | 1 + bst_size(l) + bst_size(r) 26 | } 27 | }. 28 | 29 | % make list of ones of length n 30 | ones :: int -> ints. 31 | ones(n) = ones_acc(n, nil). 32 | 33 | ones_acc :: int -> ints -> ints. 34 | ones_acc(n, xs) = { 35 | if n <= 0 then 36 | xs 37 | else 38 | ones_acc(n-1, cons(1, xs)) 39 | }. 40 | 41 | % print all elements of tree (inorder, no indentation etc to show tree 42 | % structure). 43 | print_tree :: bst -> void 44 | implicit rw io 45 | sharing print_tree(t)=voidvar 46 | pre nosharing 47 | post nosharing. 48 | print_tree(t) = { 49 | cases t of { 50 | case mt: 51 | return 52 | case node(l, n, r): 53 | !print_tree(l); 54 | !print_int(n); 55 | !print_tree(r) 56 | } 57 | }. 58 | 59 | -------------------------------------------------------------------------------- /bench/cbst.c: -------------------------------------------------------------------------------- 1 | #define ADT_MALLOC(s) malloc(s) 2 | #define ADT_FREE(s) free(s) 3 | // hacked version of bst.c from bst.pns with iterative inner loop 4 | // - a few versions 5 | // - also can experiment with malloc vs GC_malloc 6 | 7 | #define version 3 8 | 9 | // prettier version of data type for version 3 10 | typedef struct tree_node *tree; 11 | struct tree_node { 12 | tree *left; 13 | long data; 14 | tree *right;}; 15 | 16 | #include "pawns.h" 17 | #include "bst.h" 18 | void main(); 19 | bst list_bst(list xs); 20 | void list_bst_du(list xs, bst* tp); 21 | #if version==3 22 | void bst_insert_du(long x, tree *tp); 23 | #else 24 | void bst_insert_du(intptr_t x, bst* tp); 25 | #endif 26 | static __inline void bstmain(); 27 | static __inline intptr_t bst_size(bst t); 28 | static __inline list ones(intptr_t n); 29 | static __inline list ones_acc(intptr_t n, list xs); 30 | static __inline void print_tree(bst t); 31 | static __inline void print_int(intptr_t i); 32 | 33 | 34 | void 35 | main() { 36 | bstmain(); 37 | return; 38 | } 39 | 40 | bst 41 | list_bst(list xs) { 42 | bst V0 = mt(); 43 | bst* tp = (bst*)ADT_MALLOC(sizeof(void*)); 44 | *tp=V0; 45 | list_bst_du(xs, tp); 46 | bst V2 = *tp; 47 | return(V2); 48 | } 49 | 50 | void 51 | list_bst_du(list xs, bst* tp) { 52 | switch_list(xs) 53 | case_cons_ptr(V0, V1) 54 | list xs1 = *V1; 55 | intptr_t x = *V0; 56 | bst_insert_du(x, tp); 57 | list_bst_du(xs1, tp); 58 | return; 59 | case_nil_ptr() 60 | return; 61 | end_switch() 62 | } 63 | 64 | 65 | // version 0 produced by Pawns compiler 66 | #if version==0 67 | void 68 | bst_insert_du(intptr_t x, bst* tp) { 69 | bst V0 = *tp; 70 | switch_bst(V0) 71 | case_mt_ptr() 72 | bst V2 = mt(); 73 | bst V3 = mt(); 74 | bst V1 = node(V2, x, V3); 75 | *tp=V1; 76 | case_node_ptr(lp, V4, rp) 77 | intptr_t n = *V4; 78 | PAWNS_bool V5 = leq(x, n); 79 | switch_PAWNS_bool(V5) 80 | case_PAWNS_true_ptr() 81 | bst_insert_du(x, lp); 82 | return; 83 | case_PAWNS_false_ptr() 84 | bst_insert_du(x, rp); 85 | return; 86 | end_switch() 87 | end_switch() 88 | } 89 | #endif // version 90 | 91 | #if version==1 92 | void 93 | bst_insert_du(intptr_t x, bst* tp) { 94 | bst V0 = *tp; 95 | while(1) { 96 | if_node_ptr(*tp, lp, V4, rp) 97 | intptr_t n = *V4; 98 | if (x <= n) 99 | tp = lp; 100 | else 101 | tp = rp; 102 | else() 103 | bst V2 = mt(); 104 | bst V3 = mt(); 105 | bst V1 = node(V2, x, V3); 106 | *tp=V1; 107 | return; 108 | end_if() 109 | } 110 | } 111 | #endif // version 112 | 113 | #if version==2 114 | void 115 | bst_insert_du(intptr_t x, bst* tp) { 116 | bst V0 = *tp; 117 | while(*tp) { 118 | struct _ADT_bst* *lp=&((struct _ADT_bst_node*)(*tp))->f0; 119 | intptr_t n=((struct _ADT_bst_node*)(*tp))->f1; 120 | struct _ADT_bst* *rp=&((struct _ADT_bst_node*)(*tp))->f2; 121 | if (x <= n) 122 | tp = lp; 123 | else 124 | tp = rp; 125 | } 126 | bst V2 = mt(); 127 | bst V3 = mt(); 128 | bst V1 = node(V2, x, V3); 129 | *tp=V1; 130 | return; 131 | } 132 | #endif // version 133 | 134 | #if version==3 135 | // prettier variant of version 2 136 | void 137 | bst_insert_du(long x, tree *tp) { 138 | while(*tp) { 139 | if (x <= (*tp)->data) 140 | tp = &(*tp)->left; 141 | else 142 | tp = &(*tp)->right; 143 | } 144 | *tp = ADT_MALLOC(sizeof(struct tree_node)); 145 | (*tp)->left = NULL; 146 | (*tp)->data = x; 147 | (*tp)->right = NULL; 148 | } 149 | // Alt version avoiding *tp so much 150 | // void 151 | // bst_insert_du(long x, tree *tp) { 152 | // tree t; 153 | // while((t = *tp) != NULL) { 154 | // if (x <= t->data) 155 | // tp = &t->left; 156 | // else 157 | // tp = &t->right; 158 | // } 159 | // t = 160 | // *tp = ADT_MALLOC(sizeof(struct tree_node)); 161 | // t->left = NULL; 162 | // t->data = x; 163 | // t->right = NULL; 164 | // } 165 | #endif // version 166 | 167 | static __inline intptr_t 168 | bst_size(bst t) { 169 | switch_bst(t) 170 | case_mt_ptr() 171 | intptr_t V0 = 0; 172 | return(V0); 173 | case_node_ptr(V1, V2, V3) 174 | bst r = *V3; 175 | intptr_t n = *V2; 176 | bst l = *V1; 177 | intptr_t V6 = 1; 178 | intptr_t V7 = bst_size(l); 179 | intptr_t V5 = plus(V6, V7); 180 | intptr_t V8 = bst_size(r); 181 | intptr_t V4 = plus(V5, V8); 182 | return(V4); 183 | end_switch() 184 | } 185 | 186 | static __inline list 187 | ones(intptr_t n) { 188 | list V1 = nil(); 189 | list V0 = ones_acc(n, V1); 190 | return(V0); 191 | } 192 | 193 | static __inline list 194 | ones_acc(intptr_t n, list xs) { 195 | intptr_t V1 = 0; 196 | PAWNS_bool V0 = leq(n, V1); 197 | switch_PAWNS_bool(V0) 198 | case_PAWNS_true_ptr() 199 | return(xs); 200 | case_PAWNS_false_ptr() 201 | intptr_t V4 = 1; 202 | intptr_t V3 = minus(n, V4); 203 | intptr_t V6 = 1; 204 | list V5 = cons(V6, xs); 205 | list V2 = ones_acc(V3, V5); 206 | return(V2); 207 | end_switch() 208 | } 209 | 210 | 211 | #ifdef DEBUG 212 | static __inline void 213 | bstmain() { 214 | intptr_t V1 = 5; 215 | list V0 = ones(V1); 216 | bst t = list_bst(V0); 217 | print_tree(t); 218 | intptr_t V4 = bst_size(t); 219 | print_int(V4); 220 | return; 221 | } 222 | #else // DEBUG 223 | static __inline void 224 | bstmain() { 225 | intptr_t V4 = 30000; 226 | list V3 = ones(V4); 227 | bst V2 = list_bst(V3); 228 | intptr_t V1 = bst_size(V2); 229 | print_int(V1); 230 | return; 231 | } 232 | #endif // DEBUG 233 | 234 | 235 | static __inline void 236 | print_tree(bst t) { 237 | printf("("); 238 | switch_bst(t) 239 | case_mt_ptr() 240 | printf(")"); 241 | return; 242 | case_node_ptr(V1, V2, V3) 243 | bst r = *V3; 244 | intptr_t n = *V2; 245 | bst l = *V1; 246 | print_tree(l); 247 | print_int(n); 248 | print_tree(r); 249 | printf(")"); 250 | return; 251 | end_switch() 252 | } 253 | 254 | static __inline void 255 | print_int(intptr_t i){ 256 | printf("%ld\n", (long)i); 257 | } 258 | 259 | -------------------------------------------------------------------------------- /bench/cpbst.c: -------------------------------------------------------------------------------- 1 | #define ADT_MALLOC(s) malloc(s) 2 | #define ADT_FREE(s) free(s) 3 | // hacked version of bst.c from bst.pns with iterative inner loop 4 | // - a few versions 5 | // - also can experiment with malloc vs GC_malloc 6 | 7 | #define version 3 8 | 9 | // prettier version of data type for version 3 10 | typedef struct tree_node *tree; 11 | struct tree_node { 12 | tree *left; 13 | long data; 14 | tree *right;}; 15 | 16 | #include "pawns.h" 17 | #include "bst.h" 18 | void main(); 19 | bst list_bst(list xs); 20 | bst bst_insert(intptr_t x, bst t0); 21 | static __inline void bstmain(); 22 | static __inline intptr_t bst_size(bst t); 23 | static __inline list ones(intptr_t n); 24 | static __inline list ones_acc(intptr_t n, list xs); 25 | static __inline void print_tree(bst t); 26 | static __inline void print_int(intptr_t i); 27 | 28 | 29 | 30 | void 31 | main() { 32 | bstmain(); 33 | return; 34 | } 35 | 36 | bst 37 | list_bst(list xs) { 38 | bst t = mt(); 39 | while(1) 40 | if_cons(xs, x, xs1) 41 | t = bst_insert(x, t); 42 | xs = xs1; 43 | else() 44 | break; 45 | end_if() 46 | return t; 47 | } 48 | 49 | // XXX could improve by making this tail-recursive 50 | bst 51 | bst_insert(intptr_t x, bst t0) { 52 | switch_bst(t0) 53 | case_mt_ptr() 54 | bst V1 = mt(); 55 | bst V2 = mt(); 56 | bst V0 = node(V1, x, V2); 57 | return(V0); 58 | case_node_ptr(V3, V4, V5) 59 | bst r = *V5; 60 | intptr_t n = *V4; 61 | bst l = *V3; 62 | if (x <= n) { 63 | bst V8 = bst_insert(x, l); 64 | bst V7 = node(V8, n, r); 65 | ADT_FREE(t0); 66 | return(V7); 67 | } else { 68 | bst V10 = bst_insert(x, r); 69 | bst V9 = node(l, n, V10); 70 | ADT_FREE(t0); 71 | return(V9); 72 | } 73 | end_switch() 74 | } 75 | 76 | 77 | static __inline intptr_t 78 | bst_size(bst t) { 79 | switch_bst(t) 80 | case_mt_ptr() 81 | intptr_t V0 = 0; 82 | return(V0); 83 | case_node_ptr(V1, V2, V3) 84 | bst r = *V3; 85 | intptr_t n = *V2; 86 | bst l = *V1; 87 | intptr_t V6 = 1; 88 | intptr_t V7 = bst_size(l); 89 | intptr_t V5 = plus(V6, V7); 90 | intptr_t V8 = bst_size(r); 91 | intptr_t V4 = plus(V5, V8); 92 | return(V4); 93 | end_switch() 94 | } 95 | 96 | static __inline list 97 | ones(intptr_t n) { 98 | list V1 = nil(); 99 | list V0 = ones_acc(n, V1); 100 | return(V0); 101 | } 102 | 103 | static __inline list 104 | ones_acc(intptr_t n, list xs) { 105 | intptr_t V1 = 0; 106 | PAWNS_bool V0 = leq(n, V1); 107 | switch_PAWNS_bool(V0) 108 | case_PAWNS_true_ptr() 109 | return(xs); 110 | case_PAWNS_false_ptr() 111 | intptr_t V4 = 1; 112 | intptr_t V3 = minus(n, V4); 113 | intptr_t V6 = 1; 114 | list V5 = cons(V6, xs); 115 | list V2 = ones_acc(V3, V5); 116 | return(V2); 117 | end_switch() 118 | } 119 | 120 | 121 | #ifdef DEBUG 122 | static __inline void 123 | bstmain() { 124 | intptr_t V1 = 5; 125 | list V0 = ones(V1); 126 | bst t = list_bst(V0); 127 | print_tree(t); 128 | intptr_t V4 = bst_size(t); 129 | print_int(V4); 130 | return; 131 | } 132 | #else // DEBUG 133 | static __inline void 134 | bstmain() { 135 | intptr_t V4 = 30000; 136 | list V3 = ones(V4); 137 | bst V2 = list_bst(V3); 138 | intptr_t V1 = bst_size(V2); 139 | print_int(V1); 140 | return; 141 | } 142 | #endif // DEBUG 143 | 144 | 145 | static __inline void 146 | print_tree(bst t) { 147 | printf("("); 148 | switch_bst(t) 149 | case_mt_ptr() 150 | printf(")"); 151 | return; 152 | case_node_ptr(V1, V2, V3) 153 | bst r = *V3; 154 | intptr_t n = *V2; 155 | bst l = *V1; 156 | print_tree(l); 157 | print_int(n); 158 | print_tree(r); 159 | printf(")"); 160 | return; 161 | end_switch() 162 | } 163 | 164 | static __inline void 165 | print_int(intptr_t i){ 166 | printf("%ld\n", (long)i); 167 | } 168 | 169 | -------------------------------------------------------------------------------- /bench/cpibst.c: -------------------------------------------------------------------------------- 1 | #define ADT_MALLOC(s) malloc(s) 2 | #define ADT_FREE(s) free(s) 3 | // hacked version of bst.c from bst.pns with iterative inner loop 4 | // - a few versions 5 | // - also can experiment with malloc vs GC_malloc 6 | 7 | #define version 3 8 | 9 | // prettier version of data type for version 3 10 | typedef struct tree_node *tree; 11 | struct tree_node { 12 | tree *left; 13 | long data; 14 | tree *right;}; 15 | 16 | #include "pawns.h" 17 | #include "bst.h" 18 | void main(); 19 | bst list_bst(list xs); 20 | bst bst_insert(intptr_t x, bst t0); 21 | void bst_insert1(intptr_t x, bst t0, bst *r); 22 | static __inline void bstmain(); 23 | static __inline intptr_t bst_size(bst t); 24 | static __inline list ones(intptr_t n); 25 | static __inline list ones_acc(intptr_t n, list xs); 26 | static __inline void print_tree(bst t); 27 | static __inline void print_int(intptr_t i); 28 | 29 | 30 | void 31 | main() { 32 | bstmain(); 33 | return; 34 | } 35 | 36 | bst 37 | list_bst(list xs) { 38 | bst t = mt(); 39 | while(1) 40 | if_cons(xs, x, xs1) 41 | t = bst_insert(x, t); 42 | xs = xs1; 43 | else() 44 | break; 45 | end_if() 46 | return t; 47 | } 48 | 49 | // iterative version - we pass in a pointer to tree to clobber 50 | bst 51 | bst_insert(intptr_t x, bst t0) { 52 | bst rt; 53 | bst_insert1(x, t0, &rt); 54 | return rt; 55 | } 56 | 57 | void 58 | bst_insert1(intptr_t x, bst t0, bst *rt) { 59 | while (1) { 60 | switch_bst(t0) 61 | case_mt_ptr() 62 | bst V1 = mt(); 63 | bst V2 = mt(); 64 | bst V0 = node(V1, x, V2); 65 | *rt = V0; 66 | return; 67 | case_node_ptr(V3, V4, V5) 68 | bst r = *V5; 69 | intptr_t n = *V4; 70 | bst l = *V3; 71 | if (x <= n) { 72 | bst V8; 73 | bst V7 = node(V8, n, r); 74 | ADT_FREE(t0); 75 | // printf("%lx %lx %lx %lx\n", (long)t0, (long)l, (long)rt, (long)V7); 76 | t0 = l; 77 | *rt = V7; 78 | rt = &((struct _ADT_bst_node*)V7)->f0; 79 | } else { 80 | bst V10; 81 | bst V9 = node(l, n, V10); 82 | ADT_FREE(t0); 83 | t0 = r; 84 | *rt = V9; 85 | rt = &((struct _ADT_bst_node*)V9)->f2; 86 | } 87 | end_switch() 88 | } 89 | } 90 | 91 | 92 | static __inline intptr_t 93 | bst_size(bst t) { 94 | switch_bst(t) 95 | case_mt_ptr() 96 | intptr_t V0 = 0; 97 | return(V0); 98 | case_node_ptr(V1, V2, V3) 99 | bst r = *V3; 100 | intptr_t n = *V2; 101 | bst l = *V1; 102 | intptr_t V6 = 1; 103 | intptr_t V7 = bst_size(l); 104 | intptr_t V5 = plus(V6, V7); 105 | intptr_t V8 = bst_size(r); 106 | intptr_t V4 = plus(V5, V8); 107 | return(V4); 108 | end_switch() 109 | } 110 | 111 | static __inline list 112 | ones(intptr_t n) { 113 | list V1 = nil(); 114 | list V0 = ones_acc(n, V1); 115 | return(V0); 116 | } 117 | 118 | static __inline list 119 | ones_acc(intptr_t n, list xs) { 120 | intptr_t V1 = 0; 121 | PAWNS_bool V0 = leq(n, V1); 122 | switch_PAWNS_bool(V0) 123 | case_PAWNS_true_ptr() 124 | return(xs); 125 | case_PAWNS_false_ptr() 126 | intptr_t V4 = 1; 127 | intptr_t V3 = minus(n, V4); 128 | intptr_t V6 = 1; 129 | list V5 = cons(V6, xs); 130 | list V2 = ones_acc(V3, V5); 131 | return(V2); 132 | end_switch() 133 | } 134 | 135 | 136 | #ifdef DEBUG 137 | static __inline void 138 | bstmain() { 139 | intptr_t V1 = 5; 140 | list V0 = ones(V1); 141 | bst t = list_bst(V0); 142 | print_tree(t); 143 | intptr_t V4 = bst_size(t); 144 | print_int(V4); 145 | return; 146 | } 147 | #else // DEBUG 148 | static __inline void 149 | bstmain() { 150 | intptr_t V4 = 30000; 151 | list V3 = ones(V4); 152 | bst V2 = list_bst(V3); 153 | intptr_t V1 = bst_size(V2); 154 | print_int(V1); 155 | return; 156 | } 157 | #endif // DEBUG 158 | 159 | 160 | static __inline void 161 | print_tree(bst t) { 162 | printf("("); 163 | switch_bst(t) 164 | case_mt_ptr() 165 | printf(")"); 166 | return; 167 | case_node_ptr(V1, V2, V3) 168 | bst r = *V3; 169 | intptr_t n = *V2; 170 | bst l = *V1; 171 | print_tree(l); 172 | print_int(n); 173 | print_tree(r); 174 | printf(")"); 175 | return; 176 | end_switch() 177 | } 178 | 179 | static __inline void 180 | print_int(intptr_t i){ 181 | printf("%ld\n", (long)i); 182 | } 183 | 184 | -------------------------------------------------------------------------------- /bench/cpigbst.c: -------------------------------------------------------------------------------- 1 | // hacked version of bst.c from bst.pns with iterative inner loop 2 | // - a few versions 3 | // - also can experiment with malloc vs GC_malloc 4 | 5 | #define version 3 6 | 7 | // prettier version of data type for version 3 8 | typedef struct tree_node *tree; 9 | struct tree_node { 10 | tree *left; 11 | long data; 12 | tree *right;}; 13 | 14 | #include "pawns.h" 15 | #include "bst.h" 16 | void main(); 17 | bst list_bst(list xs); 18 | bst bst_insert(intptr_t x, bst t0); 19 | void bst_insert1(intptr_t x, bst t0, bst *r); 20 | static __inline void bstmain(); 21 | static __inline intptr_t bst_size(bst t); 22 | static __inline list ones(intptr_t n); 23 | static __inline list ones_acc(intptr_t n, list xs); 24 | static __inline void print_tree(bst t); 25 | static __inline void print_int(intptr_t i); 26 | 27 | 28 | void 29 | main() { 30 | bstmain(); 31 | return; 32 | } 33 | 34 | bst 35 | list_bst(list xs) { 36 | bst t = mt(); 37 | while(1) 38 | if_cons(xs, x, xs1) 39 | t = bst_insert(x, t); 40 | xs = xs1; 41 | else() 42 | break; 43 | end_if() 44 | return t; 45 | } 46 | 47 | // iterative version - we pass in a pointer to tree to clobber 48 | bst 49 | bst_insert(intptr_t x, bst t0) { 50 | bst rt; 51 | bst_insert1(x, t0, &rt); 52 | return rt; 53 | } 54 | 55 | void 56 | bst_insert1(intptr_t x, bst t0, bst *rt) { 57 | while (1) { 58 | switch_bst(t0) 59 | case_mt_ptr() 60 | bst V1 = mt(); 61 | bst V2 = mt(); 62 | bst V0 = node(V1, x, V2); 63 | *rt = V0; 64 | return; 65 | case_node_ptr(V3, V4, V5) 66 | bst r = *V5; 67 | intptr_t n = *V4; 68 | bst l = *V3; 69 | if (x <= n) { 70 | bst V8; 71 | bst V7 = node(V8, n, r); 72 | ADT_FREE(t0); 73 | // printf("%lx %lx %lx %lx\n", (long)t0, (long)l, (long)rt, (long)V7); 74 | t0 = l; 75 | *rt = V7; 76 | rt = &((struct _ADT_bst_node*)V7)->f0; 77 | } else { 78 | bst V10; 79 | bst V9 = node(l, n, V10); 80 | ADT_FREE(t0); 81 | t0 = r; 82 | *rt = V9; 83 | rt = &((struct _ADT_bst_node*)V9)->f2; 84 | } 85 | end_switch() 86 | } 87 | } 88 | 89 | 90 | static __inline intptr_t 91 | bst_size(bst t) { 92 | switch_bst(t) 93 | case_mt_ptr() 94 | intptr_t V0 = 0; 95 | return(V0); 96 | case_node_ptr(V1, V2, V3) 97 | bst r = *V3; 98 | intptr_t n = *V2; 99 | bst l = *V1; 100 | intptr_t V6 = 1; 101 | intptr_t V7 = bst_size(l); 102 | intptr_t V5 = plus(V6, V7); 103 | intptr_t V8 = bst_size(r); 104 | intptr_t V4 = plus(V5, V8); 105 | return(V4); 106 | end_switch() 107 | } 108 | 109 | static __inline list 110 | ones(intptr_t n) { 111 | list V1 = nil(); 112 | list V0 = ones_acc(n, V1); 113 | return(V0); 114 | } 115 | 116 | static __inline list 117 | ones_acc(intptr_t n, list xs) { 118 | intptr_t V1 = 0; 119 | PAWNS_bool V0 = leq(n, V1); 120 | switch_PAWNS_bool(V0) 121 | case_PAWNS_true_ptr() 122 | return(xs); 123 | case_PAWNS_false_ptr() 124 | intptr_t V4 = 1; 125 | intptr_t V3 = minus(n, V4); 126 | intptr_t V6 = 1; 127 | list V5 = cons(V6, xs); 128 | list V2 = ones_acc(V3, V5); 129 | return(V2); 130 | end_switch() 131 | } 132 | 133 | 134 | #ifdef DEBUG 135 | static __inline void 136 | bstmain() { 137 | intptr_t V1 = 5; 138 | list V0 = ones(V1); 139 | bst t = list_bst(V0); 140 | print_tree(t); 141 | intptr_t V4 = bst_size(t); 142 | print_int(V4); 143 | return; 144 | } 145 | #else // DEBUG 146 | static __inline void 147 | bstmain() { 148 | intptr_t V4 = 30000; 149 | list V3 = ones(V4); 150 | bst V2 = list_bst(V3); 151 | intptr_t V1 = bst_size(V2); 152 | print_int(V1); 153 | return; 154 | } 155 | #endif // DEBUG 156 | 157 | 158 | static __inline void 159 | print_tree(bst t) { 160 | printf("("); 161 | switch_bst(t) 162 | case_mt_ptr() 163 | printf(")"); 164 | return; 165 | case_node_ptr(V1, V2, V3) 166 | bst r = *V3; 167 | intptr_t n = *V2; 168 | bst l = *V1; 169 | print_tree(l); 170 | print_int(n); 171 | print_tree(r); 172 | printf(")"); 173 | return; 174 | end_switch() 175 | } 176 | 177 | static __inline void 178 | print_int(intptr_t i){ 179 | printf("%ld\n", (long)i); 180 | } 181 | 182 | -------------------------------------------------------------------------------- /bench/cpinfbst.c: -------------------------------------------------------------------------------- 1 | // hacked version of bst.c from bst.pns with iterative inner loop 2 | // - a few versions 3 | // - also can experiment with malloc vs GC_malloc 4 | 5 | #define version 3 6 | 7 | // prettier version of data type for version 3 8 | typedef struct tree_node *tree; 9 | struct tree_node { 10 | tree *left; 11 | long data; 12 | tree *right;}; 13 | 14 | #include "pawns.h" 15 | #include "bst.h" 16 | void main(); 17 | bst list_bst(list xs); 18 | bst bst_insert(intptr_t x, bst t0); 19 | void bst_insert1(intptr_t x, bst t0, bst *r); 20 | static __inline void bstmain(); 21 | static __inline intptr_t bst_size(bst t); 22 | static __inline list ones(intptr_t n); 23 | static __inline list ones_acc(intptr_t n, list xs); 24 | static __inline void print_tree(bst t); 25 | static __inline void print_int(intptr_t i); 26 | 27 | 28 | void 29 | main() { 30 | bstmain(); 31 | return; 32 | } 33 | 34 | bst 35 | list_bst(list xs) { 36 | bst t = mt(); 37 | while(1) 38 | if_cons(xs, x, xs1) 39 | t = bst_insert(x, t); 40 | xs = xs1; 41 | else() 42 | break; 43 | end_if() 44 | return t; 45 | } 46 | 47 | // iterative version - we pass in a pointer to tree to clobber 48 | bst 49 | bst_insert(intptr_t x, bst t0) { 50 | bst rt; 51 | bst_insert1(x, t0, &rt); 52 | return rt; 53 | } 54 | 55 | void 56 | bst_insert1(intptr_t x, bst t0, bst *rt) { 57 | while (1) { 58 | switch_bst(t0) 59 | case_mt_ptr() 60 | bst V1 = mt(); 61 | bst V2 = mt(); 62 | bst V0 = node(V1, x, V2); 63 | *rt = V0; 64 | return; 65 | case_node_ptr(V3, V4, V5) 66 | bst r = *V5; 67 | intptr_t n = *V4; 68 | bst l = *V3; 69 | if (x <= n) { 70 | bst V8; 71 | bst V7 = node(V8, n, r); 72 | // ADT_FREE(t0); 73 | // printf("%lx %lx %lx %lx\n", (long)t0, (long)l, (long)rt, (long)V7); 74 | t0 = l; 75 | *rt = V7; 76 | rt = &((struct _ADT_bst_node*)V7)->f0; 77 | } else { 78 | bst V10; 79 | bst V9 = node(l, n, V10); 80 | // ADT_FREE(t0); 81 | t0 = r; 82 | *rt = V9; 83 | rt = &((struct _ADT_bst_node*)V9)->f2; 84 | } 85 | end_switch() 86 | } 87 | } 88 | 89 | 90 | static __inline intptr_t 91 | bst_size(bst t) { 92 | switch_bst(t) 93 | case_mt_ptr() 94 | intptr_t V0 = 0; 95 | return(V0); 96 | case_node_ptr(V1, V2, V3) 97 | bst r = *V3; 98 | intptr_t n = *V2; 99 | bst l = *V1; 100 | intptr_t V6 = 1; 101 | intptr_t V7 = bst_size(l); 102 | intptr_t V5 = plus(V6, V7); 103 | intptr_t V8 = bst_size(r); 104 | intptr_t V4 = plus(V5, V8); 105 | return(V4); 106 | end_switch() 107 | } 108 | 109 | static __inline list 110 | ones(intptr_t n) { 111 | list V1 = nil(); 112 | list V0 = ones_acc(n, V1); 113 | return(V0); 114 | } 115 | 116 | static __inline list 117 | ones_acc(intptr_t n, list xs) { 118 | intptr_t V1 = 0; 119 | PAWNS_bool V0 = leq(n, V1); 120 | switch_PAWNS_bool(V0) 121 | case_PAWNS_true_ptr() 122 | return(xs); 123 | case_PAWNS_false_ptr() 124 | intptr_t V4 = 1; 125 | intptr_t V3 = minus(n, V4); 126 | intptr_t V6 = 1; 127 | list V5 = cons(V6, xs); 128 | list V2 = ones_acc(V3, V5); 129 | return(V2); 130 | end_switch() 131 | } 132 | 133 | 134 | #ifdef DEBUG 135 | static __inline void 136 | bstmain() { 137 | intptr_t V1 = 5; 138 | list V0 = ones(V1); 139 | bst t = list_bst(V0); 140 | print_tree(t); 141 | intptr_t V4 = bst_size(t); 142 | print_int(V4); 143 | return; 144 | } 145 | #else // DEBUG 146 | static __inline void 147 | bstmain() { 148 | intptr_t V4 = 30000; 149 | list V3 = ones(V4); 150 | bst V2 = list_bst(V3); 151 | intptr_t V1 = bst_size(V2); 152 | print_int(V1); 153 | return; 154 | } 155 | #endif // DEBUG 156 | 157 | 158 | static __inline void 159 | print_tree(bst t) { 160 | printf("("); 161 | switch_bst(t) 162 | case_mt_ptr() 163 | printf(")"); 164 | return; 165 | case_node_ptr(V1, V2, V3) 166 | bst r = *V3; 167 | intptr_t n = *V2; 168 | bst l = *V1; 169 | print_tree(l); 170 | print_int(n); 171 | print_tree(r); 172 | printf(")"); 173 | return; 174 | end_switch() 175 | } 176 | 177 | static __inline void 178 | print_int(intptr_t i){ 179 | printf("%ld\n", (long)i); 180 | } 181 | 182 | -------------------------------------------------------------------------------- /bench/gcbst.c: -------------------------------------------------------------------------------- 1 | // hacked version of bst.c from bst.pns with iterative inner loop 2 | // - a few versions 3 | // - also can experiment with malloc vs GC_malloc 4 | 5 | #define version 3 6 | 7 | // prettier version of data type for version 3 8 | typedef struct tree_node *tree; 9 | struct tree_node { 10 | tree *left; 11 | long data; 12 | tree *right;}; 13 | 14 | #include "pawns.h" 15 | #include "bst.h" 16 | void main(); 17 | bst list_bst(list xs); 18 | void list_bst_du(list xs, bst* tp); 19 | #if version==3 20 | void bst_insert_du(long x, tree *tp); 21 | #else 22 | void bst_insert_du(intptr_t x, bst* tp); 23 | #endif 24 | static __inline void bstmain(); 25 | static __inline intptr_t bst_size(bst t); 26 | static __inline list ones(intptr_t n); 27 | static __inline list ones_acc(intptr_t n, list xs); 28 | static __inline void print_tree(bst t); 29 | 30 | 31 | void 32 | main() { 33 | bstmain(); 34 | return; 35 | } 36 | 37 | bst 38 | list_bst(list xs) { 39 | bst V0 = mt(); 40 | bst* tp = (bst*)ADT_MALLOC(sizeof(void*)); 41 | *tp=V0; 42 | list_bst_du(xs, tp); 43 | bst V2 = *tp; 44 | return(V2); 45 | } 46 | 47 | void 48 | list_bst_du(list xs, bst* tp) { 49 | switch_list(xs) 50 | case_cons_ptr(V0, V1) 51 | list xs1 = *V1; 52 | intptr_t x = *V0; 53 | bst_insert_du(x, tp); 54 | list_bst_du(xs1, tp); 55 | return; 56 | case_nil_ptr() 57 | return; 58 | end_switch() 59 | } 60 | 61 | 62 | // version 0 produced by Pawns compiler 63 | #if version==0 64 | void 65 | bst_insert_du(intptr_t x, bst* tp) { 66 | bst V0 = *tp; 67 | switch_bst(V0) 68 | case_mt_ptr() 69 | bst V2 = mt(); 70 | bst V3 = mt(); 71 | bst V1 = node(V2, x, V3); 72 | *tp=V1; 73 | case_node_ptr(lp, V4, rp) 74 | intptr_t n = *V4; 75 | PAWNS_bool V5 = leq(x, n); 76 | switch_PAWNS_bool(V5) 77 | case_PAWNS_true_ptr() 78 | bst_insert_du(x, lp); 79 | return; 80 | case_PAWNS_false_ptr() 81 | bst_insert_du(x, rp); 82 | return; 83 | end_switch() 84 | end_switch() 85 | } 86 | #endif // version 87 | 88 | #if version==1 89 | void 90 | bst_insert_du(intptr_t x, bst* tp) { 91 | bst V0 = *tp; 92 | while(1) { 93 | if_node_ptr(*tp, lp, V4, rp) 94 | intptr_t n = *V4; 95 | if (x <= n) 96 | tp = lp; 97 | else 98 | tp = rp; 99 | else() 100 | bst V2 = mt(); 101 | bst V3 = mt(); 102 | bst V1 = node(V2, x, V3); 103 | *tp=V1; 104 | return; 105 | end_if() 106 | } 107 | } 108 | #endif // version 109 | 110 | #if version==2 111 | void 112 | bst_insert_du(intptr_t x, bst* tp) { 113 | bst V0 = *tp; 114 | while(*tp) { 115 | struct _ADT_bst* *lp=&((struct _ADT_bst_node*)(*tp))->f0; 116 | intptr_t n=((struct _ADT_bst_node*)(*tp))->f1; 117 | struct _ADT_bst* *rp=&((struct _ADT_bst_node*)(*tp))->f2; 118 | if (x <= n) 119 | tp = lp; 120 | else 121 | tp = rp; 122 | } 123 | bst V2 = mt(); 124 | bst V3 = mt(); 125 | bst V1 = node(V2, x, V3); 126 | *tp=V1; 127 | return; 128 | } 129 | #endif // version 130 | 131 | #if version==3 132 | // prettier variant of version 2 133 | void 134 | bst_insert_du(long x, tree *tp) { 135 | while(*tp) { 136 | if (x <= (*tp)->data) 137 | tp = &(*tp)->left; 138 | else 139 | tp = &(*tp)->right; 140 | } 141 | *tp = ADT_MALLOC(sizeof(struct tree_node)); 142 | (*tp)->left = NULL; 143 | (*tp)->data = x; 144 | (*tp)->right = NULL; 145 | } 146 | // Alt version avoiding *tp so much 147 | // void 148 | // bst_insert_du(long x, tree *tp) { 149 | // tree t; 150 | // while((t = *tp) != NULL) { 151 | // if (x <= t->data) 152 | // tp = &t->left; 153 | // else 154 | // tp = &t->right; 155 | // } 156 | // t = 157 | // *tp = ADT_MALLOC(sizeof(struct tree_node)); 158 | // t->left = NULL; 159 | // t->data = x; 160 | // t->right = NULL; 161 | // } 162 | #endif // version 163 | 164 | static __inline intptr_t 165 | bst_size(bst t) { 166 | switch_bst(t) 167 | case_mt_ptr() 168 | intptr_t V0 = 0; 169 | return(V0); 170 | case_node_ptr(V1, V2, V3) 171 | bst r = *V3; 172 | intptr_t n = *V2; 173 | bst l = *V1; 174 | intptr_t V6 = 1; 175 | intptr_t V7 = bst_size(l); 176 | intptr_t V5 = plus(V6, V7); 177 | intptr_t V8 = bst_size(r); 178 | intptr_t V4 = plus(V5, V8); 179 | return(V4); 180 | end_switch() 181 | } 182 | 183 | static __inline list 184 | ones(intptr_t n) { 185 | list V1 = nil(); 186 | list V0 = ones_acc(n, V1); 187 | return(V0); 188 | } 189 | 190 | static __inline list 191 | ones_acc(intptr_t n, list xs) { 192 | intptr_t V1 = 0; 193 | PAWNS_bool V0 = leq(n, V1); 194 | switch_PAWNS_bool(V0) 195 | case_PAWNS_true_ptr() 196 | return(xs); 197 | case_PAWNS_false_ptr() 198 | intptr_t V4 = 1; 199 | intptr_t V3 = minus(n, V4); 200 | intptr_t V6 = 1; 201 | list V5 = cons(V6, xs); 202 | list V2 = ones_acc(V3, V5); 203 | return(V2); 204 | end_switch() 205 | } 206 | 207 | 208 | #ifdef DEBUG 209 | static __inline void 210 | bstmain() { 211 | intptr_t V1 = 5; 212 | list V0 = ones(V1); 213 | bst t = list_bst(V0); 214 | print_tree(t); 215 | intptr_t V4 = bst_size(t); 216 | print_int(V4); 217 | return; 218 | } 219 | #else // DEBUG 220 | static __inline void 221 | bstmain() { 222 | intptr_t V4 = 30000; 223 | list V3 = ones(V4); 224 | bst V2 = list_bst(V3); 225 | intptr_t V1 = bst_size(V2); 226 | print_int(V1); 227 | return; 228 | } 229 | #endif // DEBUG 230 | 231 | 232 | static __inline void 233 | print_tree(bst t) { 234 | printf("("); 235 | switch_bst(t) 236 | case_mt_ptr() 237 | printf(")"); 238 | return; 239 | case_node_ptr(V1, V2, V3) 240 | bst r = *V3; 241 | intptr_t n = *V2; 242 | bst l = *V1; 243 | print_tree(l); 244 | print_int(n); 245 | print_tree(r); 246 | printf(")"); 247 | return; 248 | end_switch() 249 | } 250 | -------------------------------------------------------------------------------- /bench/hspbst.hs: -------------------------------------------------------------------------------- 1 | -- Haskell version of bst.ps 2 | 3 | data Bst = Mt | Node Bst Int Bst 4 | type Ints = [Int] 5 | 6 | list_bst :: Ints -> Bst 7 | list_bst xs = list_bst_acc xs Mt 8 | 9 | list_bst_acc :: Ints -> Bst -> Bst 10 | list_bst_acc xs t0 = 11 | case xs of 12 | (x:xs1) -> list_bst_acc xs1 (bst_insert x t0) 13 | [] -> t0 14 | 15 | bst_insert :: Int -> Bst -> Bst 16 | bst_insert x t0 = 17 | case t0 of 18 | Mt -> Node Mt x Mt 19 | (Node l n r) -> 20 | if x <= n then 21 | Node (bst_insert x l) n r 22 | else 23 | Node l n (bst_insert x r) 24 | 25 | bst_size :: Bst -> Int 26 | bst_size t = 27 | case t of 28 | Mt -> 0 29 | (Node l n r) -> 1 + (bst_size l) + (bst_size r) 30 | 31 | tst = bst_size (list_bst [1..10]) 32 | 33 | main = do print (bst_size (list_bst [1..30000])) 34 | -- C;ghc -O3 hsbst.hs ; time ./hsbst 35 | -- [1 of 1] Compiling Main ( hsbst.hs, hsbst.o ) 36 | -- Linking hsbst ... 37 | -- 10000 38 | -- 39 | -- real 0m11.908s 40 | -- user 0m11.855s 41 | -- sys 0m0.028s 42 | -- C;ghc -O3 hsbst.hs ; time ./hsbst 43 | -- [1 of 1] Compiling Main ( hsbst.hs, hsbst.o ) 44 | -- Linking hsbst ... 45 | -- 30000 46 | -- 47 | -- real 3m50.300s 48 | -- user 3m49.509s 49 | -- sys 0m0.280s 50 | 51 | 52 | -------------------------------------------------------------------------------- /bench/hsrbst.hs: -------------------------------------------------------------------------------- 1 | -- playing around with STRefs - BST example etc 2 | 3 | import Control.Monad.ST 4 | import Data.STRef 5 | 6 | -- items in tree (monomorphic, no separate key+value currently) 7 | type Item = Int 8 | 9 | -- tree of ints (for simple BST) 10 | -- with STRefs so we can use (monadic) destructive update 11 | -- This leads to an extra level of indirection in data structure plus 12 | -- explicit dealing with refs in all the code traversing trees plus 13 | -- the need for the ST monad everywhere the tree is used:-( 14 | -- Note: the Item in nodes here is not wrapped in a ref (not quite the 15 | -- same as Pawns version) 16 | data DUTree s = 17 | DUEmpty | DUNode (STRef s (DUTree s)) Item (STRef s (DUTree s)) 18 | 19 | -- high level version 20 | data Tree = Empty | Node Tree Item Tree 21 | deriving Show 22 | 23 | -- convert list to BST (using destructive insert) 24 | list_dubst :: [Item] -> ST s (DUTree s) 25 | list_dubst xs = 26 | do 27 | tp <- newSTRef DUEmpty 28 | list_dubst_du xs tp 29 | readSTRef tp 30 | 31 | -- As above with (ref to) tree passed in 32 | list_dubst_du :: [Item] -> STRef t (DUTree t) -> ST t () 33 | list_dubst_du xs tp = 34 | case xs of 35 | (x:xs1) -> 36 | do 37 | dubst_insert_du x tp 38 | list_dubst_du xs1 tp 39 | [] -> 40 | return () 41 | 42 | -- destructively insert element x into (ref to) BST 43 | dubst_insert_du :: Item -> STRef t (DUTree t) -> ST t () 44 | dubst_insert_du x tp = 45 | do 46 | t <- readSTRef tp 47 | case t of 48 | DUEmpty -> -- tp := Node Empty x Empty 49 | do 50 | e1 <- newSTRef DUEmpty 51 | e2 <- newSTRef DUEmpty 52 | writeSTRef tp (DUNode e1 x e2) 53 | (DUNode lp n rp) -> 54 | if x <= n then 55 | dubst_insert_du x lp 56 | else 57 | dubst_insert_du x rp 58 | 59 | -- size of tree 60 | -- (doesn't update tree, though this isn't obvious from the type signature) 61 | dubst_size :: DUTree s -> ST s Int 62 | dubst_size t = 63 | case t of 64 | DUEmpty -> 65 | return 0 66 | (DUNode lp n rp) -> 67 | do 68 | l <- readSTRef lp 69 | sl <- dubst_size l 70 | r <- readSTRef rp 71 | sr <- dubst_size r 72 | return (sl + sr + 1) 73 | 74 | -- tests for membership of tree 75 | -- (doesn't update tree, though this isn't obvious from the type signature) 76 | dubst_member :: Item -> DUTree s -> ST s Bool 77 | dubst_member x t = 78 | case t of 79 | DUEmpty -> 80 | return False 81 | (DUNode lp n rp) -> 82 | if x == n then 83 | return True 84 | else if x <= n then 85 | do 86 | l <- readSTRef lp 87 | dubst_member x l 88 | else 89 | do 90 | r <- readSTRef rp 91 | dubst_member x r 92 | 93 | test1 = 94 | runST $ 95 | do 96 | tp <- newSTRef DUEmpty 97 | dubst_insert_du 3 tp 98 | dubst_insert_du 5 tp 99 | t <- readSTRef tp 100 | dubst_size t 101 | 102 | test2 = 103 | runST $ 104 | do 105 | t <- list_dubst [3,4,2,5,1] 106 | dubst_size t 107 | 108 | -- illustrates how sharing of (even empty) subtrees breaks insertion 109 | test3 = 110 | runST $ 111 | do 112 | tp <- newSTRef DUEmpty -- could be anything 113 | e1 <- newSTRef DUEmpty 114 | writeSTRef tp (DUNode e1 5 e1) -- tree with Empty subtree refs shared 115 | dubst_insert_du 3 tp -- clobbers both occurrences of e1 - oops! 116 | t <- readSTRef tp 117 | dubst_size t 118 | 119 | test4 = 120 | runST $ 121 | do 122 | t <- list_dubst [3,6,2,5,1] 123 | -- dubst_member 5 t 124 | dubst_member 4 t 125 | 126 | -- convert from DU tree to high level tree 127 | dubst_bst :: DUTree s -> ST s Tree 128 | dubst_bst t = 129 | case t of 130 | DUEmpty -> 131 | return Empty 132 | (DUNode lp n rp) -> 133 | do 134 | l <- readSTRef lp 135 | hl <- dubst_bst l 136 | r <- readSTRef rp 137 | hr <- dubst_bst r 138 | return (Node hl n hr) 139 | 140 | -- size of high level tree 141 | bst_size :: Tree -> Int 142 | bst_size t = 143 | case t of 144 | Empty -> 0 145 | (Node l _ r) -> (bst_size l) + (bst_size r) + 1 146 | 147 | -- size of tree, using conversion to high level tree 148 | dubst_size' :: DUTree s -> ST s Int 149 | dubst_size' t = 150 | do 151 | ht <- dubst_bst t 152 | return (bst_size ht) 153 | 154 | -- length of list 155 | len l = 156 | runST $ 157 | do 158 | dut <- list_dubst l 159 | t <- dubst_bst dut 160 | return $ bst_size t 161 | 162 | tst30000 = 163 | runST $ 164 | do 165 | t <- list_dubst [1..30000] 166 | dubst_size t 167 | 168 | main = do print tst30000 169 | 170 | 171 | -- :l "hsrbst" 172 | -- len [3,4,2,5,1] 173 | -------------------------------------------------------------------------------- /bench/hssbst.hs: -------------------------------------------------------------------------------- 1 | -- Haskell version of bst.ps with `seq` to try to improve performance 2 | 3 | data Bst = Mt | Node Bst Int Bst 4 | type Ints = [Int] 5 | 6 | list_bst :: Ints -> Bst 7 | list_bst xs = list_bst_acc xs Mt 8 | 9 | list_bst_acc :: Ints -> Bst -> Bst 10 | list_bst_acc xs t0 = 11 | case xs of 12 | (x:xs1) -> 13 | let t1 = bst_insert x t0 14 | in t1 `seq` list_bst_acc xs1 t1 15 | [] -> t0 16 | 17 | bst_insert :: Int -> Bst -> Bst 18 | bst_insert x t0 = 19 | case t0 of 20 | Mt -> Node Mt x Mt 21 | (Node l n r) -> 22 | if x <= n then 23 | let t1 = bst_insert x l 24 | in t1 `seq` Node t1 n r 25 | else 26 | let t1 = bst_insert x r 27 | in t1 `seq` Node l n t1 28 | 29 | bst_size :: Bst -> Int 30 | bst_size t = 31 | case t of 32 | Mt -> 0 33 | (Node l n r) -> 1 + (bst_size l) + (bst_size r) 34 | 35 | tst = bst_size (list_bst [1..10]) 36 | 37 | main = do print (bst_size (list_bst [1..30000])) 38 | -- C;ghc -O3 hsbst.hs ; time ./hsbst 39 | -- [1 of 1] Compiling Main ( hsbst.hs, hsbst.o ) 40 | -- Linking hsbst ... 41 | -- 10000 42 | -- 43 | -- real 0m11.908s 44 | -- user 0m11.855s 45 | -- sys 0m0.028s 46 | -- C;ghc -O3 hsbst.hs ; time ./hsbst 47 | -- [1 of 1] Compiling Main ( hsbst.hs, hsbst.o ) 48 | -- Linking hsbst ... 49 | -- 30000 50 | -- 51 | -- real 3m50.300s 52 | -- user 3m49.509s 53 | -- sys 0m0.280s 54 | 55 | 56 | -------------------------------------------------------------------------------- /bench/makefile: -------------------------------------------------------------------------------- 1 | # makefile for Pawns stuff - try out make pattern rules etc 2 | 3 | # Size of tree for testing bst.pns, pbst.pns (if Max=0 we use a default 4 | # small list and test some higher order stuff). If Max>1400 or so its 5 | # too big without GC for some default limits on process size etc. 6 | # not actually used - see code 7 | Max=12000 8 | Max=30000 9 | Max=0 10 | 11 | # gcc -O3 does a great job 12 | # for Max=30000 without -O pbst gets killed but is ~3.5 times bst 13 | # without -O we get bst 12.5s, pbst 30+?s, cbst 2.4s, gcbst 2.3s 14 | # with -O3 we get bst 0.81, pbst 16.67s, cbst 1.65s, gcbst 1.64s 15 | # A bit weird...? 16 | CC=gcc 17 | 18 | # adt stuff causes *lots* of warnings due to implicit coercion between 19 | # things with size sizeof(void*) currently, so we turn off all warnings 20 | # with -w (for now XXX useful to have them when mixing C and Pawns) 21 | # Also, we need -Wno-incompatible-pointer-types -Wno-int-conversion for 22 | # more recent versions of gcc (some old warnings are now errors) 23 | CFLAGS=-w -Wno-incompatible-pointer-types -Wno-int-conversion 24 | CFLAGS=-O3 -w -Wno-incompatible-pointer-types -Wno-int-conversion 25 | 26 | # We need to link with the (Boehm++) garbage collector currently, which 27 | # should really be installed somewhere standard, but just in case its 28 | # not. gc details at http://www.hboehm.info/gc/ 29 | GCLIB=~/lib/gc/lib 30 | GC=gc 31 | LDLIBS=-Wl,-rpath -Wl,$(GCLIBDIR) -l$(GC) 32 | # LDFLAGS=-Wl,-rpath -Wl,$(GCLIBDIR) -l$(GC) 33 | 34 | 35 | # install these somewhere, eg ~/bin at least 36 | PNSC=~/bin/pnsc 37 | ADTPP=../../../adt4c/src/adtpp 38 | ADTPP=~/bin/adtpp 39 | 40 | # The Pawns "compiler" converts foo.pns to foo.c and foo.adt and the 41 | # latter is converted to foo.h by adtpp. foo.c requires foo.h and 42 | # foo.adt should generally not be touched by the user so we can package 43 | # up these two steps together as follows. Make doesn't clean up foo.h 44 | # or foo.adt, but we might want to use the former in our C code and the 45 | # latter can easily be cleaned up and is small anyway. 46 | # adtpp is currently rather noisey so we put the output in a file 47 | # (XXX we include pawns.h as a dependency here for development purposes) 48 | %.c %.h : %.pns pawns.h 49 | $(PNSC) $< 50 | $(ADTPP) $*.adt > adtpp.errs 51 | 52 | # the adtpp tool takes a foo.adt file and generates a foo.h file 53 | # (not needed for Pawns if we use the combined rule but it does no harm 54 | # and can be useful for C code) 55 | %.h : %.adt 56 | $(ADTPP) $< 57 | 58 | .bogus: all 59 | all: bst pbst cbst cpinfbst cpibst cpbst cpigbst hssbst hspbst hsrbst # mlpbst mlrbst 60 | 61 | .bogus: times 62 | times: all 63 | echo 64 | echo '------------ Pawns with DU' 65 | -time ./bst 66 | echo 67 | echo '------------ C with malloc, DU' 68 | -time ./cbst 69 | # echo 70 | # echo '------------ C with GC_malloc' 71 | # -time ./gcbst 72 | # echo 73 | # echo '------------ MLton with Ref, DU' 74 | # -time ./mlrbst 75 | echo 76 | echo '------------ Haskell with STRef, DU' 77 | -time ./hsrbst 78 | # echo 79 | # echo '------------ MLton no DU' 80 | # -time ./mlpbst 81 | echo 82 | echo '------------ Pawns no DU' 83 | -time ./pbst 84 | echo 85 | echo '------------ C iterative GC_malloc no free no DU' 86 | -time ./cpinfbst 87 | echo 88 | echo '------------ Haskell with seq but no DU' 89 | -time ./hssbst 90 | echo 91 | echo '------------ C iterative GC_malloc no DU' 92 | -time ./cpigbst 93 | echo 94 | echo '------------ C iterative no DU' 95 | -time ./cpibst 96 | echo 97 | echo '------------ C no DU' 98 | -time ./cpbst 99 | echo 100 | echo '------------ Haskell no DU' 101 | -time ./hspbst 102 | 103 | # bst.pns imports bstmain.pns, io.pns 104 | bst.c : bst.pns bstmain.pns io.pns pawns.h builtin.h 105 | 106 | # pbst.pns imports bstmain.pns, io.pns 107 | pbst.c : pbst.pns bstmain.pns io.pns pawns.h builtin.h 108 | 109 | io.pns: ../examples/io.pns 110 | cp $< . 111 | 112 | pawns.h: ../compiler/pawns.h 113 | cp $< . 114 | 115 | builtin.h: ../compiler/builtin.h 116 | cp $< . 117 | 118 | gcbst.c : cbst.c 119 | tail -n +3 cbst.c > gcbst.c 120 | 121 | cpigbst.c : cpibst.c 122 | tail -n +3 cpibst.c > cpigbst.c 123 | 124 | # should do cpinfbst.c like above 125 | 126 | cbst.o : cbst.c bst.h 127 | 128 | cpbst.o : cpbst.c bst.h 129 | 130 | cpinfbst.o : cpinfbst.c bst.h 131 | 132 | cpibst.o : cpibst.c bst.h 133 | 134 | cpigbst.o : cpigbst.c bst.h 135 | 136 | gcbst.o : gcbst.c bst.h 137 | 138 | hspbst : hspbst.hs 139 | ghc -O3 $< 140 | 141 | hssbst : hssbst.hs 142 | ghc -O3 $< 143 | 144 | hsrbst : hsrbst.hs 145 | ghc -O3 $< 146 | 147 | mlpbst : mlpbst.sml 148 | mlton $< 149 | 150 | mlrbst : mlrbst.sml 151 | mlton $< 152 | 153 | .bogus: clean 154 | clean: 155 | rm -f *.adt *.o *.h.gch bst.h bst.c pbst.h pbst.c adtpp.errs 156 | rm -f io.pns pawns.h builtin.h 157 | rm -f hsrbst.hi hssbst.hi hspbst.hi tmp* a.out 158 | -rm -i bst pbst cpinfbst cpibst cpbst cbst cpigbst gcbst hsrbst hssbst hspbst mlpbst mlrbst 159 | 160 | # :set noet ts=8 161 | -------------------------------------------------------------------------------- /bench/ml/mlpbst.sml: -------------------------------------------------------------------------------- 1 | (* SML bst - "pure" version *) 2 | 3 | datatype tree = mt | node of tree * int * tree; 4 | 5 | fun ints_from_to(min, max) = 6 | if min <= max then 7 | min :: ints_from_to (min+1, max) 8 | else 9 | []; 10 | 11 | fun bst_size(t) = 12 | case t of 13 | mt => 0 14 | | node (l, n, r) => 1 + bst_size(l) + bst_size(r); 15 | 16 | fun bst_insert(x, t0) = 17 | case t0 of 18 | mt => node(mt, x, mt) 19 | | node(l, n, r) => 20 | if x<=n then 21 | node(bst_insert(x, l), n, r) 22 | else 23 | node(l, n, bst_insert(x, r)); 24 | 25 | fun list_bst_acc(xs, t0) = 26 | case xs of 27 | [] => t0 28 | | (x:: xs1) => list_bst_acc(xs1, bst_insert(x, t0)); 29 | 30 | fun list_bst(xs) = list_bst_acc(xs, mt); 31 | 32 | fun test n = bst_size(list_bst(ints_from_to(1,n))); 33 | 34 | print (Int.fmt StringCvt.DEC (test 30000)); 35 | print "\n"; 36 | -------------------------------------------------------------------------------- /bench/ml/mlrbst.sml: -------------------------------------------------------------------------------- 1 | (* SML bst with refs and := *) 2 | 3 | datatype tree = mt | node of (tree ref) * int * (tree ref); 4 | 5 | fun ints_from_to(min, max) = 6 | if min <= max then 7 | min :: ints_from_to (min+1, max) 8 | else 9 | []; 10 | 11 | fun bst_size(t) = 12 | case t of 13 | mt => 0 14 | | (node (l, n, r)) => 1 + bst_size(!l) + bst_size(!r); 15 | 16 | fun bst_insert_du(x, t0) = 17 | case t0 of 18 | ref mt => t0 := node(ref mt, x, ref mt) 19 | | ref (node(l, n, r)) => 20 | if x<=n then 21 | bst_insert_du(x, l) 22 | else 23 | bst_insert_du(x, r); 24 | 25 | fun list_bst_du(xs, t0) = 26 | case xs of 27 | [] => () 28 | | (x:: xs1) => 29 | let in 30 | bst_insert_du(x, t0); 31 | list_bst_du(xs1, t0) 32 | end; 33 | 34 | fun list_bst(xs) = 35 | let val tp = ref mt in 36 | list_bst_du(xs, tp); 37 | !tp 38 | end; 39 | 40 | fun test n = bst_size(list_bst(ints_from_to(1,n))); 41 | 42 | print (Int.fmt StringCvt.DEC (test 30000)); 43 | print "\n"; 44 | -------------------------------------------------------------------------------- /bench/ml/mltbst.cml: -------------------------------------------------------------------------------- 1 | (* OCAML bst start of attempt with mutable records *) 2 | 3 | datatype tree = mt | 4 | node of {mutable left:(tree ref), item:int, mutable right:(tree ref)}; 5 | 6 | (* hmm this may avoid extra indirection but gives ugly structure for 7 | code - can't start with ref to empty tree etc *) 8 | 9 | (* 10 | fun ints_from_to(min, max) = 11 | if min <= max then 12 | min :: ints_from_to (min+1, max) 13 | else 14 | []; 15 | 16 | fun bst_size(t) = 17 | case t of 18 | mt => 0 19 | | (node (l, n, r)) => 1 + bst_size(!l) + bst_size(!r); 20 | 21 | fun bst_insert_du(x, t0) = 22 | case t0 of 23 | ref mt => t0 := node(ref mt, x, ref mt) 24 | | ref (node(l, n, r)) => 25 | if x<=n then 26 | bst_insert_du(x, l) 27 | else 28 | bst_insert_du(x, r); 29 | 30 | fun list_bst_du(xs, t0) = 31 | case xs of 32 | [] => () 33 | | (x:: xs1) => 34 | let in 35 | bst_insert_du(x, t0); 36 | list_bst_du(xs1, t0) 37 | end; 38 | 39 | fun list_bst(xs) = 40 | let val tp = ref mt in 41 | list_bst_du(xs, tp); 42 | !tp 43 | end; 44 | 45 | fun test n = bst_size(list_bst(ints_from_to(1,n))); 46 | 47 | print (Int.fmt StringCvt.DEC (test 30000)); 48 | *) 49 | print "\n"; 50 | -------------------------------------------------------------------------------- /bench/mlpbst.sml: -------------------------------------------------------------------------------- 1 | (* SML bst - "pure" version *) 2 | 3 | datatype tree = mt | node of tree * int * tree; 4 | 5 | fun ints_from_to(min, max) = 6 | if min <= max then 7 | min :: ints_from_to (min+1, max) 8 | else 9 | []; 10 | 11 | fun bst_size(t) = 12 | case t of 13 | mt => 0 14 | | node (l, n, r) => 1 + bst_size(l) + bst_size(r); 15 | 16 | fun bst_insert(x, t0) = 17 | case t0 of 18 | mt => node(mt, x, mt) 19 | | node(l, n, r) => 20 | if x<=n then 21 | node(bst_insert(x, l), n, r) 22 | else 23 | node(l, n, bst_insert(x, r)); 24 | 25 | fun list_bst_acc(xs, t0) = 26 | case xs of 27 | [] => t0 28 | | (x:: xs1) => list_bst_acc(xs1, bst_insert(x, t0)); 29 | 30 | fun list_bst(xs) = list_bst_acc(xs, mt); 31 | 32 | fun test n = bst_size(list_bst(ints_from_to(1,n))); 33 | 34 | print (Int.fmt StringCvt.DEC (test 30000)); 35 | print "\n"; 36 | -------------------------------------------------------------------------------- /bench/mlrbst.sml: -------------------------------------------------------------------------------- 1 | (* SML bst with refs and := *) 2 | 3 | datatype tree = mt | node of (tree ref) * int * (tree ref); 4 | 5 | fun ints_from_to(min, max) = 6 | if min <= max then 7 | min :: ints_from_to (min+1, max) 8 | else 9 | []; 10 | 11 | fun bst_size(t) = 12 | case t of 13 | mt => 0 14 | | (node (l, n, r)) => 1 + bst_size(!l) + bst_size(!r); 15 | 16 | fun bst_insert_du(x, t0) = 17 | case t0 of 18 | ref mt => t0 := node(ref mt, x, ref mt) 19 | | ref (node(l, n, r)) => 20 | if x<=n then 21 | bst_insert_du(x, l) 22 | else 23 | bst_insert_du(x, r); 24 | 25 | fun list_bst_du(xs, t0) = 26 | case xs of 27 | [] => () 28 | | (x:: xs1) => 29 | let in 30 | bst_insert_du(x, t0); 31 | list_bst_du(xs1, t0) 32 | end; 33 | 34 | fun list_bst(xs) = 35 | let val tp = ref mt in 36 | list_bst_du(xs, tp); 37 | !tp 38 | end; 39 | 40 | fun test n = bst_size(list_bst(ints_from_to(1,n))); 41 | 42 | print (Int.fmt StringCvt.DEC (test 30000)); 43 | print "\n"; 44 | -------------------------------------------------------------------------------- /bench/pbst.pns: -------------------------------------------------------------------------------- 1 | % bst stuff: conversion from list of ints to bst of ints 2 | % pure version (see bst.pns for destructive update version) 3 | 4 | import from bstmain. 5 | import print_int from io. 6 | 7 | main :: void -> void 8 | implicit rw io. 9 | main(v) = !bstmain(v). 10 | 11 | type bst ---> mt ; node(bst, int, bst). 12 | type ints = list(int). 13 | 14 | % convert list to bst 15 | list_bst :: ints -> bst. 16 | list_bst(xs) = list_bst_acc(xs, mt). 17 | 18 | % add list of ints to tree and return new tree 19 | % accumulator version used so order of insertion is L-R 20 | list_bst_acc :: ints -> bst -> bst. 21 | list_bst_acc(xs, t0) = { 22 | cases xs of { 23 | case cons(x, xs1): 24 | list_bst_acc(xs1, bst_insert(x, t0)) 25 | case nil: 26 | t0 27 | } 28 | }. 29 | 30 | % insert by constructing new path 31 | bst_insert :: int -> bst -> bst. 32 | % sharing bst_insert_du(x, t0) = t 33 | % pre nosharing 34 | % post t1 = t. % int keys don't share 35 | bst_insert(x, t0) = { 36 | cases t0 of { 37 | case mt: 38 | node(mt, x, mt) 39 | case node(l, n, r): 40 | if x <= n then 41 | node(bst_insert(x, l), n, r) 42 | else 43 | node(l, n, bst_insert(x, r)) 44 | } 45 | }. 46 | -------------------------------------------------------------------------------- /compiler/.bcdrc: -------------------------------------------------------------------------------- 1 | alias vv='vim pawns.pl' 2 | alias vcc='vim comp.pl' 3 | alias vho='vim ../examples/ho.pns' 4 | alias vbs='vim ../examples/bst.pns ' 5 | alias vimp='vim ../examples/imp.pns' 6 | alias vb='vim Bugs ' 7 | -------------------------------------------------------------------------------- /compiler/.exrc: -------------------------------------------------------------------------------- 1 | set exrc 2 | set ts=8 noet 3 | set ts=4 et 4 | map !! :w :!latex tplp;dvips tplp 5 | map !! :w :!latex tplp 6 | map !! :w :!latex talk;dvips talk 7 | map !! :w :!latex talk 8 | set wrapmargin=8 9 | set wrapscan 10 | map !w :set wrapmargin=0 nowrapscan 11 | map q :wq 12 | map N :w :n 13 | map z :w  14 | map %$ :'c,.s/^/% / 15 | map %^ :'c,.s/^% // 16 | map %t :%s/ / /g 17 | map , Ea,' 18 | map !d :.! date 19 | map !u :.! date -u 20 | map !q Bi``Ea'' 21 | map !t Bi\texttt{Ea} 22 | map !v Bi\verb@Ea@ 23 | map !c Bi\cite{Ea} 24 | map !b bi\textbf{ea} 25 | map !i bi\emph{ea} 26 | map !e :s/^.*$/& &/ i\end{A}-i\begin{A}a 27 | map !r :s/^.*$/& &/ A-i+A 28 | map !f !{fmt 29 | map !h1 0i\section{$a} 30 | map !h2 0i\subsection{$a} 31 | map !h3 0i\subsubsection{$a} 32 | ab veR \begin{verbatim} \end{verbatim} 33 | ab itE \begin{itemize} \item \end{itemize} 34 | ab enU \begin{enumerate} \item \end{enumerate} 35 | ab taB \begin{tabular}{lr} \end{tabular} 36 | ab fiG \begin{figure} \begin{center} \end{center} % \caption{} \label{fig_f} \end{figure} 37 | ab bwS \begin{bwslide} \Heading{x} \end{bwslide} 38 | ab iT \item 39 | -------------------------------------------------------------------------------- /compiler/Bugs: -------------------------------------------------------------------------------- 1 | Incomplete list of bugs/limitations 2 | 3 | % XXX type error (q, not *q) -> Oops! alias_stat failed! 4 | % post mbs = mbs1. % XXX type error not detected (-> fail) 5 | in duspec.pns 6 | 7 | % **!g2r := r2rc2(c2ra); % XXX Error: function call as LHS of := (ignored)(**!g2r) 8 | rectype.pns 9 | 10 | See XXX in code 11 | 12 | Check C code output where var is declared in different branches of if/etc - 13 | looks like C var scope is wrong. Need to move declaration before if and just 14 | have assignment in the branches (treat it like :=). 15 | 16 | calling undefine function -> barf(?) 17 | 18 | See use_closure_ret in state.pns - can we avoid precondition being added to 19 | post-sharing here? 20 | 21 | Type casting in code - currrently looks like 22 | n = (nil :: list('_type_param'(1))) 23 | ugly A F. Need to use version of 24 | read that captures (type) var names and effectively have scope 25 | being declaration of function plus function definition. A bit 26 | messy but not too bad. Now redone so type casts rarely ndded - compiler 27 | instantaiates types. 28 | 29 | Various things to fix in sharing analysis - see paper for 30 | "final" version of algorithm (that now out of date since abstract domain is 31 | more expressive) 32 | 33 | Functions with multiple args, some of which are void cause C 34 | code with void args (error). eg 35 | ints1 :: bst -> list(int) -> void -> ints 36 | sharing ints1(a_bst,a_ints,v) = ns 37 | pre nosharing 38 | post ns=a_ints. 39 | ints1(a_bst, a_ints, v) = { 40 | is = cons(4, cons(2, cons(1, cons(3, nil)))); 41 | return(is) 42 | }. 43 | This is a bit of a pain to fix with higher order etc? 44 | 45 | Maximum number of args in closure - should use polymorphic 46 | list of args if there are too many. 47 | 48 | see example/bst_poly.pns 49 | p ../examples/ 50 | ~/bin/pnsc bst_poly.pns 51 | vim bst_poly.pns 52 | 53 | examples/rectype.pns 54 | % f1(a) = r2c1(r2c2(a)). % XXX should get redefinition error 55 | 56 | pawns.pl: 57 | % XXXX Possible BUG if we have a function as an argument and it has two 58 | % closure arguments that share... 59 | 60 | p ../examples/dse 61 | ~/bin/pnsc scope_bug.pns 62 | ... 63 | sharing analysis of (q_empty) 64 | ERROR: Prolog initialisation failed: 65 | ERROR: assert/1: Cannot represent due to `cyclic_term' 66 | ??? works fine with sim.pns... 67 | could be from assert in type_struct/2? 68 | 69 | impure function calls in expression - ! gets lost in trf 70 | eg ../examples/dse/sim.pns 71 | numitems = !random_num(void) mod 23 + 1; 72 | 73 | -------------------------------------------------------------------------------- /compiler/README.md.src: -------------------------------------------------------------------------------- 1 | # Pawns, version VERSION 2 | 3 | Pawns (Pointer Assignment Without Nasty Surprises) is a 4 | declarative/imperative language. It supports typical features of a strict 5 | functional language such as algebraic data types, polymorphism, higher 6 | order programming and pure (referentially transparent) functions. It also 7 | supports imperative features such as destructive update via pointers and 8 | a form of global variables (including IO). Unlike other declarative/imperative 9 | languages, all data constructor arguments can have pointers to them and 10 | be updated, all side-effects in the code are made obvious by annotations 11 | and impure code can be encapsulated inside a pure function. The 12 | compiler checks annotations and purity by analysis of data structure 13 | sharing. Functions that may update their arguments have additional 14 | declarations concerning update and sharing. 15 | 16 | Language and implementation by 17 | [Lee Naish](https://lee-naish.github.io/). 18 | It's basicaly a proof of concept for what I think are some neat language 19 | ideas that tackle a difficult problem in programming language design - 20 | definitely not a polished product! 21 | 22 | # Pawns home page 23 | Since 2022 the home page has been https://lee-naish.github.io/src/pawns/ 24 | (tinyurl.com/pawns-lang points to an outdated version). 25 | This has links to (among other things): 26 | 27 | - A brief overview of the language: 28 | This is not necessarily up to date, misses some features, 29 | and the syntax is not what is supported - see note below. 30 | 31 | - An informal introduction to the language: 32 | Older than the overview and much harder to read but covers a few more 33 | things. 34 | 35 | - Slides for a couple of talks 36 | 37 | - A paper on the sharing analysis done in the compiler: 38 | The implementation 39 | here has some known bugs corrected in the paper, meaning you can write 40 | dodgey code and the compiler won't complain as it should. See comments 41 | in the source code. However, it also has some enhancements to make sharing 42 | more precise, meaning you can write correct code that passes the compiler 43 | even though the analysis in the paper would result in error messages. 44 | The paper may be updated to reflect this at some point. 45 | 46 | 47 | # Requirements 48 | 49 | The system is also not packaged well currently. My development machine 50 | is laptop running Ubuntu. I've not ported it elsewhere but after doing 51 | several years worth of upgrades it still built with no problems so the 52 | Ubuntu build seems to be on solid foundations. If you can't get it to 53 | work on your chosen platform I will gladly return your money but not 54 | return your time:( 55 | It needs 56 | 57 | - 1) SWI-Prolog: 58 | See https://www.swi-prolog.org/build/unix.html, eg 59 | sudo apt-get install software-properties-common 60 | sudo apt-add-repository ppa:swi-prolog/stable 61 | sudo apt-get update 62 | sudo apt-get install swi-prolog 63 | 64 | - 2) Boehm et al. garbage collector: 65 | sudo apt-get install libgc-dev 66 | 67 | - 3) adtpp tool installed in ~/bin/adtpp: 68 | This is in a public git 69 | repository and requires flex, yacc and gcc. 70 | sudo apt-get install git 71 | git clone https://github.com/lee-naish/adtpp 72 | sudo apt install flex 73 | sudo apt install bison 74 | mkdir ~/bin 75 | cd adtpp/src 76 | make install 77 | 78 | - 4) pawns.h in current directory 79 | 80 | - 5) gcc (other C compilers should be ok also) 81 | 82 | 83 | # Repository contents 84 | 85 | - compiler/: 86 | Source for compiler, pnsc. 87 | "pnsc foo.pns" will compile foo.pns to foo.c and foo.adt (algebraic data 88 | type definitions that adtpp will convert to C). See examples/makefile 89 | for make convenient rules etc 90 | To install the compiler in ~/bin, use: 91 | "cd compiler 92 | make install" 93 | 94 | - examples/: 95 | Example Pawns code (with makefile and other files needed etc) 96 | 97 | - bench: 98 | Some benchmarks (binary tree insertion...) in various languages 99 | 100 | 101 | # Syntax 102 | 103 | People have always argued way too much about the syntax of programming 104 | languages, at the expense of semantics, which is the important thing. 105 | What was that Phil Wadler quote...? There are two things I have done 106 | which may counter this trend for Pawns. First, the papers written so far 107 | have used a fake syntax based on Haskell. Second, I think we can *all* 108 | agree that the actual supported syntax is awful. It was chosen to make 109 | the implementation easy - I had better things to do than write a parser 110 | (which would also require more serious thoughts about syntax) so I just 111 | used Prolog syntax with a bunch of operators declared and used 'read' 112 | in Prolog to do all the parsing. This means various things need to be 113 | terminated with '.', the Prolog tokeniser is used, and various things 114 | need parentheses or braces. I have not properly described the syntax - 115 | best look at examples for now. However, none of this is set in stone. 116 | The start of a Pawns source code file, up to the first blank line, 117 | is ignored as far as code is concerned. It can be used for a #! line, 118 | meta-data, directives etc. These could include a directive to say what 119 | syntax is used in the rest of the file. Currently its just ignored, 120 | so best make sure you start with a block of comments or at least a blank 121 | line, or your first bit of code will mysteriously get ignored. 122 | 123 | -------------------------------------------------------------------------------- /compiler/Readme: -------------------------------------------------------------------------------- 1 | Pawns compiler source etc 2 | 3 | Readme: You are reading it! 4 | 5 | pawns.pl comp.pl: SWI-Prolog source for compiler (should be split up 6 | into more files) 7 | 8 | The next few things are not needed here but currently must be in dir 9 | where Pawns code is compiled 10 | 11 | apply.h apply.c: src for higher order "apply", compiled and linked 12 | with executables 13 | apply.adt: src for apply.h (generated by adtpp tool) 14 | apply1.pns: obsolete Pawns source (basis of apply.c) 15 | pawns.h builtin.h: stuff for some builtin types/fns; should be builtin.adt 16 | somewhere???? 17 | 18 | makefile: makefile 19 | 20 | Readme.src: source for ../Readme (we plug in version number) 21 | 22 | .bcdrc .exrc: Lee's bash environment stuff etc 23 | 24 | -------------------------------------------------------------------------------- /compiler/Readme.src: -------------------------------------------------------------------------------- 1 | Pawns: a declarative/imperative language 2 | (Pointer Assignment Without Nasty Surprises) 3 | Version: VERSION 4 | Initial development by Lee Naish 5 | (basicaly a proof of concept for what I think are some neat language 6 | ideas that tackle a difficult problem in programming language design; 7 | definitely not a polished product) 8 | 9 | Pawns home page (moved in 2022): 10 | https://lee-naish.github.io/src/pawns/ 11 | (tinyurl.com/pawns-lang points to old version) 12 | 13 | This has links to: 14 | 15 | An informal introduction to the language (not necessarily up to date, 16 | or presented particularly well, and the syntax is not what is supported - 17 | see note below). 18 | 19 | Also a paper on the sharing analysis done in the compiler (the src version 20 | here has some known bugs corrected in the paper, meaning you can write 21 | dodgey code and the compiler won't complain as it should). See comments 22 | in the source code. However, it also has some enhancements to make sharing 23 | moreprecise, meaning you can write correct code that passes the compiler 24 | even though the analysis in the paper would result in error messages. 25 | The paper may be updated to reflect this at some point. 26 | 27 | The system is also not packaged well currently and my development machine 28 | (a laptop running Ubuntu) has rather old hardware and software. If you 29 | can't get it to work on your chosen platform I'll gladly return your money 30 | but I can't return your time:( 31 | 32 | It needs 33 | 34 | 1) SWI-Prolog: 35 | sudo apt-get install swi-prolog-nox 36 | 37 | 2) Boehm++ garbage collector: 38 | sudo apt-get install libgc-dev 39 | 40 | 3) adtpp/adt4c tool installed in ~/bin/adtpp: 41 | sudo apt-get install git 42 | git clone https://github.com/cjack/Adt4c 43 | cd Adt4c/src 44 | make install 45 | (a more up to date version is at 46 | https://bitbucket.org/Macnaa/adt4c-with-polymorphism.git) 47 | 48 | 4) pawns.h in current dir 49 | 50 | 5) gcc (other C compilers should be ok also) 51 | 52 | -------------------------------------------------------------- 53 | 54 | We currently have 55 | 56 | compiler: source for compiler 57 | 58 | examples: example Pawns code (with makefile and other files needed etc) 59 | 60 | bench: some benchmarks (binary tree insertion...) in various languages 61 | 62 | -------------------------------------------------------------- 63 | 64 | Note re syntax 65 | 66 | People have always argued way too much about the syntax of programming 67 | languages, at the expense of semantics, which is the important thing. 68 | What was that Phil Wadler quote...? There are two things I have done 69 | which may counter this trend for Pawns. First, the papers written so far 70 | have used a fake syntax based on Haskell. Second, I think we can *all* 71 | agree that the actual supported syntax is awful. It was chosen to make 72 | the implementation easy - I had better things to do than write a parser 73 | (which would also require more serious thoughts about syntax) so I just 74 | used Prolog syntax with a bunch of operators declared and used 'read' 75 | in Prolog to do all the parsing. This means various things need to be 76 | terminated with '.', the Prolog tokeniser is used, and various things 77 | need parentheses or braces. I have not properly described the syntax - 78 | best look at examples for now. However, none of this is set in stone. 79 | The start of a Pawns source code file, up to the first blank line, 80 | is ignored as far as code is concerned. It can be used for a #! line, 81 | meta-data, directives etc. These could include a directive to say what 82 | syntax is used in the rest of the file. Currently its just ignored, 83 | so best make sure you start with a block of comments or at least a blank 84 | line, or your first bit of code will mysteriously get ignored. 85 | 86 | -------------------------------------------------------------------------------- /compiler/apply.adt: -------------------------------------------------------------------------------- 1 | // included in builtin.adt 2 | data _closure { 3 | _cl_delete_this_when_adtpp_fixed(); 4 | _cl0(_func_ptr, intptr_t); 5 | _cl1(_func_ptr, intptr_t, _void_ptr); 6 | _cl2(_func_ptr, intptr_t, _void_ptr, _void_ptr); 7 | _cl3(_func_ptr, intptr_t, _void_ptr, _void_ptr, _void_ptr); 8 | _cl4(_func_ptr, intptr_t, _void_ptr, _void_ptr, _void_ptr, _void_ptr); 9 | } 10 | -------------------------------------------------------------------------------- /compiler/apply.c: -------------------------------------------------------------------------------- 1 | // now copied to pawns.h 2 | 3 | typedef void *_void_ptr; 4 | typedef void (*_func_ptr)(void*); 5 | #include "apply.h" 6 | 7 | void * 8 | apply(_closure cl, void *a1) { 9 | _func_ptr r; 10 | void *ca1, *ca2, *ca3, *ca4; 11 | intptr_t aty; 12 | 13 | switch__closure(cl) 14 | case__cl0(f, aty) 15 | if (aty==1) 16 | return (*(void*(*)(void*))f)(a1); 17 | else 18 | return (void *) _cl1(f, aty, a1); 19 | case__cl1(f, aty, ca1) 20 | if (aty==2) 21 | return (*(void*(*)(void*,void*))f)(ca1, a1); 22 | else 23 | return (void *) _cl2(f, aty, ca1, a1); 24 | case__cl2(f, aty, ca1, ca2) 25 | if (aty==3) 26 | return (*(void*(*)(void*,void*,void*))f)(ca1, ca2, a1); 27 | else 28 | return (void *) _cl3(f, aty, ca1, ca2, a1); 29 | case__cl3(f, aty, ca1, ca2, ca3) 30 | if (aty==4) 31 | return (*(void*(*)(void*,void*,void*,void*))f)(ca1, ca2, ca3, a1); 32 | else 33 | return (void *) _cl4(f, aty, ca1, ca2, ca3, a1); 34 | case__cl4(f, aty, ca1, ca2, ca3, ca4) 35 | return (*(void*(*)(void*,void*,void*,void*,void*))f)(ca1, ca2, ca3, ca4, a1); 36 | end_switch() 37 | } 38 | 39 | -------------------------------------------------------------------------------- /compiler/apply1.pns: -------------------------------------------------------------------------------- 1 | % Pawns code for apply etc 2 | % Now coded directly in C (this is not well-typed) 3 | 4 | apply:: '_closure' -> ref(void) -> ref(void). 5 | apply(cl, a1): 6 | cases cl of ( 7 | case '_cl0'(f, aty): 8 | cases aty==1 of ( 9 | case true: f(a1) 10 | case false: '_cl1'(f, aty, a1) 11 | ) 12 | case '_cl1'(f, aty, ca1): 13 | cases aty==2 of ( 14 | case true: f(ca1, a1) 15 | case false: '_cl2'(f, aty, ca1, a1) 16 | ) 17 | case '_cl2'(f, aty, ca1, ca2): 18 | cases aty==2 of ( 19 | case true: f(ca1, ca2, a1) 20 | case false: '_cl3'(f, aty, ca1, ca2, a1) 21 | ) 22 | case '_cl3'(f, aty, ca1, ca2, ca3): 23 | cases aty==2 of ( 24 | case true: f(ca1, ca2, ca3, a) 25 | case false: '_cl4'(f, aty, ca1, ca2, ca3, a1) 26 | ) 27 | case '_cl4'(f, aty, ca1, ca2, ca3, ca4): 28 | f(ca1, ca2, ca3, ca4, a1) 29 | ). 30 | -------------------------------------------------------------------------------- /compiler/builtin.adt: -------------------------------------------------------------------------------- 1 | // builtin types for Pawns in adtpp syntax 2 | // (should add more) 3 | // used to construct builtin.h 4 | 5 | // XXX currently closure arg numbers are limited 6 | data _closure { 7 | _cl0(_func_ptr, intptr_t); 8 | _cl1(_func_ptr, intptr_t, _void_ptr); 9 | _cl2(_func_ptr, intptr_t, _void_ptr, _void_ptr); 10 | _cl3(_func_ptr, intptr_t, _void_ptr, _void_ptr, _void_ptr); 11 | _cl4(_func_ptr, intptr_t, _void_ptr, _void_ptr, _void_ptr, _void_ptr); 12 | } 13 | 14 | data pair { 15 | t2(_void_ptr, _void_ptr); 16 | } 17 | 18 | data maybe { 19 | nothing(); 20 | just(_void_ptr); 21 | } 22 | 23 | data list { 24 | nil(); 25 | cons(_void_ptr, list); 26 | } 27 | 28 | data PAWNS_bool { 29 | PAWNS_false(); 30 | PAWNS_true(); 31 | } 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /compiler/makefile: -------------------------------------------------------------------------------- 1 | # makefile for Pawns compiler: 2 | # just two SWI-Prolog files with compile/0 as top level pred to call 3 | # 4 | # The Pawns header file which is needed everywhere included 5 | # some code generated by adtpp 6 | # The README.md for the dist is created using the master version 7 | # number which is defined here 8 | # 9 | # Generate VERSION line with: date +'VERSION = 1.%y%m%d' 10 | # or in vim: :/^VERSION /!date +'VERSION = 1.\%y\%m\%d' 11 | 12 | VERSION = 1.250416 13 | 14 | ADTPP=~/bin/adtpp 15 | 16 | pnsc: pawns.pl comp.pl 17 | swipl -o pnsc -g compile -c pawns.pl comp.pl 18 | 19 | install: pnsc 20 | cp pnsc ~/bin/pnsc 21 | 22 | uninstall: 23 | rm ~/bin/pnsc 24 | 25 | builtin.h: builtin.adt 26 | $(ADTPP) $< 27 | 28 | README.md : README.md.src makefile 29 | sed s/VERSION/$(VERSION)/ < README.md.src > README.md 30 | 31 | .PHONY: ..README 32 | ..README: README.md 33 | cp README.md .. 34 | 35 | .PHONY: clean 36 | clean: 37 | rm -rf pnsc tmp* Readme.. 38 | 39 | # :set noet ts=8 40 | 41 | -------------------------------------------------------------------------------- /compiler/pawns.h: -------------------------------------------------------------------------------- 1 | #ifndef PAWNS_H 2 | #define PAWNS_H 3 | // Header file for compiled Pawns code. 4 | // Defines some builtin types and functions. 5 | // The type stuff is generated by adtpp but we need to prefix 6 | // it and postfix it with other stuff so we have two files. 7 | // XXX They should be installed somewhere and included with 8 | // instead of "pawns.h". 9 | // We could get the Pawns compiler to inline some of this but we get gcc to 10 | // do it instead. The functions are static so they can be defined in 11 | // several files which are linked. 12 | // Could separate some stuff and put in in a library instead 13 | // XXX need to add a bunch more (see also comp.pl) 14 | // bool is munged by prefixing with PAWNS_ - maybe do the same for int 15 | // XXX probably should migrate compiled version of 16 | // ../examples/array.pns here also 17 | 18 | // GC stuff - gcc flags don't seem to work 19 | // adtpp allows us to override default malloc/free 20 | #define ADT_MALLOC(s) GC_MALLOC(s) 21 | #define ADT_FREE(s) GC_FREE(s) 22 | // Last time I looked, 23 | // by default the Boehm et al garbage collector .h file has 24 | // #define GC_MALLOC(s) GC_malloc(s) 25 | // #define GC_FREE(s) GC_free(s) 26 | // and prototypes for these functions. This should be 27 | // sufficient if gc.h isn't installed properly or you want to 28 | // avoid reading it. 29 | #include 30 | 31 | #include // need intptr_t etc 32 | 33 | // needed printf prototype etc for print_int builtin 34 | // probably best to have all io stuff elsewhere 35 | // #include 36 | 37 | typedef int *********************_void_ptr; 38 | typedef void (*_func_ptr)(void*); 39 | 40 | #include "builtin.h" // XXX rename? 41 | 42 | // XXX use macros rather than inline function for some of these, like plus 43 | // and minus 44 | 45 | static intptr_t plus(intptr_t, intptr_t); 46 | static intptr_t minus(intptr_t, intptr_t); 47 | static intptr_t times(intptr_t, intptr_t); 48 | static intptr_t divide(intptr_t, intptr_t); 49 | static intptr_t mod(intptr_t, intptr_t); 50 | static PAWNS_bool leq(intptr_t, intptr_t); 51 | static PAWNS_bool eq(intptr_t, intptr_t); 52 | // static void print_int(intptr_t); 53 | 54 | static __inline PAWNS_bool 55 | leq(intptr_t i, intptr_t j) { 56 | if(i <= j) 57 | return PAWNS_true(); 58 | else 59 | return PAWNS_false(); 60 | } 61 | 62 | static __inline PAWNS_bool 63 | eq(intptr_t i, intptr_t j) { 64 | if(i == j) 65 | return PAWNS_true(); 66 | else 67 | return PAWNS_false(); 68 | } 69 | 70 | static __inline intptr_t 71 | plus(intptr_t i, intptr_t j) { 72 | return i+j; 73 | } 74 | 75 | static __inline intptr_t 76 | minus(intptr_t i, intptr_t j) { 77 | return i-j; 78 | } 79 | 80 | static __inline intptr_t 81 | times(intptr_t i, intptr_t j) { 82 | return i*j; 83 | } 84 | 85 | static __inline intptr_t 86 | divide(intptr_t i, intptr_t j) { 87 | return i/j; 88 | } 89 | 90 | // XXX % is not really mod 91 | static __inline intptr_t 92 | mod(intptr_t i, intptr_t j) { 93 | return i%j; 94 | } 95 | 96 | // static __inline void 97 | // print_int(intptr_t i) { 98 | // // printf("%ld ", (long)i); 99 | // printf("%ld\n", (long)i); 100 | // } 101 | 102 | static __inline void * 103 | apply(_closure cl, void *a1) { 104 | _func_ptr r; 105 | void *ca1, *ca2, *ca3, *ca4; 106 | intptr_t aty; 107 | 108 | switch__closure(cl) 109 | case__cl0(f, aty) 110 | if (aty==1) 111 | return (*(void*(*)(void*))f)(a1); 112 | else 113 | return (void *) _cl1(f, aty, a1); 114 | case__cl1(f, aty, ca1) 115 | if (aty==2) 116 | return (*(void*(*)(void*,void*))f)(ca1, a1); 117 | else 118 | return (void *) _cl2(f, aty, ca1, a1); 119 | case__cl2(f, aty, ca1, ca2) 120 | if (aty==3) 121 | return (*(void*(*)(void*,void*,void*))f)(ca1, ca2, a1); 122 | else 123 | return (void *) _cl3(f, aty, ca1, ca2, a1); 124 | case__cl3(f, aty, ca1, ca2, ca3) 125 | if (aty==4) 126 | return (*(void*(*)(void*,void*,void*,void*))f)(ca1, ca2, ca3, a1); 127 | else 128 | return (void *) _cl4(f, aty, ca1, ca2, ca3, a1); 129 | case__cl4(f, aty, ca1, ca2, ca3, ca4) 130 | return (*(void*(*)(void*,void*,void*,void*,void*))f)(ca1, ca2, ca3, ca4, a1); 131 | end_switch() 132 | } 133 | 134 | #endif // PAWNS_H 135 | -------------------------------------------------------------------------------- /examples/.bcdrc: -------------------------------------------------------------------------------- 1 | alias ppb='~/c/src/proglang/adt4c/src/adtpp bst.adt' 2 | alias pppb='~/c/src/proglang/adt4c/src/adtpp pbst.adt' 3 | alias pph='~/c/src/proglang/adt4c/src/adtpp ho.adt' 4 | alias ppc='~/c/src/proglang/adt4c/src/adtpp cord.adt' 5 | alias cleann='rm\ 6 | out \ 7 | bst.adt bst.c bst.h \ 8 | pbst.adt pbst.c pbst.h \ 9 | ho.adt ho.c ho.h \ 10 | cord.adt cord.c cord.h \ 11 | pres.adt pres.c pres.h \ 12 | mod1.adt mod1.c mod1.h \ 13 | mod2.adt mod2.c mod2.h \ 14 | rectype.adt rectype.c rectype.h \ 15 | state.adt state.c state.h \ 16 | ' 17 | alias gcb='gcc -O3 bst_main.c apply.c ; ./a.out' 18 | alias tuf='make testuf ; ./testuf' 19 | -------------------------------------------------------------------------------- /examples/Readme: -------------------------------------------------------------------------------- 1 | Various bits of Pawns code used for testing the compiler etc. Most are 2 | not stand-alone programs. makefile targets might give some clues... 3 | -------------------------------------------------------------------------------- /examples/addlist.pns: -------------------------------------------------------------------------------- 1 | % For testing higher order + import/export with bst.pns 2 | 3 | type ints = list(int). 4 | 5 | export_imp map, map2, inc, incs, add_lists. 6 | 7 | % extra testing stuff for HO 8 | map :: (int -> int) -> ints -> ints. 9 | map(f, mbs) = { 10 | cases mbs of { 11 | case nil: 12 | nil 13 | case cons(mb, mbs1): 14 | cons(f(mb), map(f, mbs1)) 15 | } 16 | }. 17 | 18 | % XXXXX map2 :: (int -> int -> int) -> ints -> ints. % -> failure 19 | map2 :: (int -> int -> int) -> ints -> ints -> ints. 20 | map2(f, mbs, mcs) = { 21 | cases mbs of { 22 | case nil: 23 | nil 24 | case cons(mb, mbs1): 25 | cases mcs of { 26 | case nil: 27 | nil 28 | case cons(mc, mcs1): 29 | cons(f(mb,mc), map2(f, mbs1, mcs1)) 30 | } 31 | } 32 | }. 33 | 34 | inc :: int -> int. 35 | inc(n) = n+10. 36 | 37 | incs :: ints -> ints. 38 | incs(is) = map(+(20), is). 39 | 40 | add_lists :: ints -> ints -> ints. 41 | add_lists(xs, ys) = map2(+, xs, ys). 42 | -------------------------------------------------------------------------------- /examples/apply.c: -------------------------------------------------------------------------------- 1 | typedef void *_void_ptr; 2 | typedef void (*_func_ptr)(void*); 3 | #include "apply.h" 4 | 5 | // need to generalise this to any number of closure args (ie, a list) 6 | // + we need to support application to multiple args. 7 | // can specialise representation (eg) as follows (we have a certain 8 | // number of closure args and need a certain number of extra args): 9 | // _cl0_1(f), _cl0_2(f), _cl1_1(f,cla1), _cl2_2(f,cla1,cla2), 10 | // cl0(f,n), _cl1(f,n,cla1), _cl2(f,n,cla1,cla2), 11 | // cl(f,n,cla1,cla2,cas) -- (may want length of list cas also?) 12 | // Also, have apply, apply2, apply3? and for more args use nested calls 13 | // to these (less efficient but we have to stop somewhere; have a flag 14 | // somewhere so we can increase this). 15 | // Want general case + specialised ones. Hard to do general case with C 16 | // - we need a call with N arguments, for unbounded N. Could specify a 17 | // maximum arity for HO calls; user can generally group arguments as a 18 | // tuple if needed. 19 | 20 | void * 21 | apply(_closure cl, void *a1) { 22 | _func_ptr r; 23 | void *ca1, *ca2, *ca3, *ca4; 24 | intptr_t aty; 25 | 26 | switch__closure(cl) 27 | case__cl0(f, aty) 28 | if (aty==1) { 29 | return (*(void*(*)(void*))f)(a1); 30 | } else 31 | return (void *) _cl1(f, aty, a1); 32 | case__cl1(f, aty, ca1) 33 | if (aty==2) 34 | return (*(void*(*)(void*,void*))f)(ca1, a1); 35 | else 36 | return (void *) _cl2(f, aty, ca1, a1); 37 | case__cl2(f, aty, ca1, ca2) 38 | if (aty==3) 39 | return (*(void*(*)(void*,void*,void*))f)(ca1, ca2, a1); 40 | else 41 | return (void *) _cl3(f, aty, ca1, ca2, a1); 42 | case__cl3(f, aty, ca1, ca2, ca3) 43 | if (aty==4) 44 | return (*(void*(*)(void*,void*,void*,void*))f)(ca1, ca2, ca3, a1); 45 | else 46 | return (void *) _cl4(f, aty, ca1, ca2, ca3, a1); 47 | case__cl4(f, aty, ca1, ca2, ca3, ca4) 48 | return (*(void*(*)(void*,void*,void*,void*,void*))f)(ca1, ca2, ca3, ca4, a1); 49 | end_switch() 50 | } 51 | 52 | -------------------------------------------------------------------------------- /examples/array.pns: -------------------------------------------------------------------------------- 1 | % prototype array support for pawns 2 | % Indices start at 0. Default is arrays have bound checks; turn off 3 | % with -D UNSAFE_ARRAY (we export the implementation, so the code is 4 | % included in other files and thus potentially we can turn off bounds 5 | % checks selectively for some modules that use arrays). 6 | % 7 | % XXX Need to rethink sharing and exporting of type names? Here we don't 8 | % want to export the type imp really but we want to specify sharing between 9 | % array elements and other args. Also, we want to be able to talk about 10 | % sharing of array elements and other data in our code, so we need to 11 | % export a (fake) data constructor at least. Maybe with sharing its 12 | % hard to really support an abstract interface - look at some other 13 | % examples. Could possibly support faking data constructors which 14 | % correspond to paths in the type. 15 | 16 | % if we export_imp array_new there is a bit more bloat but its one less 17 | % .o file to link 18 | % export_name array_new. 19 | export_imp 20 | array_needed, % dummy fn so we can #include 21 | array, % type for arrays 22 | array_new, % create new array 23 | array_nthp, % get ptr to nth element of array 24 | array_nth, % get nth element of array 25 | array_size. % get size of array 26 | 27 | % dummy type so we can export its name 28 | type array(T) ---> array_(T). 29 | 30 | % dummy fn so we can include stuff 31 | array_needed :: void -> void. 32 | array_needed(v) = as_C " {return;} \n\c 33 | // #include \n\c 34 | #include \n\c 35 | // #include \n\c 36 | ". 37 | 38 | % (generic) arrays are pointers to a block of words (void*), the first 39 | % is the number of elements, the rest are the elements of the array 40 | 41 | % malloc space for size (stored with array) + elements and initialise 42 | % XXX should have some other variants to initialise, eg fold-like things 43 | % such as array_new_fold :: int -> (T1 -> (T, T1)) -> T1 -> array(T) 44 | array_new :: int -> T -> array(T) 45 | sharing array_new(s, i) = a 46 | pre nosharing 47 | post a = array_(i). 48 | array_new(size, initval) = as_C "\c 49 | { \n\c 50 | int i; \n\c 51 | void *vp, **vpp; // note ptr to ptr so vpp++ does the right thing \n\c 52 | if (size < 0) \n\c 53 | size = 0; \n\c 54 | vp = ADT_MALLOC((size+1)*sizeof(void*)); \n\c 55 | if (!vp) { \n\c 56 | fprintf(stderr, \"Malloc of array failed\\n\"); \n\c 57 | exit(1); \n\c 58 | } \n\c 59 | vpp = (void **) vp; // vpp points to first void* in block \n\c 60 | *vpp++ = (void*) size; \n\c 61 | for (i=0; i < size; i++) \n\c 62 | *vpp++ = (void*) initval; \n\c 63 | return (array) vp; \n\c 64 | } \n\c 65 | ". 66 | 67 | % returns ptr to nth array element 68 | % (starting at 0 XXX should we start at 1??) 69 | array_nthp :: array(T) -> int -> ref(T) 70 | sharing array_nthp(a, i) = r 71 | pre nosharing 72 | post a = array_(*r). 73 | array_nthp(arr, n) = as_C "\c 74 | { \n\c 75 | // default is arrays have bound checks; turn off with -D UNSAFE_ARRAY 76 | #ifndef UNSAFE_ARRAY // array bounds check \n\c 77 | if (n >= *(intptr_t*)arr || n < 0) { \n\c 78 | fprintf(stderr, \"Array bounds error\\n\"); \n\c 79 | exit(1); \n\c 80 | } \n\c 81 | #endif // UNSAFE_ARRAY \n\c 82 | return (intptr_t)((void**)arr+n+1); // ptr arith, cast important \n\c 83 | } \n\c 84 | ". 85 | 86 | % returns nth array element, for convenience 87 | array_nth :: array(T) -> int -> T 88 | sharing array_nth(a, i) = r 89 | pre nosharing 90 | post a = array_(r). 91 | array_nth(arr, n) = *array_nthp(arr, n). 92 | 93 | % returns size of array 94 | array_size :: array(T) -> int 95 | sharing array_size(a) = r 96 | pre nosharing 97 | post nosharing. 98 | array_size(arr) = as_C"\c 99 | { \n\c 100 | return (int) *((intptr_t*) arr); \n\c 101 | } \n\c 102 | ". 103 | 104 | % void array_free(void *arr); 105 | % provide this for C programmers? 106 | -------------------------------------------------------------------------------- /examples/arrayc.c: -------------------------------------------------------------------------------- 1 | // prototype array support for pawns 2 | // Old - use array.pns now (though no inline pragma) 3 | #include "array_adt.h" 4 | #include 5 | #include 6 | #include 7 | 8 | 9 | // (generic) arrays are pointers to a block of words (void*), the first 10 | // is the number of elements, the rest are the elements of the array 11 | 12 | // malloc space for size (stored with array) + elements and initialise 13 | array 14 | array_new(int size, void *initval) { 15 | int i; 16 | void *vp, **vpp; // note ptr to ptr so vpp++ does the right thing 17 | if (size < 0) 18 | size = 0; 19 | vp = malloc((size+1)*sizeof(void*)); 20 | if (!vp) { 21 | fprintf(stderr, "Malloc of array failed\n"); 22 | exit(1); 23 | } 24 | vpp = (void **) vp; // vpp points to first void* in block 25 | *vpp++ = (void*) size; 26 | for (i=0; i < size; i++) 27 | *vpp++ = initval; 28 | return (array) vp; 29 | } 30 | 31 | // returns ptr to nth array element 32 | // XXX inline this 33 | void **array_nthp(array arr, int n) { 34 | // arr != NULL, we hope XXX 35 | return ((void**)arr + n + 1); // ptr arith, cast is important 36 | } 37 | 38 | // returns size of array 39 | // XXX inline this 40 | int 41 | array_size(array arr) { 42 | // arr != NULL, we hope XXX 43 | return (int) *((intptr_t*) arr); 44 | } 45 | 46 | 47 | // void array_free(void *arr); 48 | -------------------------------------------------------------------------------- /examples/bst.pns: -------------------------------------------------------------------------------- 1 | % bst stuff: conversion from list of ints to bst of ints destructively, 2 | % printing tree, HO, state var, importing etc 3 | % no polymorphism 4 | % See bst_main.c for top level 5 | 6 | type bst ---> mt ; node(bst, int, bst). 7 | type ints = list(int). 8 | type rbst = ref(bst). 9 | 10 | import from addlist. 11 | import print_int from io. 12 | 13 | ints1 :: void -> ints 14 | sharing ints1(v)= ns 15 | pre nosharing 16 | post ns = abstract. 17 | ints1(v) = 18 | cons(4, cons(2, cons(1, cons(3, nil)))). 19 | 20 | % convert list to bst - note this appears "pure" to callers 21 | list_bst :: ints -> bst. 22 | % sharing list_bst(xs) = xt 23 | % pre xs = abstract 24 | % post xt = abstract. 25 | % XX the following is less precise than needed (if list_bst is called 26 | % with a concrete list we don't want to stop it being updated later) but 27 | % its what is currently generated if no sharing is specified. 28 | % post xt = abstract; xs = abstract. 29 | list_bst(xs) = { 30 | *tp = mt; 31 | list_bst_du(xs, !tp); 32 | % list_bst_du_ho(xs, !tp); 33 | return(*tp) 34 | }. 35 | 36 | % destructively add list of ints to tree we have ptr to 37 | list_bst_du :: ints -> rbst -> void 38 | sharing list_bst_du(xs, !tp) = v 39 | % pre nosharing % gives error with call to list_bst_du above 40 | pre xs = abstract % OK 41 | % pre xs = abstract; tp = abstract % XX get errors with !tp 42 | post nosharing. 43 | list_bst_du(xs, tp) = { 44 | cases xs of { 45 | case cons(x, xs1): 46 | bst_insert_du(x, !tp); 47 | list_bst_du(xs1, !tp) 48 | case nil: 49 | void 50 | } 51 | }. 52 | 53 | % destructively add int to tree we have ptr to 54 | % - traverse down to leaf and clobber it (while loop would be nice) 55 | bst_insert_du :: int -> rbst -> void 56 | sharing bst_insert_du(x, !tp) = v 57 | pre nosharing 58 | post nosharing. 59 | bst_insert_du(x, tp) = { 60 | cases *tp of { 61 | case mt: 62 | *!tp := node(mt, x, mt) 63 | case node(*lp, n, *rp): 64 | % see how much malloc slows things 65 | % tmp = node(mt, x, mt); 66 | if leq(x, n) then 67 | bst_insert_du(x, !lp) !tp 68 | else 69 | bst_insert_du(x, !rp) !tp 70 | } 71 | }. 72 | 73 | % sum of data in bst using state var 74 | % Rather than use the nicer functional style we use destructive 75 | % update of a global counter to demonstrate such things. However, this 76 | % is encapsulated so bst_sum is pure. 77 | bst_sum :: bst -> int. 78 | % sharing bst_sum(t)=s 79 | % pre t = abstract 80 | % post nosharing. 81 | % post s = abstract. % same as nosharing since its atomic 82 | % want to avoid post t = abstract 83 | bst_sum(t) = { 84 | !init_counter(0); 85 | !bst_sum1(t); 86 | *counter 87 | }. 88 | 89 | % counter for nodes 90 | !counter :: ref(int). 91 | 92 | % XXXX breaks things?: 93 | % init_counter :: void 94 | % init_counter :: void -> void 95 | 96 | % initialize counter to n (counter is not passed in - its 97 | % write only) 98 | init_counter :: int -> void 99 | implicit wo counter. 100 | init_counter(n) = { 101 | *counter = n 102 | }. 103 | 104 | % assign n to counter (counter is not passed in - its 105 | % read-write so this is semantically distinct from 106 | % init_counter, though the emitted code is the same) 107 | assign_counter :: int -> void 108 | implicit rw counter. 109 | assign_counter(n) = { 110 | *!counter := n 111 | }. 112 | 113 | % increment counter by n 114 | add_to_counter :: int -> void 115 | implicit rw counter. 116 | add_to_counter(n) = { 117 | *!counter := *counter + n 118 | }. 119 | 120 | bst_sum1 :: bst -> void 121 | implicit rw counter. 122 | bst_sum1(t) = { 123 | cases t of { 124 | case mt: 125 | return 126 | case node(l, n, r): 127 | !bst_sum1(l); 128 | !add_to_counter(n); 129 | % !bst_sum1(r) % obvious way 130 | % since bst_sum is pure we can do this instead: 131 | !add_to_counter(bst_sum(r)) 132 | } 133 | }. 134 | 135 | % XXXXX add code to return nuber of nodes, sum (and sum of squares) 136 | 137 | % print all elements of tree (inorder, no indentation etc to show tree 138 | % structure). 139 | print_tree :: bst -> void 140 | implicit rw io 141 | sharing print_tree(t)=voidvar 142 | pre nosharing 143 | post nosharing. 144 | print_tree(t) = { 145 | cases t of { 146 | case mt: 147 | return 148 | case node(l, n, r): 149 | !print_tree(l); 150 | !print_int(n); 151 | !print_tree(r) 152 | } 153 | }. 154 | 155 | % as above for list 156 | print_ints :: list(int) -> void 157 | implicit rw io 158 | sharing print_ints(t)=voidvar 159 | pre nosharing 160 | post nosharing. 161 | print_ints(t) = { 162 | cases t of { 163 | case nil: 164 | return 165 | case cons(n, r): 166 | !print_int(n); 167 | !print_ints(r) 168 | } 169 | }. 170 | 171 | % HO version of list_bst_du 172 | % (non-du version could use foldl) 173 | 174 | % destructively add list of ints to tree we have ptr to 175 | list_bst_du_ho :: ints -> rbst -> void 176 | sharing list_bst_du_ho(xs, !tp) = v 177 | pre xs = abstract 178 | post nosharing. 179 | % list_bst_du_ho(xs, tp) = int_rbst_foldl_du(xs, bst_insert_du, !tp). 180 | list_bst_du_ho(xs, tp) = foldl_du(xs, bst_insert_du, !tp). 181 | % XXX incompatible postcond above (ho type checking???) 182 | % 'Error: incompatible postcondition for 183 | % '('V0'-foldl_du-[xs,'V1',tp]) 184 | % ' type is '(int -> ref(bst) -> void sharing f(x,tp)=v pre 185 | % nosharing post nosharing' !'([tp])' imp'([],[],[])' 186 | % cl'([int])) 187 | % ' expected '(_G3275 -> _G3301 -> void sharing f(x,tp)=v pre 188 | % nosharing post nosharing' !'([tp])' imp'([],[],[])' 189 | % cl'([_G3275])) 190 | % source: foldl_du(xs,bst_insert_du,!tp) 191 | 192 | 193 | 194 | % name type sig for bst_insert_du 195 | type fn_i_rbst_du = (int -> rbst -> void 196 | sharing f(x, !tp) = v 197 | pre nosharing 198 | post nosharing). 199 | 200 | % traverses like foldl but just returns void and uses du 201 | % (same as list_bst_du but fn passed in) 202 | int_rbst_foldl_du :: ints -> fn_i_rbst_du -> rbst -> void 203 | sharing int_rbst_foldl_du(xs, f, !tp)=voidvar 204 | pre xs = abstract 205 | post nosharing. 206 | int_rbst_foldl_du(xs, f, tp) = { 207 | cases xs of { 208 | case nil: 209 | return 210 | case cons(x, xs1): 211 | f(x, !tp); 212 | int_rbst_foldl_du(xs1, f, !tp) 213 | } 214 | }. 215 | 216 | % Polymorphic and higher order: 217 | 218 | % name type sig for foldl_du arg - second arg of fn is updated 219 | type fn_foldl_du(A, B) = (A -> B -> void 220 | sharing f(x, !tp) = v 221 | pre nosharing 222 | post nosharing). 223 | 224 | % traverses like foldl but just returns void and uses du 225 | foldl_du :: list(A) -> fn_foldl_du(A, B) -> B -> void 226 | sharing foldl_du(xs, f, !tp)=voidvar 227 | pre xs = abstract 228 | post nosharing. 229 | foldl_du(xs, f, tp) = { 230 | cases xs of { 231 | case nil: 232 | return 233 | case cons(x, xs1): 234 | f(x, !tp); 235 | foldl_du(xs1, f, !tp) 236 | } 237 | }. 238 | 239 | 240 | % unrelated: du of single threaded DS without ! annotations:) 241 | single_thread2:: void -> void. 242 | single_thread2(v) = { 243 | *i1 = 1; 244 | i2 = increment(i1); % single threaded (i1 is not used later) 245 | i2a = i2; % not strictly single threaded 246 | i2b = i2a; 247 | i3 = increment(i2); % OK (i2, i2a and i2b are not used later) 248 | i4 = increment(!i3); % not single threaded - need ! 249 | i3a = i3; 250 | i5 = increment(i3) !i3a; % not single threaded - need ! 251 | i6 = increment(i3a) 252 | }. 253 | 254 | increment:: ref(int) -> ref(int) 255 | sharing increment(!p) = r pre nosharing post r=p. 256 | increment(p) = { 257 | *!p := *p + 1; 258 | p 259 | }. 260 | 261 | 262 | % unrelated: du of single threaded DS without ! annotations:) 263 | single_thread:: void -> void. 264 | single_thread(v) = { 265 | *i1 = 1; 266 | i2 = assign(i1, 2); % single threaded (i1 is not used later) 267 | i2a = i2; % not strictly single threaded 268 | i2b = i2a; 269 | i3 = assign(i2, 3); % OK (i2, i2a and i2b are not used later) 270 | i4 = assign(!i3, 4); % not single threaded - need ! 271 | i3a = i3; 272 | i5 = assign(i3, 5) !i3a; % not single threaded - need ! 273 | i6 = assign(i3a, 6) 274 | }. 275 | 276 | assign:: ref(T) -> T -> ref(T) 277 | sharing assign(!p, v) = r pre nosharing post r=p; *r=v. 278 | assign(p, v) = { 279 | *!p := v; 280 | p 281 | }. 282 | 283 | -------------------------------------------------------------------------------- /examples/bst1.pns: -------------------------------------------------------------------------------- 1 | % bst stuff: conversion from list of ints to bst of ints destructively, 2 | % printing tree,... 3 | % Simple version with no polymorphism or higher order (with polymorphism 4 | % you typically get more sharing because the values in the tree are not 5 | % atomic) and with higher order you might potentially get less precise 6 | % sharing analysis. 7 | 8 | type bst ---> mt ; node(bst, int, bst). 9 | type ints = list(int). 10 | type rbst = ref(bst). 11 | 12 | % import from addlist. 13 | 14 | bst1 :: void -> bst 15 | sharing bst1(v)=t 16 | pre nosharing 17 | post nosharing. 18 | bst1(v) = { 19 | t = node(mt, 42, mt); 20 | return(t) 21 | }. 22 | 23 | abst1 :: void -> bst 24 | sharing abst1(v)=t 25 | pre nosharing 26 | post t=abstract. 27 | abst1(v) = { 28 | t = node(mt, 42, mt); 29 | return(t) 30 | }. 31 | 32 | ints1 :: void -> ints 33 | sharing ints1(v)= ns 34 | pre nosharing 35 | post ns = abstract. 36 | ints1(v) = 37 | cons(4, cons(2, cons(1, cons(3, nil)))). 38 | 39 | % convert list to bst - note this appears "pure" to callers 40 | list_bst :: ints -> bst. 41 | % sharing list_bst(xs) = xt 42 | % pre xs = abstract 43 | % post xt = abstract. 44 | % XX the following is less precise than needed (if list_bst is called 45 | % with a concrete list we don't want to stop it being updated later) but 46 | % its what is currently generated if no sharing is specified. 47 | % post xt = abstract; xs = abstract. 48 | list_bst(xs) = { 49 | *tp = mt; 50 | list_bst_du(xs, !tp); 51 | return(*tp) 52 | }. 53 | 54 | % destructively add list of ints to tree we have ptr to 55 | list_bst_du :: ints -> rbst -> void 56 | sharing list_bst_du(xs, !tp) = v 57 | pre xs = abstract 58 | % pre (xs = abstract; tp = abstract) % XX get errors with !tp 59 | post nosharing. 60 | list_bst_du(xs, tp) = { 61 | cases xs of { 62 | case cons(x, xs1): 63 | bst_insert_du(x, !tp); 64 | list_bst_du(xs1, !tp); 65 | return 66 | case nil: 67 | return 68 | } 69 | }. 70 | 71 | % destructively add int to tree we have ptr to 72 | % - traverse down to leaf and clobber it (while loop would be nice) 73 | bst_insert_du :: int -> rbst -> void 74 | sharing bst_insert_du(x, !tp) = v 75 | pre nosharing 76 | post nosharing. 77 | bst_insert_du(x, tp) = { 78 | cases *tp of { 79 | case mt: 80 | *!tp := node(mt, x, mt) 81 | case node(*lp, n, *rp): 82 | if leq(x, n) then 83 | bst_insert_du(x, !lp) !tp 84 | else 85 | bst_insert_du(x, !rp) !tp 86 | } 87 | }. 88 | 89 | 90 | test1 :: void -> void 91 | sharing test1(v)=v1 92 | pre nosharing 93 | post nosharing. 94 | test1(v) = { 95 | *tp = mt; 96 | bst_insert_du(42, !tp); 97 | % example of passing a concrete DS to a pure fn preventing 98 | % further update of the DS because it might share with abstract DS 99 | t1 = bst_id(*tp); 100 | bst_insert_du(43, !tp); % Error: missing !t1 101 | bst_insert_du(44, !tp) !t1; % Error: t1 abstract 102 | t2 = t1; % dummy use of t1 103 | bst_insert_du(44, !tp); % OK: t1 now dead 104 | tp1 = tp; 105 | t3 = list_bst(ints1(void)); 106 | return(v) 107 | }. 108 | 109 | test2 :: void -> void 110 | sharing test2(v)=v1 111 | pre nosharing 112 | post nosharing. 113 | test2(v) = { 114 | *tp = mt; 115 | bst_insert_du(42, !tp); 116 | % example of passing a concrete DS to a pure fn not preventing 117 | % further update of the DS because pure fn doesn't create sharing 118 | s1 = bst_size(*tp); 119 | % should avoid sharing tp with abstract! 120 | bst_insert_du(43, !tp); 121 | s2 = bst_size(*tp); 122 | % 123 | *tp1 = bst1(void); % concrete tree 124 | bst_insert_du(42, !tp1); % -> can DU 125 | *atp1 = abst1(void); % abstract tree 126 | bst_insert_du(43, !atp1); % can't DU abs var if live; precond viol 127 | dummy0 = tp1; 128 | dummy1 = atp1; 129 | % 130 | ns = cons(2, nil); 131 | cases ns of { 132 | case cons(*np, *nsp): 133 | t2 = list_bst(ns); % precond of list_bst shares ns with abstract 134 | *!nsp := cons(3, nil) !ns % but not postcond, so this is OK 135 | }; 136 | ns1 = ns; % use ns 137 | return(v) 138 | }. 139 | 140 | bst_id :: bst -> bst 141 | sharing bst_id(t)=t1 142 | pre t = abstract 143 | % post (t1 = abstract; t = t1). % want to avoid t = abstract 144 | post (t1 = abstract; t = abstract). % imprecise (curr. default) 145 | % post t1 = abstract. % not sufficient 146 | % for abstract, if the result can share with an input (components have 147 | % the same type) the this should be put explicitly in post, but if 148 | % possible, avoid explicit sharing between args and abstract in post 149 | % - should put this in code for generating implicit pre/post 150 | bst_id(t) = { 151 | return(t) 152 | }. 153 | 154 | bst_size :: bst -> int. 155 | % sharing bst_size(xt)=s 156 | % pre xt = abstract 157 | % post nosharing. 158 | % post s = abstract. % same as nosharing since its atomic 159 | % want to avoid post xt = abstract 160 | bst_size(xs) = { 161 | % XXX STUB 162 | return(42) 163 | }. 164 | 165 | -------------------------------------------------------------------------------- /examples/bst_a.pns: -------------------------------------------------------------------------------- 1 | % OLD 2 | % bst stuff: conversion from list of ints to bst of ints destructively, 3 | % printing tree,... 4 | % Hacked bst.pns to play around with abstract/concrete stuff implemented 5 | % using sharing with abs_t vars 6 | 7 | type bst ---> mt ; node(bst, int, bst). 8 | type ints = list(int). 9 | 10 | bst1 :: void -> bst 11 | sharing bst1(v)=t 12 | pre nosharing 13 | post nosharing. 14 | bst1(v) = { 15 | t = node(mt, 42, mt); 16 | return(t) 17 | }. 18 | 19 | ints1 :: bst -> list(int) -> void -> ints 20 | sharing ints1(a_bst,a_ints,v) = ns 21 | pre nosharing 22 | post ns=a_ints. 23 | ints1(a_bst, a_ints, v) = { 24 | is = cons(4, cons(2, cons(1, cons(3, nil)))); 25 | return(is) 26 | }. 27 | 28 | % convert list to bst - note this appears "pure" to callers 29 | list_bst :: bst -> list(int) -> list(int) -> bst 30 | sharing list_bst(a_bst,a_ints,xs)=xt 31 | pre xs=a_ints 32 | post t=a_bst. 33 | list_bst(a_bst, a_ints, xs) = { 34 | *tp = mt; 35 | list_bst_du(a_bst, a_ints, xs, !tp); 36 | return(*tp) 37 | }. 38 | 39 | % destructively add list of ints to tree we have ptr to 40 | list_bst_du :: bst -> list(int) -> list(int) -> ref(bst) -> void 41 | sharing list_bst_du(a_bst,a_ints,xs,tp)=voidvar 42 | pre xs=a_ints 43 | post nosharing. 44 | list_bst_du(a_bst, a_ints, xs, tp) = { 45 | cases xs of { 46 | case cons(x, xs1): 47 | bst_insert_du(x, !tp); 48 | list_bst_du(a_bst, a_ints, xs1, !tp); 49 | return 50 | case nil: 51 | return 52 | } 53 | }. 54 | 55 | % destructively add int to tree we have ptr to 56 | % - traverse down to leaf and clobber it (while loop would be nice) 57 | bst_insert_du :: int -> ref(bst) -> void 58 | % sharing bst_insert_du(x,!tp)=voidvar 59 | sharing bst_insert_du(x,tp)=voidvar % XXXX no ! before tp 60 | pre nosharing 61 | post nosharing. 62 | bst_insert_du(x, tp) = { 63 | tmp1 = *tp; 64 | cases tmp1 of { 65 | case mt: 66 | *!tp := node(mt, x, mt); 67 | return 68 | % shouldn't need ptr for n but currently needed for compilation 69 | case node(*lp, *np, *rp): 70 | tmp3 = *np; 71 | tmp2 = leq(x, tmp3); 72 | cases tmp2 of { 73 | case true: 74 | bst_insert_du(x, !lp) !tp!rp!np; % np,rp dead 75 | return 76 | case false: 77 | bst_insert_du(x, !rp) !tp!lp!np; % np,lp dead 78 | return 79 | } 80 | } 81 | }. 82 | 83 | bst_id :: bst -> bst -> bst 84 | sharing bst_id(a_bst,t)=t1 85 | pre a_bst=t 86 | post (t1=a_bst;t1=t). 87 | bst_id(a_bst, t) = { 88 | return(t) 89 | }. 90 | 91 | test1 :: bst -> void -> void 92 | sharing test1(a_bst,v)=v1 93 | pre nosharing 94 | post nosharing. 95 | test1(a_bst, v) = { 96 | *tp = mt; 97 | bst_insert_du(42, !tp); 98 | t1 = bst_id(a_bst, *tp); 99 | bst_insert_du(43, !tp); % Error: missing !t1 100 | bst_insert_du(44, !tp) !t1; % Error: t1 shares with a_bst 101 | use = t1; 102 | return(v) 103 | }. 104 | 105 | bst_size :: bst -> bst -> int 106 | sharing bst_size(a_bst,xt)=s 107 | pre a_bst=xt 108 | post nosharing. 109 | % Note: need to distinguish between precond and extra sharing in postcond 110 | % introduced by execution. For pure fns we only want to add latter. 111 | % If we have a_bst = xt as a postcondition also then calling size makes 112 | % the tree abstract, restricting programming (eg DU of tree) 113 | bst_size(a_bst, xs) = { 114 | % STUB 115 | return(42) 116 | }. 117 | 118 | test2 :: bst -> void -> void 119 | sharing test2(a_bst,v)=v1 120 | pre nosharing 121 | post nosharing. 122 | test2(a_bst, v) = { 123 | *tp = mt; 124 | bst_insert_du(42, !tp); 125 | s1 = bst_size(a_bst, *tp); 126 | bst_insert_du(43, !tp); 127 | s2 = bst_size(a_bst, *tp); 128 | return(v) 129 | }. 130 | 131 | % <= for ints: defined elsewhere in C 132 | leq :: int -> int -> bool 133 | sharing leq(p0,p1)=r 134 | pre nosharing 135 | post nosharing. 136 | leq(p0, p1) = { return(true) 137 | }. 138 | -------------------------------------------------------------------------------- /examples/bst_main.c: -------------------------------------------------------------------------------- 1 | // harness for bst.pns -> bst_out.c 2 | // or pbst.c if we use -DPure 3 | // -DMax=n inserts n ints into the tree, unbalanced ->O(n^2) 4 | // prints time taken 5 | // Initial version du takes around 65% of time with -DPure 6 | // Later version has huge difference: 2100ms vs 90ms (>20 speedup) 7 | // Compiler is doing a very good job for du version: tight code with 8 | // tail recursion optimised. For pure version its hard to make it tail 9 | // recursive due to malloc/node() so the code is recursive, using stack 10 | // space as well as a malloc for each level traversed. 11 | // gcc -O3 -DMax=10000 -DPure bst_main.c ; ./a.out 12 | // gcc -O3 -DMax=10000 bst_main.c ; ./a.out 13 | // if-then-else implemented as switch, no tail recursion opt in src, 14 | // extra code in macros to get type checking, etc, malloc from stdlib 15 | 16 | #ifndef Max 17 | #define Max 0 18 | #endif 19 | 20 | #include 21 | #include 22 | #include 23 | #include "pawns.h" 24 | #include "bst.h" 25 | #include "addlist.h" 26 | 27 | // should be in some .h file?? 28 | bst list_bst(list xs); 29 | list incs(list is); 30 | list add_lists(list xs, list ys); 31 | 32 | 33 | void 34 | main() { 35 | list l, l2, l3; 36 | bst t; 37 | clock_t t1, t2; 38 | intptr_t sum; 39 | 40 | #if Max>0 41 | long i; 42 | l = nil(); 43 | for (i = Max; i > 0; i--) 44 | l = cons((void*)i, l); 45 | #else // Max 46 | l = cons(5L, cons(6L, cons(3L, cons(1L, cons(2L, cons(4L, cons(7L, nil()))))))); 47 | printf("l = %lx\n", (long) l); 48 | print_ints(l); 49 | #endif // Max 50 | t1 = clock(); 51 | t = list_bst(l); 52 | // exit(1); // temp hack for bst_count 53 | t2 = clock(); 54 | printf("list_bst took %dms\n", (int)((t2-t1)*1000/CLOCKS_PER_SEC)); 55 | #if Max==0 56 | l2 = incs(l); // test higher order 57 | print_ints(l2); 58 | l3 = add_lists(l,l2); // test higher order 59 | #endif // Max 60 | #if Max<150 61 | print_tree(t); 62 | #endif // Max 63 | sum = bst_sum(t); 64 | printf("sum = %ld\n", (long)sum); 65 | exit(0); 66 | } 67 | -------------------------------------------------------------------------------- /examples/bst_poly.pns: -------------------------------------------------------------------------------- 1 | % bst stuff: conversion from list of ints to bst of ints destructively, 2 | % printing tree,... 3 | % Version with polymorphism and higher order. More potential sharing so 4 | % we need renaming of functions to get versions with more specific types 5 | % and different sharing information. A couple of buggy versions thrown 6 | % in (detected by the compiler) to illustrate potential problems with 7 | % type preservation when polymorphism is mixed with destructive update. 8 | 9 | import from addlist. 10 | import print_int from io. 11 | 12 | type bst(T) ---> mt ; node(bst(T), T, bst(T)). 13 | type ibst = bst(int). 14 | type ints = list(int). 15 | type rbst(T) = ref(bst(T)). 16 | type ribst = rbst(int). 17 | 18 | bst1 :: void -> ibst 19 | sharing bst1(v)=t 20 | pre nosharing 21 | post nosharing. 22 | bst1(v) = { 23 | t = node(mt, 42, mt); 24 | return(t) 25 | }. 26 | 27 | ints1 :: void -> ints 28 | sharing ints1(v)= (is) 29 | pre nosharing 30 | post nosharing. 31 | ints1(v) = { 32 | is = cons(4, cons(2, cons(1, cons(3, nil)))); 33 | return(is) 34 | }. 35 | 36 | % Convert int list to ibst - note this appears "pure" to callers. 37 | % Defined in terms of (renamed) HO polymorphic functions 38 | list_bst :: ints -> ibst 39 | sharing list_bst(xs) = xt 40 | pre xs = abstract 41 | post nosharing. 42 | list_bst(xs) = { 43 | % we need *tp to be type ibst, not bst(T) since its updated 44 | % *tp = (mt :: ibst); 45 | *tp = mt; 46 | ilist_bst_du(xs, (<=), !tp); 47 | return(*tp) 48 | }. 49 | 50 | % we rename the polymorphic code and use an instance of the types and 51 | % different sharing (the list abstract but not sharing with the tree) 52 | renaming 53 | ilist_bst_du = list_bst_du, 54 | ibst_insert_du = bst_insert_du. 55 | 56 | ilist_bst_du :: ints -> (int -> int -> bool) -> ribst -> void 57 | % sharing ilist_bst_du(xs, !tp) = v % XXX causes grief way down the track 58 | sharing ilist_bst_du(xs, leq, !tp) = v 59 | pre xs = abstract 60 | post nosharing. 61 | ibst_insert_du :: int -> (int -> int -> bool) -> ribst -> void 62 | sharing ibst_insert_du(x, leq, !tp) = v 63 | pre nosharing 64 | post nosharing. 65 | 66 | % specification of precise DU info for list_bst_pdu and bst_insert_pdu 67 | % The arg of the top level ref is DU, as are the left and right subtrees of a 68 | % node. The tree elements are not touched, so they can potentially be 69 | % abstract. 70 | du_spec [ 71 | subt = ref(!...node(!,?,!)) % ref+subtrees can be DU but not elements 72 | ]. 73 | 74 | % Destructively add list of elements to tree we have ptr to. 75 | % In general there will be sharing between list and tree elements and 76 | % because the tree is destructively updated, the list (and its elements). 77 | % This version allows abstract sharing due to more precise duspec. 78 | % (compare with older list_bst_du, written before precise duspec) 79 | list_bst_pdu :: list(T) -> (T -> T -> bool) -> ref(bst(T)) -> void 80 | sharing list_bst_pdu(xs, letest, !tp^subt) = v 81 | pre cases xs of {case cons(x, xs1): *tp = node(mt, x, mt)} 82 | % post cases xs of {case cons(x, xs1): *tp = node(mt, x, mt)}. 83 | post nosharing. 84 | % would be nice to be able to avoid cases and use eg 85 | % xs = cons(x, nil); *tp = node(mt, x, mt) 86 | list_bst_pdu(xs, letest, tp) = { 87 | cases xs of { 88 | case cons(x, xs1): 89 | % need !xs below for polymorphic version, or any instance 90 | % where elements are not atomic 91 | bst_insert_pdu(x, letest, tp) !tp^subt; 92 | list_bst_pdu(xs1, letest, tp) !tp^subt; 93 | return 94 | case nil: 95 | return 96 | } 97 | }. 98 | 99 | % destructively add element to tree we have ptr to 100 | % - traverse down to leaf and clobber it (while loop would be nice?) 101 | bst_insert_pdu :: T -> (T -> T -> bool) -> ref(bst(T)) -> void 102 | sharing bst_insert_pdu(x, letest, !tp^subt) = v 103 | pre *tp = node(mt, x, mt) 104 | post nosharing. 105 | % post *tp = node(mt, x, mt). 106 | bst_insert_pdu(x, letest, tp) = { 107 | cases *tp of { 108 | case mt: 109 | *tp := node(mt, x, mt) !tp^subt 110 | case node(*lp, n, *rp): 111 | if letest(x, n) then 112 | bst_insert_pdu(x, letest, lp) !lp^subt!tp^subt 113 | else 114 | bst_insert_pdu(x, letest, rp) !rp^subt!tp^subt 115 | } 116 | }. 117 | 118 | % Destructively add list of elements to tree we have ptr to. 119 | % In general there will be sharing between list and tree elements and 120 | % because the tree is destructively updated, the list (and its elements) 121 | % but not be abstract (the fact that *only the outer structure* of the 122 | % tree is updated is not captured by the declarations). However, if 123 | % the element type is atomic there is no sharing so 124 | % by renaming this function (and bst_insert_du) and giving 125 | % a more specific type, different sharing can be specified, including 126 | % the list being abstract. 127 | list_bst_du :: list(T) -> (T -> T -> bool) -> ref(bst(T)) -> void 128 | sharing list_bst_du(xs, letest, !tp) = v 129 | pre cases xs of {case cons(x, xs1): *tp = node(mt, x, mt)} 130 | % post cases xs of {case cons(x, xs1): *tp = node(mt, x, mt)}. 131 | post nosharing. 132 | % would be nice to be able to avoid cases and use eg 133 | % xs = cons(x, nil); *tp = node(mt, x, mt) 134 | list_bst_du(xs, letest, tp) = { 135 | cases xs of { 136 | case cons(x, xs1): 137 | % need !xs below for polymorphic version, or any instance 138 | % where elements are not atomic 139 | bst_insert_du(x, letest, !tp) !xs1; % xs not updated 140 | list_bst_du(xs1, letest, !tp) !xs1; % xs not updated 141 | return 142 | case nil: 143 | return 144 | } 145 | }. 146 | 147 | % destructively add element to tree we have ptr to 148 | % - traverse down to leaf and clobber it (while loop would be nice?) 149 | bst_insert_du :: T -> (T -> T -> bool) -> ref(bst(T)) -> void 150 | sharing bst_insert_du(x, letest, !tp) = v 151 | pre *tp = node(mt, x, mt) 152 | post nosharing. 153 | % post *tp = node(mt, x, mt). 154 | bst_insert_du(x, letest, tp) = { 155 | cases *tp of { 156 | case mt: 157 | *!tp := node(mt, x, mt) 158 | case node(*lp, n, *rp): 159 | if letest(x, n) then 160 | bst_insert_du(x, letest, !lp) !tp 161 | else 162 | bst_insert_du(x, letest, !rp) !tp 163 | } 164 | }. 165 | 166 | % Dodgey version which could (have) violated type preservation 167 | % Now ok as type is cast automatically(?) 168 | bug1_list_bst :: ints -> ibst 169 | sharing list_bst(xs) = xt 170 | pre xs = abstract 171 | post nosharing. 172 | bug1_list_bst(xs) = { 173 | *tp = mt; % tp :: ref(bst(T)) 174 | ilist_bst_du(xs, (<=), !tp); % mutates tp to ref(ibst) 175 | % tp type is instantiated to ref(ibst) so any subsequent 176 | % use of tp here in context where ref(bst(T)) expected, gives a type error 177 | return(*tp) 178 | }. 179 | 180 | % Dodgey version which could violate type preservation. 181 | % Error detected during sharing analysis 182 | bug2_list_bst :: ints -> ibst 183 | sharing list_bst(xs) = xt 184 | pre xs = abstract 185 | post nosharing. 186 | bug2_list_bst(xs) = { 187 | *tp1 = mt; % tp1 :: ref(bst(T)) 188 | tp2 = (tp1 :: ref(ibst)); % cast tp1 to get tp2 189 | % tp2 = tp1; 190 | % "Error: sharing of cast variable later implicitly mutated" 191 | % not really a need for this cast now that types get further instantiated 192 | ilist_bst_du(xs, (<=), !tp2) !tp1; % tp1 implicitly smashed 193 | % potential use of tp1 here in context where ref(bst(T)) expected, 194 | % but tp1 is now a ref(ibst) so type preservation would be violated 195 | *tp2 196 | }. 197 | 198 | % Attempt to use polymorphic HO code without renaming. 199 | % The polymorphic code has list and tree elements sharing and the list 200 | % cannot be abstract since the tree is updated (the elements are not 201 | % actually updated but the declarations are not precise enough to convey 202 | % that). Also demonstrates renaming+with 203 | bug3_list_bst :: ints -> ibst. 204 | renaming 205 | bug3_list_bst = list_bst 206 | with 207 | list_bst_du = ilist_bst_du. 208 | 209 | 210 | % print all elements of tree (inorder, no indentation etc to show tree 211 | % structure). 212 | print_tree :: ibst -> void 213 | implicit rw io 214 | sharing print_tree(t)=voidvar 215 | pre nosharing 216 | post nosharing. 217 | print_tree(t) = { 218 | cases t of { 219 | case mt: 220 | return 221 | case node(l, n, r): 222 | !print_tree(l); 223 | !print_int(n); 224 | !print_tree(r); 225 | return 226 | } 227 | }. 228 | 229 | % as above for list 230 | % implicit !io 231 | print_ints :: list(int) -> void 232 | implicit rw io 233 | sharing print_ints(t)=voidvar 234 | pre nosharing 235 | post nosharing. 236 | print_ints(t) = { 237 | cases t of { 238 | case nil: 239 | return 240 | case cons(n, r): 241 | !print_int(n); 242 | !print_ints(r); 243 | return 244 | } 245 | }. 246 | 247 | 248 | % see bst.pns for version with encapsulated counter 249 | % Could do a higher order version with a foldr for trees 250 | bst_sum :: ibst -> int 251 | sharing bst_sum(t) = i 252 | pre t = abstract 253 | post nosharing. 254 | bst_sum(t) = { 255 | cases t of { 256 | case mt: 257 | 0 258 | case node(l, n, r): 259 | bst_sum(l) + n + bst_sum(r) 260 | } 261 | }. 262 | 263 | -------------------------------------------------------------------------------- /examples/c2pawns.sed: -------------------------------------------------------------------------------- 1 | s.^//.%. 2 | /^[^%]/s/\\/\\\\/g 3 | /^[^%]/s/"/\\"/g 4 | /^[^%]/s/$/ \\n\\c/g 5 | -------------------------------------------------------------------------------- /examples/cord.pns: -------------------------------------------------------------------------------- 1 | % cords of {lists of) bools 2 | % should do "pure" (non-DU) versions also 3 | 4 | type cb ---> leaf(bs) ; branch(cb, cb). 5 | type bs = list(bool). 6 | type rbs = ref(bs). 7 | 8 | % test type equality 9 | % type bsss = l(l(bs)). 10 | % type l(X) = list(X). 11 | % type eqtest ---> foo(bsss). 12 | 13 | % cordlist takes a cord (containing lists of bools) and returns 14 | % the concatenation of all the lists. The lists inside the cord are 15 | % modified (the nil of each one except the last is updated to point to 16 | % the next list in the cord). Note: the lists in the cord must not 17 | % share! 18 | % We create a pointer to what is initially an empty list and repeatedly 19 | % append lists from the cord onto the end of this list, which we keep a 20 | % pointer to. 21 | cordlist :: cb -> bs 22 | sharing cordlist(!x)=a 23 | pre nosharing 24 | post x=leaf(a). 25 | cordlist(x) = { 26 | % the initial binding of a is of type ref(list(T)) but since 27 | % its assigned things of type ref(bs) we have to explicitly declare 28 | % this 29 | % XXX hmm, should have a way to get a type params in such places - 30 | % currently scope of declaration doesn't include defn 31 | % *a = (nil :: bs); 32 | *a = nil; 33 | b = cordlist1(!x, !a); 34 | return(*a) 35 | }. 36 | 37 | % Given a cord and a pointer to the end of a list, (destructively) 38 | % append each list in the cord onto the end of this list and return the 39 | % new end of the list. 40 | % (could instead have pointer to pointer to list and clobber it) 41 | cordlist1 :: cb -> rbs -> rbs 42 | sharing cordlist1(!x,!p)=p1 43 | pre x=leaf(*p) 44 | post (x=leaf(*p); p1=p). 45 | cordlist1(x, p) = { 46 | cases x of { 47 | % case empty: 48 | % return(p) 49 | case leaf(q): 50 | % q is not updated below (assuming leaves don't share) since p 51 | % will generally share with previous leaves but not this one (yet) 52 | *!p := q !x!q; 53 | return(lastp(p)) % now we share (return val) with q 54 | case branch(x1, x2): 55 | % Could use p instead of p2 below but its more confusing. 56 | % Or return(cordlist1(!x2, cordlist1(!x1, !p))) !x 57 | % (with annotation on nested call?) - shorter but less clear 58 | % 59 | p2 = cordlist1(!x1, !p) !x!x2; % !x2 see below 60 | return(cordlist1(!x2, !p2)) !x!p 61 | % 62 | % !x2 is needed above with our sharing analysis. If the cord is 63 | % constructed so there is no sharing between branches then x2 is 64 | % not updated in this call and all is fine. However, this 65 | % restriction cannot be guaranteed here and the precision of our 66 | % current sharing analysis doesn't allow us to express this 67 | % non-sharing. Thus it must be left up to the programmer to 68 | % document this restriction and carefully abide by it: when 69 | % constructing a cord which is passed here we must not have cord 70 | % such as branch(leaf(xs), leaf(as++xs)) which share xs. 71 | % Forcing the programmer to add !x2 above should alert them to 72 | % this fact. 73 | } 74 | }. 75 | 76 | % given a pointer to a list, returns a pointer to the nil at the end of 77 | % the list 78 | % Precise sharing is a bit subtle: arg q shares with result r but we 79 | % know that r points to nil so the elements of the list r points to *do 80 | % not* share with the elements the list q points to. Ideally we should 81 | % express this (negative) information in the postcondition. 82 | lastp :: rbs -> rbs 83 | sharing lastp(q)=r 84 | pre nosharing 85 | post r=q. 86 | % following should be more precise??? 87 | % post *r=nil; q=cons(true,*r). % XXX sharing analysis of (cordlist1) alias_stat failed :-( 88 | % post *r=nil; q=cons(42,*r). % XXX loop compiling after error msg? 89 | lastp(q) = { 90 | q1 = *q; 91 | cases q1 of { 92 | case nil: 93 | return(q) 94 | case cons(*h, *p): 95 | return(lastp(p)) 96 | } 97 | }. 98 | 99 | % Safe interface to cords. Its important that the different lists in a 100 | % cord don't share, otherwise cordlist breaks (it will create a cyclic 101 | % list then loop). Here we use an interface with preconditions to ensure 102 | % that when we add a list to a cord its doesn't share with the lists in 103 | % the cord already. 104 | 105 | % returns empty cord 106 | % has dummy arg 107 | cord_mt :: void -> cb 108 | sharing cord_mt(v)=a 109 | pre nosharing 110 | post nosharing. 111 | cord_mt(x) = { 112 | % return(empty). 113 | return(leaf(nil)) 114 | }. 115 | 116 | % list to cord 117 | list_cord :: list(bool) -> cb 118 | sharing list_cord(l)=c 119 | pre nosharing 120 | post c=leaf(l). 121 | list_cord(l) = { 122 | return(leaf(l)) 123 | }. 124 | 125 | % appends list to cord 126 | cord_app :: cb -> list(bool) -> cb 127 | sharing cord_app(c0,l)=c 128 | pre nosharing 129 | post inferred. 130 | % post c=branch(c0,leaf(l)). 131 | cord_app(c0, l) = { 132 | return(branch(c0, leaf(l))) 133 | }. 134 | 135 | % prepends list to cord 136 | cord_pre :: list(bool) -> cb -> cb 137 | sharing cord_pre(l,c0)=c 138 | pre nosharing 139 | post inferred. 140 | % post c=branch(leaf(l),c0). 141 | cord_pre(l, c0) = { 142 | return(branch(leaf(l), c0)) 143 | }. 144 | 145 | % some test code 146 | testcord :: list(bool) -> bs 147 | sharing testcord(l)=l1 % should be !l 148 | pre nosharing 149 | post nosharing. % should be l1 = l 150 | testcord(l) = { 151 | c0=leaf(l); 152 | c1=cord_app(c0,l); % precond violation - c0 and l share 153 | c2 = leaf(nil); 154 | c3=cord_app(c2,l); 155 | c4=cord_app(c3,l); % precond violation - c3 and l share 156 | % l1 shares with leaves of c4 and therefore with l 157 | % l is an arg so is considered live for whole fn body 158 | % l1 = cordlist(c4); % !l (!c4 not needed since its dead) 159 | l1 = cordlist(c4) !l; % if we add !l we need to declare arg l mutable 160 | return(l1) 161 | }. % postcond violation 162 | 163 | -------------------------------------------------------------------------------- /examples/cord_poly.pns: -------------------------------------------------------------------------------- 1 | % cords - polymorphic version 2 | % should do "pure" (non-DU) versions also 3 | 4 | type cord(T) ---> leaf(list(T)) ; branch(cord(T), cord(T)). 5 | type rlist(T) = ref(list(T)). 6 | 7 | % cordlist takes a cord (containing lists of T) and returns 8 | % the concatenation of all the lists. The lists inside the cord are 9 | % modified (the nil of each one except the last is updated to point to 10 | % the next list in the cord). Note: the lists in the cord must not 11 | % share! 12 | % We create a pointer to what is initially an empty list and repeatedly 13 | % append lists from the cord onto the end of this list, which we keep a 14 | % pointer to. 15 | cordlist :: cord(T) -> list(T) 16 | sharing cordlist(!x)=a 17 | pre nosharing 18 | post x=leaf(a). 19 | cordlist(x) = { 20 | % XXX hmm, should have a way to get a type params in such places - 21 | % currently scope of declaration doesn't include defn, so T here is 22 | % not the same T as in the declaration and we get an error 23 | % *a = (nil :: list(T)); 24 | % *a = (nil :: list('_type_param'(1))); % hack 25 | *a = nil; 26 | b = cordlist1(!x, !a); 27 | return(*a) 28 | }. 29 | 30 | % Given a cord and a pointer to the end of a list, (destructively) 31 | % append each list in the cord onto the end of this list and return the 32 | % new end of the list. 33 | % (could instead have pointer to pointer to list and clobber it) 34 | cordlist1 :: cord(T) -> rlist(T) -> rlist(T) 35 | sharing cordlist1(!x,!p)=p1 36 | pre x=leaf(*p) 37 | post (x=leaf(*p); p1=p). 38 | cordlist1(x, p) = { 39 | cases x of { 40 | % case empty: 41 | % return(p) 42 | case leaf(q): 43 | % q is not updated below (assuming leaves don't share) since p 44 | % will generally share with previous leaves but not this one (yet) 45 | *!p := q !x!q; 46 | return(lastp(p)) % now we share (return val) with q 47 | case branch(x1, x2): 48 | % Could use p instead of p2 below but its more confusing. 49 | % Or return(cordlist1(!x2, cordlist1(!x1, !p))) !x 50 | % (with annotation on nested call?) - shorter but less clear 51 | % 52 | p2 = cordlist1(!x1, !p) !x!x2; % !x2 like !x1 below 53 | return(cordlist1(!x2, !p2)) !x!x1!p % !x1 see below 54 | % 55 | % !x1 is needed above with our sharing analysis. If the cord is 56 | % constructed so there is no sharing between branches then x1 is 57 | % not updated in this call and all is fine. However, this 58 | % restriction cannot be guaranteed here and the precision of our 59 | % current sharing analysis doesn't allow us to express this 60 | % non-sharing. Thus it must be left up to the programmer to 61 | % document this restriction and carefully abide by it: when 62 | % constructing a cord which is passed here we must not have cord 63 | % such as branch(leaf(xs), leaf(as++xs)) which share xs. 64 | % Forcing the programmer to add !x1 above should alert them to 65 | % this fact. 66 | } 67 | }. 68 | 69 | % given a pointer to a list, returns a pointer to the nil at the end of 70 | % the list 71 | % Precise sharing is a bit subtle: arg q shares with result r but we 72 | % know that r points to nil so the elements of the list r points to *do 73 | % not* share with the elements the list q points to. Ideally we should 74 | % express this (negative) information in the postcondition. 75 | lastp :: rlist(T) -> rlist(T) 76 | sharing lastp(q)=r 77 | pre nosharing 78 | post r=q. 79 | lastp(q) = { 80 | q1 = *q; 81 | cases q1 of { 82 | case nil: 83 | return(q) 84 | case cons(*h, *p): 85 | return(lastp(p)) 86 | } 87 | }. 88 | 89 | % Safe interface to cords. Its important that the different lists in a 90 | % cord don't share, otherwise cordlist breaks (it will create a cyclic 91 | % list then loop). Here we use an interface with preconditions to ensure 92 | % that when we add a list to a cord its doesn't share with the lists in 93 | % the cord already. 94 | 95 | % returns empty cord 96 | % has dummy arg 97 | cord_mt :: void -> cord(T) 98 | sharing cord_mt(v)=a 99 | pre nosharing 100 | post nosharing. 101 | cord_mt(x) = { 102 | % return(empty). 103 | return(leaf(nil)) 104 | }. 105 | 106 | % list to cord 107 | list_cord :: list(T) -> cord(T) 108 | sharing list_cord(l)=c 109 | pre nosharing 110 | post c=leaf(l). 111 | list_cord(l) = { 112 | return(leaf(l)) 113 | }. 114 | 115 | % appends list to cord 116 | cord_app :: cord(T) -> list(T) -> cord(T) 117 | sharing cord_app(c0,l)=c 118 | pre nosharing 119 | post inferred. 120 | % post c=branch(c0,leaf(l)). 121 | cord_app(c0, l) = { 122 | return(branch(c0, leaf(l))) 123 | }. 124 | 125 | % prepends list to cord 126 | cord_pre :: list(T) -> cord(T) -> cord(T) 127 | sharing cord_pre(l,c0)=c 128 | pre nosharing 129 | post inferred. 130 | % post c=branch(leaf(l),c0). 131 | cord_pre(l, c0) = { 132 | return(branch(leaf(l), c0)) 133 | }. 134 | 135 | % some test code 136 | testcord :: list(T) -> list(T) 137 | sharing testcord(l)=l1 % should be !l 138 | pre nosharing 139 | post nosharing. % should be l1 = l 140 | testcord(l) = { 141 | cb0 = leaf(cons(true, nil)); % cord(bool) 142 | cb1 = leaf(cons(nil, nil)); % cord(list(_)) 143 | cb2 = leaf(cons(cons(true, nil), nil)); % cord(list(bool)) 144 | cb3 = branch(cb2,cb1); % instantiates type of cb1 - XXX cyclic term! 145 | % in assert(type_struct_c(list(...),sum(...,...))) 146 | % cb4 = branch(cb0,cb1); % type error: cord(bool) vs cord(list(_)) 147 | cb5 = branch(cb1,cb1); % non-ground type 148 | c0=leaf(l); 149 | c1=cord_app(c0,l); % precond violation - c0 and l share 150 | c2 = leaf(nil); 151 | c3=cord_app(c2,l); 152 | c4=cord_app(c3,l); % precond violation - c3 and l share 153 | l1 = cordlist(c4) !l!c1!c3; % !c4 154 | % l1 shares with leaves of c4 and therefore with l 155 | % return(leaf(nil)). % type error 156 | % b = true. % return type error 157 | return(l1) 158 | }. % postcond violation 159 | 160 | -------------------------------------------------------------------------------- /examples/eval.pns: -------------------------------------------------------------------------------- 1 | % Simple example of outermost (lazy) evaluation with sharing of 2 | % sub-expressions. 3 | % We have the following Peano-style rules: 4 | % zero*x = zero 5 | % s(n)*x = x+n*x 6 | % zero+x=x 7 | % s(n)+x = s(n+x) 8 | % Evaluation of {eg) zero*(s(s(s(...)))+zero) should ideally take O(1) time, 9 | % but innermost evaluation will take O(N) time. 10 | % Evaluation of s(s(s(...)))*(s(s(s(...)))+zero) should ideally take O(N) 11 | % time but if we use outermost evaluation and don't share the two 12 | % occurrences of x on the RHS of rule s(n)*x = x+n*x, we end up 13 | % evaluating x N times, resulting in O(N^2) complexity. 14 | % Hence we want to do outermost evaluation but share sub-expressions and 15 | % only evaluate them once. The simplest way to think of this is that we 16 | % destructively update sub-expressions which are shared by outer 17 | % expressions, and we can have a direct implementation using pointers 18 | % and destructive update. One slight subtlety is we need to introduce a 19 | % level of indirection for shared things. Without destructive update of shared 20 | % structures we have to generate new identifiers, put them in a table 21 | % and repeatedly look up and update the table. 22 | 23 | % type for expressions 24 | % Note we don't have a separate a number type - for the low-level 25 | % view its better to have a single type. 26 | type expr ---> 27 | shared(expr) ; % for shared sub-expressions (indirection) 28 | zero ; 29 | s(expr) ; 30 | plus(expr, expr) ; 31 | times(expr, expr). 32 | 33 | % returns test expression 34 | % (currently need dummy arg) 35 | test :: void -> void 36 | sharing test(v)=voidvar 37 | pre nosharing 38 | post nosharing. 39 | test(p) = { 40 | *p1 = times(s(s(zero)), times(zero, plus(s(zero), s(zero)))); 41 | eval(!p1); 42 | return 43 | }. 44 | 45 | % evaluate/simplify expression so it only contains s/1 and zero 46 | % (ie "head normal form", HNF). Most of the work is done by 47 | % eval_whnf - here we just call eval_whnf and recurse down the 48 | % chain of s/1 constructors. 49 | % can't express self-sharing 50 | % shared/1, plus/2 and times/2 are gone by the end 51 | eval :: ref(expr) -> void 52 | sharing eval(!p)=voidvar 53 | pre nosharing 54 | post nosharing. 55 | eval(p) = { 56 | eval_whnf(!p); 57 | cases *p of { 58 | case zero: 59 | return 60 | case s(*p1): 61 | return(eval(!p1)) !p % tail call 62 | % default: panic 63 | } 64 | }. 65 | 66 | % evaluate/simplify *top level* of expression so it is s/1 or zero 67 | % ("weak head normal form", WHNF). 68 | % We can reuse a top-level constructor because we assume the data 69 | % structure is not cyclic (so there are no other refs to the top level). 70 | % However, nested constructors might be shared so we have to be more 71 | % careful with them. Even if the initial data structure has no sharing, 72 | % it may be introduced before recursive calls. We use an extra data 73 | % constructor shared/1 to wrap around expressions we create which are shared, 74 | % which allows us to share the result of the whole expression. We need this 75 | % because only *arguments* of data constructors can be destructively updated. 76 | % We can't, for example, overwrite times(zero,...) with zero, but we can update 77 | % the argument of shared(times(zero,...)) so it becomes shared(zero). 78 | eval_whnf :: ref(expr) -> void 79 | sharing eval_whnf(!p)=voidvar 80 | pre nosharing 81 | post nosharing. 82 | eval_whnf(p) = { 83 | cases *p of { 84 | case zero: 85 | return 86 | case s(*p1): 87 | return 88 | case shared(*p1): 89 | eval_whnf(!p1) !p; 90 | *!p := *p1 !p1; % p1 not mod here - acyclic! 91 | return 92 | case plus(*p1, *p2): 93 | eval_whnf(!p1) !p!p2; % note possible sharing of p1&p2 94 | cases *p1 of { 95 | case zero: % *p==plus(zero, *p2) 96 | % !p2 redundant as long as there are no cycles in DS 97 | % If there is a cycle here we loop 98 | *!p := *p2 !p2!p1; 99 | return(eval_whnf(!p)) % tail call (other vars dead) 100 | case s(*p11): % *p==plus(s(*p11), *p2) 101 | % we reuse the plus/2 constructor by changing 102 | % its first arg from p1 to p11 103 | % !p11!p2 redundant as long as there are no cycles in DS 104 | % If there is a cycle here we will loop but can break 105 | % things, eg x=s(0)+x (LFP=\infty) => s(x=0+x) (LFP=1) 106 | *!p1 := *p11 !p !p11!p2; % *p==plus(*p11, *p2) 107 | % 108 | % Note: we can't reuse the s/1 because it might be shared by p2 109 | % so we allocate a new s/1 instead 110 | *!p := s(*p) !p1!p2!p11; 111 | return 112 | % default: panic 113 | } 114 | case times(*p1, *p2): 115 | eval_whnf(!p1) !p!p2; % note possible sharing of p1&p2 116 | cases *p1 of { 117 | case zero: % *p==times(zero, *p2) 118 | % no need to eval p2 119 | *!p := zero !p1!p2; 120 | return 121 | case s(*p11): % *p==times(s(*p11), *p2)==times(*p1,*p2) 122 | % we reuse the times/2 constructor by changing 123 | % its first arg from p1 to p11, then clobber 124 | % p with plus/2, (sharing *p2) then (re)evaluate 125 | sp2 = shared(*p2); 126 | % !sp2 etc redundant as long as there are no cycles in DS 127 | *!p2 := sp2 !p !p1!sp2!p11; % *p==times(s(*p11), sp2) 128 | *!p1 := *p11 !p !p2!sp2!p11; % *p==times(*p11, sp2) 129 | *!p := plus(sp2, *p) !sp2!p1!p11!p2; % *p==plus(sp2,times(*p11,sp2)) 130 | return(eval_whnf(!p)) % tail call (other vars dead) 131 | % default: panic 132 | } 133 | } 134 | }. 135 | 136 | -------------------------------------------------------------------------------- /examples/evalp.pns: -------------------------------------------------------------------------------- 1 | % Simple example of outermost (lazy) evaluation - "pure" version 2 | % *without* sharing of sub-expressions. See eval.pns for better 3 | % version. This version can do lots of unnecessary re-evaluation, some 4 | % of which could be avoided with a pure version, some of which can't 5 | % easily. Best modify this version to initially convert to whnf. 6 | % We have the following Peano-style rules: 7 | % zero*x = zero 8 | % s(n)*x = x+n*x 9 | % zero+x=x 10 | % s(n)+x = s(n+x) 11 | % Evaluation of s(s(s(...)))*(s(s(s(...)))+zero) should ideally take O(N) 12 | % time but if we use outermost evaluation and don't share the two 13 | % occurrences of x on the RHS of rule s(n)*x = x+n*x, we end up 14 | % evaluating x N times, resulting in O(N^2) complexity. 15 | 16 | % type for expressions 17 | % Note we don't have a separate a number type - for the low-level 18 | % view its better to have a single type. 19 | type expr ---> 20 | zero ; 21 | s(expr) ; 22 | plus(expr, expr) ; 23 | times(expr, expr). 24 | 25 | % returns test expression 26 | % (currently need to supply an arg such as zero) 27 | test :: expr -> expr 28 | sharing test(e0)=e 29 | pre noshared 30 | post noshared. 31 | test(p) = { 32 | return( eval(times(s(s(zero)), times(zero, plus(s(zero), s(zero)))))) 33 | }. 34 | 35 | % evaluate/simplify expression so it only contains s/1 and zero. 36 | eval :: expr -> expr 37 | sharing eval(e)=r 38 | pre noshared 39 | post noshared. 40 | eval(e) = { 41 | cases e of { 42 | case zero: 43 | return( zero) 44 | case s(e1): 45 | tmp1 = eval(e1); 46 | return( s(tmp1)) 47 | case plus(e1, e2): 48 | ee1 = eval(e1); 49 | cases ee1 of { 50 | case zero: % e=plus(zero, e2) 51 | tmp1 = eval(e2); 52 | return( tmp1) % tail call 53 | case s(e11): % e=plus(s(e11), e2) 54 | tmp1 = plus(e11, e2); 55 | tmp2 = eval(tmp1); 56 | return( s(tmp2)) 57 | % default: panic 58 | } 59 | case times(e1, e2): 60 | ee1 = eval(e1); 61 | cases ee1 of { 62 | case zero: % e=times(zero, e2) 63 | % no need to eval e2 64 | return( zero) 65 | case s(e11): % e=times(s(e11), e2) 66 | tmp1 = times(e11, e2); 67 | tmp2 = plus(e2, tmp1); 68 | tmp3 = eval(tmp2); 69 | return( tmp3) % tail call 70 | % default: panic 71 | } 72 | } 73 | }. 74 | -------------------------------------------------------------------------------- /examples/io.pns: -------------------------------------------------------------------------------- 1 | % various stuff for io in Pawns, implemented in C 2 | % Shows how you can interface Pawns and C reasonably easily (and of 3 | % course you can break things this way). They are mostly very simple 4 | % functions so we export the implementation and gcc will very likely inline 5 | % them. 6 | % XXX probably should add sharing info for things returning maybe at least 7 | 8 | export_imp 9 | io_needed, 10 | read_line, 11 | read_word, 12 | print_int, 13 | print_raw, 14 | print_string, 15 | put_char, 16 | get_char. 17 | export_name 18 | string. 19 | 20 | % dummy type for C NULL-terminated strings - we cast to/from char* 21 | type string ---> dummy. 22 | 23 | % we put a dummy function here with stuff at the end to #include what we 24 | % need etc (pawns.h includes some other stuff) 25 | % XXX currently need to import_imp io_needed if we import_imp 26 | % other functions - nicer to have a less imposing way of 27 | % adding #includes etc. Could just export/import names instead 28 | % but the we don't get inlining (not really an issue for IO I 29 | % guess) 30 | io_needed :: void -> void. 31 | io_needed(v) = as_C " {return;} 32 | #include 33 | #include 34 | ". 35 | 36 | 37 | read_word :: void -> maybe(string) 38 | implicit rw io. 39 | read_word(i) = as_C "{ \n\c 40 | char tmp[200], *str; // XXX \n\c 41 | int len; \n\c 42 | len = scanf(\"%199s\", (char*)tmp); // XXX \n\c 43 | if (len == EOF || len == 0) { \n\c 44 | printf(\"EOF\\n\"); \n\c 45 | return nothing(); \n\c 46 | } else { \n\c 47 | len = strlen(tmp); \n\c 48 | str = (char*)GC_MALLOC(len+1); \n\c 49 | strcpy(str, tmp); \n\c 50 | return just((string)str); \n\c 51 | } \n\c 52 | }". 53 | 54 | read_line :: void -> maybe(string) 55 | implicit rw io. 56 | read_line(i) = as_C "{ \n\c 57 | #define READLN_BUF_SZ 500 58 | char tmp[READLN_BUF_SZ], *str; // XXX \n\c 59 | int len, ch; \n\c 60 | if (feof(stdin) != 0) { \n\c 61 | return nothing(); \n\c 62 | } else { \n\c 63 | tmp[0] = 0; // for stdin we might really be at eof? \n\c 64 | fgets(tmp, READLN_BUF_SZ-1, stdin); \n\c 65 | len = strlen(tmp); \n\c 66 | str = (char*)GC_MALLOC(len+1); \n\c 67 | strcpy(str, tmp); \n\c 68 | return just((string)str); \n\c 69 | } \n\c 70 | }". 71 | 72 | print_int :: int -> void 73 | implicit rw io. 74 | print_int(i) = as_C "{ \n\c 75 | printf(\"%ld\\n\", (long)i); \n\c 76 | }". 77 | 78 | % useful for debugging stuff with pointers etc 79 | print_raw :: T -> void 80 | implicit rw io. 81 | print_raw(i) = as_C "{ \n\c 82 | printf(\"%lx\\n\", (long)i); \n\c 83 | }". 84 | 85 | print_string :: string -> void 86 | implicit rw io. 87 | print_string(i) = as_C "{ 88 | fputs((char*)i, stdout); 89 | }". 90 | 91 | put_char :: int -> void 92 | implicit rw io. 93 | put_char(i) = as_C "{ 94 | putchar((int) i); 95 | }". 96 | 97 | get_char :: void -> int 98 | implicit rw io. 99 | get_char(v) = as_C "{ 100 | return (intptr_t) getchar(); 101 | }". 102 | 103 | -------------------------------------------------------------------------------- /examples/isort.pns: -------------------------------------------------------------------------------- 1 | % insertion sort for arrays of ints 2 | 3 | % import print_int from io. 4 | import from array. 5 | 6 | % test case 7 | test_isort :: void -> void 8 | implicit rw io 9 | sharing test_isort(v)=voidvar 10 | pre nosharing 11 | post nosharing. 12 | test_isort(v) = { 13 | s = 6; 14 | a = array_new(s, 42); 15 | p1 = array_nthp(a, 1); 16 | *!p1 := 5 !a; 17 | p2 = array_nthp(a, 2); 18 | *!p2 := 2 !a; 19 | p3 = array_nthp(a, 5); 20 | *!p3 := 7 !a; 21 | !print_array(a); 22 | isort(!a); 23 | !print_array(a); 24 | return 25 | }. 26 | 27 | % sorts array a 28 | isort :: array(int) -> void 29 | sharing isort(!a)=voidvar 30 | pre nosharing 31 | post nosharing. 32 | isort(a) = isort_s(!a, 1, array_size(a)). 33 | 34 | % sorts array a[0..s-1], assuming a[0..i] already sorted 35 | isort_s :: array(int) -> int -> int -> void 36 | sharing isort_s(!a,i,s)=voidvar 37 | pre nosharing 38 | post nosharing. 39 | isort_s(a, i, s) = { 40 | if s <= i then 41 | return 42 | else { 43 | aip = array_nthp(a, i); 44 | ai = *aip; 45 | % !print_int(500); !print_int(i); !print_int(ai); 46 | ins(ai, aip, !a, i); 47 | % print_array(a); 48 | return(isort_s(!a, i+1, s)) 49 | } 50 | }. 51 | 52 | % insert *ajp into a[0..i] by moving elements to the left by 1 53 | % as needed 54 | % very clumsy due to lack of if-then else and && (should do later) 55 | ins :: int -> ref(int) -> array(int) -> int -> void 56 | sharing ins(aj,!ajp,!a,i)=voidvar 57 | pre a=array_(*ajp) % XXX support better abstraction somehow? 58 | post nosharing. 59 | ins(aj, ajp, a, i) = { 60 | % print_array(a); 61 | aip = array_nthp(a, i); 62 | if i <= 0 then { 63 | % print_int(100); print_int(i); print_int(aj); 64 | *!aip := aj !a!ajp % ajp ok? 65 | } else { 66 | i1 = i-1; 67 | ai1p = array_nthp(a, i1); 68 | ai1 = *ai1p; 69 | if ai1 <= aj then { 70 | % print_int(1001); print_int(i); print_int(aj); 71 | *!aip := aj !a!ajp % ajp ok? 72 | } else { 73 | % print_array(a); 74 | % print_int(102); print_int(i); print_int(i1); print_int(*ai1p); 75 | *!aip := *ai1p !a!ajp; 76 | % print_array(a); 77 | ins(aj, !ajp, !a, i1) !ajp 78 | } 79 | } 80 | }. 81 | 82 | print_array :: array(int) -> void 83 | implicit rw io 84 | sharing print_array(a)=voidvar 85 | pre nosharing 86 | post nosharing. 87 | print_array(x) = extern. 88 | -------------------------------------------------------------------------------- /examples/isort_main.c: -------------------------------------------------------------------------------- 1 | // top level for isort.pns could redo in Pawns 2 | // demonstrates C calling Pawns calling extern C function 3 | 4 | #include 5 | #include 6 | #include "pawns.h" 7 | #include "isort.h" 8 | 9 | // XXX should be in .h file ... 10 | extern void print_int(intptr_t i); 11 | 12 | 13 | // see array.pns: arrays are a block of words, the first being the size 14 | void 15 | print_array(array a) { 16 | intptr_t size = *(intptr_t*)a, *ep = (intptr_t*)a + 1; 17 | int j; 18 | printf("print_array %d %d\n", (int) a, size); 19 | for(j=0; j < size; j++) { 20 | print_int((int) *ep++); 21 | } 22 | } 23 | 24 | void 25 | main() { 26 | test_isort(); 27 | exit(0); 28 | } 29 | -------------------------------------------------------------------------------- /examples/makefile: -------------------------------------------------------------------------------- 1 | # makefile for Pawns stuff - try out make pattern rules etc 2 | 3 | # Size of tree for testing bst.pns, pbst.pns (if Max=0 we use a default 4 | # small list and test some higher order stuff). If Max>1400 or so its 5 | # too big without GC for some default limits on process size etc. 6 | Max=12000 7 | Max=30000 8 | Max=0 9 | 10 | # gcc -O3 does a great job 11 | CC=gcc 12 | 13 | # We need to link with the (Boehm++) garbage collector currently, which 14 | # should really be installed somewhere standard, but just in case its 15 | # not. gc details at http://www.hboehm.info/gc/ 16 | GCLIB=~/lib/gc/lib 17 | GC=gc 18 | LDLIBS=-Wl,-rpath -Wl,$(GCLIBDIR) -l$(GC) 19 | # LDFLAGS=-Wl,-rpath -Wl,$(GCLIBDIR) -l$(GC) 20 | 21 | # adt stuff causes *lots* of warnings due to implicit coercion between 22 | # things with size sizeof(void*) currently, so we turn off all warnings 23 | # with -w (for now XXX useful to have them when mixing C and Pawns) 24 | # Also, we need -Wno-incompatible-pointer-types -Wno-int-conversion for 25 | # more recent versions of gcc (some old warnings are now errors) 26 | CFLAGS=-O3 -w -DREDIRECT_MALLOC=GC_malloc -DIGNORE_FREE -Wno-incompatible-pointer-types -Wno-int-conversion 27 | CFLAGS=-O3 -w -Wno-incompatible-pointer-types -Wno-int-conversion 28 | 29 | 30 | # XXX install these somewhere, eg ~/bin at least 31 | PNSC=../compiler/pnsc 32 | PNSC=~/bin/pnsc 33 | ADTPP=../../../adt4c/src/adtpp 34 | ADTPP=~/bin/adtpp 35 | 36 | # The Pawns "compiler" converts foo.pns to foo.c and foo.adt and the 37 | # latter is converted to foo.h by adtpp. foo.c requires foo.h and 38 | # foo.adt should generally not be touched by the user so we can package 39 | # up these two steps together as follows. Make doesn't clean up foo.h 40 | # or foo.adt, but we might want to use the former in our C code and the 41 | # latter can easily be cleaned up and is small anyway. 42 | # adtpp is currently rather noisey so we put the output in a file 43 | # (XXX we include pawns.h as a dependency here for development purposes) 44 | %.c %.h : %.pns pawns.h 45 | $(PNSC) $< 46 | $(ADTPP) $*.adt > adtpp.errs 47 | 48 | # An alternative is to separate these and change the generic %.o : %.c 49 | # rule so it requires a %.h as well, as follows: 50 | # %.o : %.c %.h 51 | # $(CC) $(CPPFLAGS) -c $< -o $@ 52 | # 53 | # %.c %.adt : %.pns 54 | # $(PAWNSC) $< 55 | 56 | # the adtpp tool takes a foo.adt file and generates a foo.h file 57 | # (not needed for Pawns if we use the combined rule but it does no harm 58 | # and can be useful for C code) 59 | %.h : %.adt 60 | $(ADTPP) $< 61 | 62 | allbst: bst pbst bst_poly 63 | 64 | pawns.h: ../compiler/pawns.h 65 | cp $< . 66 | 67 | builtin.h: ../compiler/builtin.h 68 | cp $< . 69 | 70 | apply.h: ../compiler/apply.h 71 | cp $< . 72 | 73 | # bst.pns imports from addlist.pns, io.pns so we put the following dependency 74 | bst.c: bst.pns addlist.pns io.pns pawns.h builtin.h 75 | 76 | bst_poly.c: bst_poly.pns addlist.pns io.pns pawns.h builtin.h 77 | 78 | bst_count.c: bst_count.pns io.pns random.pns pawns.h builtin.h 79 | 80 | pbst.c: pbst.pns addlist.pns io.pns pawns.h builtin.h 81 | 82 | p1bst.c: p1bst.pns addlist.pns io.pns pawns.h builtin.h 83 | 84 | # bst, pbst use main() defined in bst_main.c (not bst_main.pns) 85 | bst: bst.o bst_main.o io.o addlist.o 86 | 87 | bst_poly: bst_poly.o bst_main.o io.o addlist.o 88 | 89 | bst_count: bst_count.o bst_main.o io.o random.o addlist.o 90 | 91 | pbst: pbst.o bst_main.o io.o addlist.o 92 | 93 | p1bst: p1bst.o bst_main.o io.o addlist.o 94 | 95 | bst_main.o: bst.h bst_main.c addlist.h 96 | gcc -c $(CFLAGS) -DMax=$(Max) bst_main.c 97 | 98 | # testio.pns imports from io.pns so we put the following dependency 99 | testio.c: testio.pns io.pns pawns.h builtin.h 100 | 101 | isort.c: isort.pns array.pns io.pns pawns.h builtin.h 102 | 103 | isort: isort_main.c isort.c io.c 104 | 105 | testuf.c: testuf.pns union_find.pns io.pns pawns.h builtin.h 106 | 107 | .bogus: test 108 | test: bst pbst p1bst isort testio 109 | echo TESTING bst:::::::::::::::::::::::::::::::::::: > /dev/null 110 | ./bst 111 | echo TESTING pbst:::::::::::::::::::::::::::::::::::: > /dev/null 112 | ./pbst 113 | echo TESTING p1bst:::::::::::::::::::::::::::::::::::: > /dev/null 114 | ./p1bst 115 | echo TESTING isort:::::::::::::::::::::::::::::::::::: > /dev/null 116 | ./isort 117 | echo TESTING testio:::::::::::::::::::::::::::::::::::: > /dev/null 118 | ./testio < testio.pns 119 | echo DONE :::::::::::::::::::::::::::::::::::: > /dev/null 120 | 121 | .bogus: clean 122 | clean: 123 | rm -f *.adt *.o *.h.gch bst.h bst.c bst_poly.c p1bst.h pbst.h p1bst.c \ 124 | pbst.c testio.c wam.c wam.h bst_count.c bst_count.h \ 125 | io.c io.h imp.c imp.h addlist.c addlist.h io.h bst.h bst_poly.h \ 126 | bst1.h wam.h testio.h isort.h isort.c testuf testuf.c testuf.h \ 127 | bst1.c cord_poly.c bst_a.c cord.c ho.c state.c state.h \ 128 | absshare.c eval.c evalp.c queue_du.c queue_du.h tuple.c tuple.h \ 129 | union_find.c union_find.h random.c random.h rev.h rev.c \ 130 | array.c array.h adtpp.errs 131 | rm -if testio bst p1bst pbst isort bst_poly bst_count 132 | rm -if tmp* a.out errs 133 | 134 | # :set noet ts=8 135 | 136 | -------------------------------------------------------------------------------- /examples/map.pns: -------------------------------------------------------------------------------- 1 | 2 | 3 | type ints = list(int). 4 | 5 | f1 :: (int -> int) -> int -> int 6 | sharing f1(i) = j 7 | pre nosharing 8 | post nosharing. 9 | f1(f, i) = { 10 | j = f(i); 11 | j 12 | }. 13 | 14 | map :: (int -> int) -> ints -> ints. 15 | map(f, mbs) = { 16 | cases mbs of { 17 | case nil: 18 | nil 19 | case cons(mb, mbs1): 20 | cons(f(mb), map(f, mbs1)) 21 | } 22 | }. 23 | -------------------------------------------------------------------------------- /examples/mod.pns: -------------------------------------------------------------------------------- 1 | % very simple module stuff 2 | 3 | import from mod3. 4 | import io_needed, print_int from io. 5 | 6 | main :: void -> void 7 | implicit rw io. 8 | main(v) = { 9 | a = f3a(42); 10 | b = f3b(a); 11 | !print_int(b) 12 | }. 13 | 14 | -------------------------------------------------------------------------------- /examples/mod1.pns: -------------------------------------------------------------------------------- 1 | % simple module stuff 2 | 3 | export_imp bst1, abst1, ints. 4 | export_name bst, list_bst. 5 | % import testimp from 'pns/mod2'. 6 | % import from 'pns/mod2'. 7 | import from 'mod2'. 8 | import print_int from io. 9 | 10 | type bst ---> mt ; node(bst, int, bst). 11 | type ints = list(int). 12 | type rbst = ref(bst). 13 | 14 | testC :: bst -> bst. 15 | testC(b) = as_C "{return b;}". 16 | 17 | bst1 :: void -> bst 18 | sharing bst1(v)=t 19 | pre nosharing 20 | post nosharing. 21 | bst1(v) = { 22 | t = node(mt, 42, mt); 23 | return(t) 24 | }. 25 | 26 | abst1 :: void -> bst 27 | sharing abst1(v)=t 28 | pre nosharing 29 | post t=abstract. 30 | abst1(v) = { 31 | t = node(mt, 42, mt); 32 | return(t) 33 | }. 34 | 35 | ints1 :: void -> ints 36 | sharing ints1(v)= ns 37 | pre nosharing 38 | post ns = abstract. 39 | ints1(v) = { 40 | cons(4, cons(2, cons(1, cons(3, nil)))) 41 | }. 42 | 43 | % convert list to bst - note this appears "pure" to callers 44 | list_bst :: ints -> bst. 45 | % sharing list_bst(xs) = xt 46 | % pre xs = abstract 47 | % post xt = abstract. 48 | % XX the following is less precise than needed (if list_bst is called 49 | % with a concrete list we don't want to stop it being updated later) but 50 | % its what is currently generated if no sharing is specified. 51 | % post xt = abstract; xs = abstract. 52 | list_bst(xs) = { 53 | *tp = mt; 54 | list_bst_du(xs, !tp); 55 | return(*tp) 56 | }. 57 | 58 | % destructively add list of ints to tree we have ptr to 59 | list_bst_du :: ints -> rbst -> void 60 | sharing list_bst_du(xs, !tp) = v 61 | pre nosharing % OK since there is only one arg - could be abstract 62 | % pre xs = abstract 63 | % pre (xs = abstract; tp = abstract) % XX get errors with !tp 64 | post nosharing. 65 | list_bst_du(xs, tp) = { 66 | cases xs of { 67 | case cons(x, xs1): 68 | bst_insert_du(x, !tp); 69 | list_bst_du(xs1, !tp); 70 | return 71 | case nil: 72 | return 73 | } 74 | }. 75 | 76 | % destructively add int to tree we have ptr to 77 | % - traverse down to leaf and clobber it (while loop would be nice) 78 | bst_insert_du :: int -> rbst -> void 79 | sharing bst_insert_du(x, !tp) = v 80 | pre nosharing 81 | post nosharing. 82 | bst_insert_du(x, tp) = { 83 | cases *tp of { 84 | case mt: 85 | *!tp := node(mt, x, mt) 86 | case node(*lp, n, *rp): 87 | cases leq(x, n) of { 88 | case true: 89 | bst_insert_du(x, !lp) !tp 90 | case false: 91 | bst_insert_du(x, !rp) !tp 92 | } 93 | } 94 | }. 95 | 96 | 97 | test1 :: void -> void 98 | sharing test1(v)=v1 99 | pre nosharing 100 | post nosharing. 101 | test1(v) = { 102 | *tp = mt; 103 | bst_insert_du(42, !tp); 104 | % example of passing a concrete DS to a pure fn preventing 105 | % further update of the DS because it might share with abstract DS 106 | t1 = bst_id(*tp); 107 | bst_insert_du(43, !tp); % Error: missing !t1 108 | bst_insert_du(44, !tp) !t1; % Error: t1 abstract 109 | t2 = t1; % dummy use of t1 110 | bst_insert_du(44, !tp); % OK: t1 now dead 111 | tp1 = tp; 112 | t3 = list_bst(ints1(void)); 113 | return(v) 114 | }. 115 | 116 | bst_id :: bst -> bst 117 | sharing bst_id(t)=t1 118 | pre t = abstract 119 | % post (t1 = abstract; t = t1). % want to avoid t = abstract 120 | post (t1 = abstract; t = abstract). % imprecise (curr. default) 121 | % post t1 = abstract. % not sufficient 122 | % for abstract, if the result can share with an input (components have 123 | % the same type) the this should be put explicitly in post, but if 124 | % possible, avoid explicit sharing between args and abstract in post 125 | % - should put this in code for generating implicit pre/post 126 | bst_id(t) = { 127 | return(t) 128 | }. 129 | 130 | bst_size :: bst -> int. 131 | % sharing bst_size(xt)=s 132 | % pre xt = abstract 133 | % post nosharing. 134 | % post s = abstract. % same as nosharing since its atomic 135 | % want to avoid post xt = abstract 136 | bst_size(xs) = { 137 | % XXX STUB 138 | return(42) 139 | }. 140 | 141 | 142 | % print all elements of tree (inorder, no indentation etc to show tree 143 | % structure). Should support declaration of implicit io parameter 144 | % implicit !io 145 | print_tree :: bst -> void 146 | sharing print_tree(t)=voidvar 147 | pre nosharing 148 | post nosharing. 149 | print_tree(t) = { 150 | cases t of { 151 | case mt: 152 | return 153 | case node(l, n, r): 154 | print_tree(l); 155 | print_int(n); 156 | print_tree(r); 157 | return 158 | } 159 | }. 160 | 161 | % as above for list 162 | % implicit !io 163 | print_ints :: list(int) -> void 164 | sharing print_ints(t)=voidvar 165 | pre nosharing 166 | post nosharing. 167 | print_ints(t) = { 168 | cases t of { 169 | case nil: 170 | return 171 | case cons(n, r): 172 | print_int(n); 173 | print_ints(r); 174 | return 175 | } 176 | }. 177 | 178 | % % <= for ints: defined elsewhere in C 179 | % leq :: int -> int -> bool 180 | % sharing leq(p0,p1)=r 181 | % pre nosharing 182 | % post nosharing. 183 | % leq(p0, p1): return(true). 184 | % 185 | % % Defined elsewhere in C 186 | % print_int :: int -> void 187 | % sharing print_int(i)=voidvar 188 | % pre nosharing 189 | % post nosharing. 190 | % print_int(x) : void. 191 | 192 | % extra testing stuff for HO 193 | map :: (int -> int) -> ints -> ints. 194 | map(f, mbs) = { 195 | cases mbs of { 196 | case nil: 197 | nil 198 | case cons(mb, mbs1): 199 | cons(f(mb), map(f, mbs1)) 200 | } 201 | }. 202 | 203 | % XXXXX map2 :: (int -> int -> int) -> ints -> ints. % -> failure 204 | map2 :: (int -> int -> int) -> ints -> ints -> ints. 205 | map2(f, mbs, mcs) = { 206 | cases mbs of { 207 | case nil: 208 | nil 209 | case cons(mb, mbs1): 210 | cases mcs of { 211 | case nil: 212 | nil 213 | case cons(mc, mcs1): 214 | cons(f(mb,mc), map2(f, mbs1, mcs1)) 215 | } 216 | } 217 | }. 218 | 219 | inc :: int -> int. 220 | inc(n) = n+10. 221 | 222 | incs :: ints -> ints. 223 | incs(is) = map(+(20), is). 224 | 225 | add_lists :: ints -> ints -> ints. 226 | add_lists(xs, ys) = map2(+, xs, ys). 227 | 228 | -------------------------------------------------------------------------------- /examples/mod2.pns: -------------------------------------------------------------------------------- 1 | % test import/export 2 | 3 | export_imp testimp. 4 | export_name testimp2, tt. 5 | 6 | type tt ---> foo(tt); bar(int). 7 | 8 | testimp :: int -> int. 9 | testimp(v) = v. 10 | 11 | testimp2 :: int -> int. 12 | testimp2(v) = v. 13 | 14 | -------------------------------------------------------------------------------- /examples/mod3.pns: -------------------------------------------------------------------------------- 1 | % very simple module stuff 2 | 3 | export_name f3a. 4 | export_imp f3b. 5 | 6 | f3a:: int -> int. 7 | f3a(x) = x. 8 | 9 | f3b:: int -> int. 10 | f3b(x) = x. 11 | 12 | -------------------------------------------------------------------------------- /examples/p1bst.pns: -------------------------------------------------------------------------------- 1 | % bst stuff: conversion from list of ints to bst of ints 2 | % modification of pure version pbst.pns to simulate smarter compilation 3 | % which optimises application of a data constructor after a recursive 4 | % call so tail recursion can be implemented. We pass a pointer to the 5 | % tree insert function which is smashed by the call (but we create a new 6 | % node at each level of insertion) 7 | % Can't quite make tree abstract due to sharing imprecision + DU 8 | % See bst_main.c for top level 9 | 10 | import from addlist. 11 | import print_int from io. 12 | 13 | type bst ---> mt ; node(bst, int, bst). 14 | type rbst = ref(bst). 15 | type ints = list(int). 16 | 17 | % convert list to bst 18 | list_bst :: ints -> bst. 19 | list_bst(xs) = list_bst_acc(xs, mt). 20 | 21 | % add list of ints to tree and return new tree 22 | % accumulator version used so order of insertion is L-R 23 | list_bst_acc :: ints -> bst -> bst 24 | sharing list_bst_acc(xs, t) = v 25 | pre xs = abstract 26 | post v = t. 27 | list_bst_acc(xs, t0) = { 28 | cases xs of { 29 | case cons(x, xs1): 30 | list_bst_acc(xs1, bst_insert(x, t0)) 31 | case nil: 32 | t0 33 | } 34 | }. 35 | 36 | % insert by constructing new path 37 | bst_insert :: int -> bst -> bst 38 | sharing bst_insert(x, t) = v 39 | pre nosharing 40 | post v = t. 41 | bst_insert(x, t0) = { 42 | *tp = mt; 43 | bst_insert_du(x, t0, !tp); 44 | *tp 45 | }. 46 | 47 | % add int to tree and smash ref with new version (old version not 48 | % modified) 49 | bst_insert_du :: int -> bst -> rbst -> void 50 | sharing bst_insert_du(x, t, !tp) = v 51 | pre nosharing 52 | post *tp = t. 53 | bst_insert_du(x, t, tp) = { 54 | cases t of { 55 | case mt: 56 | *!tp := node(mt, x, mt) 57 | case node(l, n, r): 58 | % want *!tp := node(*lp=mt, n, *rp=mt); 59 | *!tp := node(mt, n, mt); 60 | cases *tp of { 61 | case node(*lp, *np, *rp): 62 | if x <= n then { 63 | *!rp := r !tp; 64 | % imprecise analysis says *rp and *lp share and 65 | % since lp is du below, rp can't be abstract 66 | bst_insert_du(x, l, !lp) !tp 67 | } else { 68 | *!lp := l !tp; 69 | bst_insert_du(x, r, !rp) !tp 70 | } 71 | } 72 | } 73 | }. 74 | 75 | % sum of data in bst 76 | bst_sum :: bst -> int. 77 | bst_sum(t) = { 78 | cases t of { 79 | case mt: 80 | 0 81 | case node(l, n, r): 82 | n + bst_sum(l) + bst_sum(r) 83 | } 84 | }. 85 | 86 | % print all elements of tree (inorder, no indentation etc to show tree 87 | % structure). 88 | print_tree :: bst -> void 89 | implicit rw io 90 | sharing print_tree(t)=voidvar 91 | pre nosharing 92 | post nosharing. 93 | print_tree(t) = { 94 | cases t of { 95 | case mt: 96 | return 97 | case node(l, n, r): 98 | !print_tree(l); 99 | !print_int(n); 100 | !print_tree(r) 101 | } 102 | }. 103 | 104 | % as above for list 105 | print_ints :: list(int) -> void 106 | implicit rw io 107 | sharing print_ints(t)=voidvar 108 | pre nosharing 109 | post nosharing. 110 | print_ints(t) = { 111 | cases t of { 112 | case nil: 113 | return 114 | case cons(n, r): 115 | !print_int(n); 116 | !print_ints(r) 117 | } 118 | }. 119 | -------------------------------------------------------------------------------- /examples/pbst.pns: -------------------------------------------------------------------------------- 1 | % bst stuff: conversion from list of ints to bst of ints 2 | % pure version (see bst.pns) 3 | % printing tree,... 4 | % See bst_main.c for top level 5 | 6 | import from addlist. 7 | import print_int from io. 8 | 9 | type bst ---> mt ; node(bst, int, bst). 10 | type ints = list(int). 11 | 12 | % convert list to bst 13 | list_bst :: ints -> bst. 14 | list_bst(xs) = list_bst_acc(xs, mt). 15 | 16 | % add list of ints to tree and return new tree 17 | % accumulator version used so order of insertion is L-R 18 | list_bst_acc :: ints -> bst -> bst. 19 | list_bst_acc(xs, t0) = { 20 | cases xs of { 21 | case cons(x, xs1): 22 | list_bst_acc(xs1, bst_insert(x, t0)) 23 | case nil: 24 | t0 25 | } 26 | }. 27 | 28 | % insert by constructing new path 29 | bst_insert :: int -> bst -> bst. 30 | % sharing bst_insert_du(x, t0) = t 31 | % pre nosharing 32 | % post t1 = t. % int keys don't share 33 | bst_insert(x, t0) = { 34 | cases t0 of { 35 | case mt: 36 | node(mt, x, mt) 37 | case node(l, n, r): 38 | cases x <= n of { 39 | case true: 40 | node(bst_insert(x, l), n, r) 41 | case false: 42 | node(l, n, bst_insert(x, r)) 43 | } 44 | } 45 | }. 46 | 47 | % sum of data in bst 48 | bst_sum :: bst -> int. 49 | bst_sum(t) = { 50 | cases t of { 51 | case mt: 52 | 0 53 | case node(l, n, r): 54 | n + bst_sum(l) + bst_sum(r) 55 | } 56 | }. 57 | 58 | % print all elements of tree (inorder, no indentation etc to show tree 59 | % structure). 60 | print_tree :: bst -> void 61 | implicit rw io 62 | sharing print_tree(t)=voidvar 63 | pre nosharing 64 | post nosharing. 65 | print_tree(t) = { 66 | cases t of { 67 | case mt: 68 | return 69 | case node(l, n, r): 70 | !print_tree(l); 71 | !print_int(n); 72 | !print_tree(r) 73 | } 74 | }. 75 | 76 | % as above for list 77 | print_ints :: list(int) -> void 78 | implicit rw io 79 | sharing print_ints(t)=voidvar 80 | pre nosharing 81 | post nosharing. 82 | print_ints(t) = { 83 | cases t of { 84 | case nil: 85 | return 86 | case cons(n, r): 87 | !print_int(n); 88 | !print_ints(r) 89 | } 90 | }. 91 | 92 | -------------------------------------------------------------------------------- /examples/pres.pns: -------------------------------------------------------------------------------- 1 | % various things related to type preservation/safety 2 | 3 | id :: T -> T 4 | sharing id(x) = y 5 | pre nosharing 6 | post y=x. 7 | id(x) = x. 8 | 9 | idri :: ref(int) -> ref(int) 10 | sharing idri(x) = y 11 | pre nosharing 12 | post y=x. 13 | idri(x) = x. 14 | 15 | idrlb :: ref(list(bool)) -> ref(list(bool)) 16 | sharing idrlb(x) = y 17 | pre nosharing 18 | post y=x. 19 | idrlb(x) = x. 20 | 21 | inc :: int -> int. 22 | inc(x) = x+1. 23 | 24 | idrli :: ref(list(int)) -> ref(list(int)) 25 | sharing idrli(x) = y 26 | pre nosharing 27 | post y=x. 28 | idrli(x) = x. 29 | 30 | assign :: ref(T) -> T -> void 31 | sharing assign(!xp, y) = v % XXX should have !y if pre y = *xp? 32 | % pre y = *xp 33 | pre nosharing 34 | post y = *xp. 35 | assign(xp, y) = { 36 | *!xp := y; 37 | return 38 | }. 39 | 40 | 41 | % (possibly) use and smash list(int) 42 | duli :: ref(list(int)) -> void 43 | sharing duli(!xp) = v 44 | pre nosharing 45 | post nosharing. 46 | duli(xp) = { 47 | return 48 | }. 49 | 50 | % (possibly) use and smash list(bool) 51 | dulb :: ref(list(bool)) -> void 52 | sharing dulb(!xp) = v 53 | pre nosharing 54 | post nosharing. 55 | dulb(xp) = { 56 | return 57 | }. 58 | 59 | const :: A -> B -> A 60 | sharing const(a, b) = r 61 | pre nosharing 62 | post r = a. 63 | const(a, b) = a. 64 | 65 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 66 | 67 | scope :: void -> void. 68 | scope(v) = { 69 | if 1 < 2 then 70 | l = nil % list(T1) 71 | else 72 | l = cons(42,nil); % list(int) 73 | % l :: list(int) 74 | *lp = l; 75 | x = idrli(lp); % list(int) required 76 | 77 | if 1 < 2 then { 78 | l1 = nil; % list(T2) 79 | l2 = l1 % list(T2) 80 | % note: l2 = nil would give different types 81 | } else { 82 | l1 = nil; % list(T3) 83 | l2 = l1 % list(T3) 84 | }; 85 | % T2, T3 unified 86 | *lp1 = l1; 87 | *!lp1 := l2 % same types - no problem 88 | }. 89 | 90 | test1 :: void -> void. 91 | test1(q) = { 92 | l42 = cons(42,nil); 93 | lt = cons(true,nil); 94 | 95 | *np = nil; % ref(list(T)) 96 | snp = np; 97 | assign(!np, l42) !snp; % instantiates type; last use of np 98 | *!snp := l42 !l42!np; % snp :: ref(list(int)) now 99 | 100 | *np1 = nil; % ref(list(T)) 101 | snp1 = np1; 102 | assign(np1, l42) !snp1; % last use of np1 but poly type so we must bang 103 | *!snp1 := lt !l42; % instantiates T to bool (need !np1 also) 104 | 105 | *np2 = nil; % ref(list(T)) 106 | *!np2 := l42; % instantiates T to int, like assign fn call 107 | 108 | % trying to reproduce bug in init_checkout_qa analysis 109 | % XXXX 110 | *np3 = t2(nil,nil); % pair of ref(list(T)) 111 | *lp3 = t2(l42,l42); % pair of ref(list(int)) 112 | *!lp3 := *np3; % instantiates T 113 | return 114 | }. 115 | 116 | test2 :: void -> void. 117 | test2(q) = { 118 | *fp1 = id; % A->A 119 | f1 = *fp1; 120 | i1 = f1(1); 121 | t1 = f1(true); 122 | 123 | *fp2 = id; % A->A 124 | assign(!fp2, id); % same, but warning/note 125 | f2 = *fp2; 126 | t2 = f2(true); 127 | i2 = f2(2); 128 | 129 | *fp3 = id; % A->A 130 | assign(!fp3, not); % now bool -> bool 131 | f3 = *fp3; 132 | t3 = f3(true); % ok 133 | i3 = f3(3); % error 134 | assign(!fp3, inc); % error 135 | 136 | *fp4 = id; % A->A 137 | sfp4 = fp4; % sharing 138 | assign(!fp4, not) !sfp4; % now bool -> bool 139 | f4 = *sfp4; 140 | t4 = f4(true); % ok 141 | i4 = f4(4); % error 142 | assign(!sfp4, inc) ! fp4; % error 143 | 144 | *fp5 = not; % bool -> bool 145 | assign(!fp5, id); % bool -> bool instance of id used! 146 | f5 = *fp5; 147 | % XXX without f5 = *fp5 we barf below 148 | t5 = f5(true); % ok 149 | i5 = f5(5); % error 150 | assign(!fp5, inc); % error 151 | 152 | /* 153 | *fp2 = id; % A->A 154 | assign(!fp2, not); 155 | f2 = *fp2; 156 | t2 = f2(true); 157 | i2 = f2(2); 158 | assign(!fp2, inc); 159 | 160 | *fp2 = id; % A->A 161 | *!fp2 := inc; 162 | t2 = *fp2(true); 163 | *fp2 = id; % A->A 164 | assign(!fp2, not); 165 | assign(!fp2, inc); 166 | *!fp2 := not; 167 | i2 = *fp2(2); 168 | *!fp2 := inc; 169 | t2 = *fp2(true); 170 | */ 171 | 172 | return 173 | }. 174 | 175 | % Add more examples 176 | % 177 | % arrow types with pre/post conds 178 | % 179 | % What should we do with := - allow type to be instaniated like with assign etc 180 | % rather than give error - seems reasonable (silly that assign is more flexible 181 | % than assign) 182 | % 183 | % Separate issue slighty but if/then/else should also unify types and give warning 184 | % if they are not identical for vars defined in different branches 185 | % 186 | % Is there then any need for casts, other than possibly making code more 187 | % readable? 188 | -------------------------------------------------------------------------------- /examples/random.pns: -------------------------------------------------------------------------------- 1 | % Purely functional random number interface to C random() in Pawns 2 | 3 | % Uses a Pawns state variable, random_state, to store state. 4 | % init_random(seed) does memory allocation, calls C initstate() and 5 | % initialises random_state 6 | % random_num(void) calls C setstate() (with *random_state) and random() 7 | % and returns the next random number in the sequence. 8 | % 9 | % Note they behave like pure functions because state variables are saved 10 | % and restored appropriately (so a sub-computation may have a separate 11 | % use of random numbers that won't interfere with the sequence of random 12 | % numbers returned), though the threading of state is done implicitly. 13 | 14 | export_name 15 | state_t, 16 | random_state, 17 | init_random, 18 | random_num. 19 | 20 | type state_t ---> dummy. % we cast to char * 21 | 22 | !random_state:: ref(state_t). 23 | 24 | % initialises random_state using C initstate() 25 | init_random :: int -> void 26 | implicit wo random_state. 27 | init_random(seed) = as_C " { 28 | unsigned useed = seed; 29 | size_t state_size = 256; 30 | char *state = ADT_MALLOC(state_size); 31 | *random_state = (state_t) state; 32 | initstate(seed, state, state_size); 33 | return; 34 | }". 35 | 36 | % returns random number using C random(), 37 | % after setting the state to random_state 38 | random_num :: void -> int 39 | implicit rw random_state. 40 | random_num(v) = as_C " { 41 | char *old_state = setstate((char *) *random_state); 42 | return (intptr_t)random(); 43 | }". 44 | 45 | -------------------------------------------------------------------------------- /examples/rectype.pns: -------------------------------------------------------------------------------- 1 | % some simple types with not so simple recursion for testing type path 2 | % folding etc 3 | % XXX should have some more code for testing also, including constructing 4 | % terms a deconstructing using case (done) then checking sharing 5 | 6 | type r1 ---> r1z ; r1c(r1). % simple recursion 7 | 8 | type r1r ---> r1rz ; r1rc(ref(r1r)). % simple recursion but through ref 9 | 10 | type r1rr ---> r1rrz ; r1rrc(ref(ref(r1rr))). % recursion through two refs 11 | 12 | type r2 ---> r2z ; r2c1(r2a). % double recursion 13 | type r2a ---> r2c2(r2). 14 | 15 | type r2r ---> r2rz ; r2rc1(r2ra). % double recursion through ref 16 | type r2ra ---> r2rc2(ref(r2r)). 17 | % There are memory cells containing values of type r2r, r2ra and 18 | % ref(r2r) so we need (at least) three distinct type paths for sharing 19 | % (unless we map different types to the same path, which is unlikely to 20 | % be a good idea). XXX 21 | 22 | type r3 ---> r3z ; r3c1(r3a). % triple recursion 23 | type r3a ---> r3c2(r3b). 24 | type r3b ---> r3c3(r3). 25 | 26 | % Examples from sharing paper 27 | type mme = maybe(maybe(either(int, int))). 28 | type rtrees = list(rtree). 29 | type rtree ---> rnode(int, rtrees). 30 | 31 | % XXX should be error with lower case t 32 | type rlist(T) ---> rnil ; rcons(T, ref(rlist(T))). 33 | 34 | test:: r1 -> r1 35 | sharing test(a) = r 36 | pre nosharing 37 | post r=r1c(a). 38 | test(a) = { 39 | a1 = r1c(r1z); 40 | b1 = r1c(a1); 41 | % 42 | *a1r = r1rz; 43 | b1r = r1rc(a1r); 44 | % 45 | **a1rr = r1rrz; 46 | *b1rr = r1rrc(a1rr); 47 | *!b1rr := r1rrc(a1rr) !a1rr; 48 | % **a1rr := r1rrz; % XXX Warning: assigned variable not def. 49 | c1rr = *a1rr; 50 | *c1rr := r1rrz; 51 | % 52 | *a2r = r2rz; 53 | b2r = r2rc2(a2r); 54 | *c2ra = r2rc1(b2r); 55 | d2r = r2rc2(c2ra); 56 | *!c2ra := r2rc1(b2r) !d2r; 57 | cases *c2ra of { 58 | case r2rc1(*e2r): 59 | void 60 | }; 61 | cases d2r of { 62 | case r2rc2(*f2r): 63 | void 64 | }; 65 | **g2r = d2r; 66 | % **!g2r := r2rc2(c2ra); % XXX Error: function call as LHS of := ... 67 | % 68 | b1 69 | }. 70 | 71 | f1:: r1 -> r1 72 | sharing f1(a) = r 73 | pre nosharing 74 | post r=r1c(a). 75 | f1(a) = r1c(a). 76 | 77 | f2:: r2 -> r2 78 | sharing f2(a) = r 79 | pre nosharing 80 | post r=r2c1(r2c2(a)). 81 | % f1(a) = r2c1(r2c2(a)). % XXX should get redefinition error 82 | f2(a) = r2c1(r2c2(a)). 83 | 84 | f2r:: r2r -> r2r 85 | sharing f2r(a) = r 86 | pre nosharing 87 | % post *ap = a; r=r2rc1(r2rc2(ap)). 88 | post inferred. 89 | f2r(a) = { 90 | *ap = a; 91 | r2rc1(r2rc2(ap)) 92 | }. 93 | 94 | f3:: r3 -> r3 95 | sharing f3(a) = r 96 | pre nosharing 97 | % post r=r3c1(r3c2(r3c3(a))). 98 | post inferred. 99 | f3(a) = r3c1(r3c2(r3c3(a))). 100 | -------------------------------------------------------------------------------- /examples/t.pns: -------------------------------------------------------------------------------- 1 | % more testing of sharing analysis stuff for paper etc 2 | 3 | % example where our sharing analysis is more precise than in Mars etc 4 | % because 1) constants dont alias, and 2) cases can eliminate sharing 5 | % for each case (eg, if xs=nil then returning xs causes no sharing) 6 | map_const_1 :: list(int) -> list(int) 7 | sharing map_const_1(xs) = ys 8 | pre nosharing 9 | post nosharing. 10 | map_const_1(xs) = { 11 | cases xs of { 12 | case nil: xs % can look like result shares with xs 13 | case cons(x,xs1): cons(1, map_const_1(xs1)) 14 | } 15 | }. 16 | 17 | /* 18 | Other examples from Matt's thesis (p196- in draft) 19 | 20 | sa(( 21 | *x = true; 22 | y = x; 23 | z = y 24 | )). 25 | [s(x._ref,x._ref),s(x._ref,y._ref),s(x._ref,z._ref),s(y._ref,y._ref),s(y._ref,z._ref),s(z._ref,z._ref)] 26 | note: s(x._ref,z._ref) 27 | 28 | sa(( 29 | *a = true; 30 | b = a; 31 | cases *a of { 32 | case true: c = b 33 | case false: d = b 34 | } 35 | )). 36 | [s(a._ref,a._ref),s(a._ref,b._ref),s(a._ref,c._ref),s(a._ref,d._ref),s(b._ref,b._ref),s(b._ref,c._ref),s(b._ref,d._ref),s(c._ref,c._ref),s(d._ref,d._ref)] 37 | note: s(a._ref,c._ref) but no c-d alias 38 | 39 | sa(( 40 | *a = true; 41 | *d = true; 42 | b = a; 43 | cases *a of { 44 | case true: c = b 45 | case false: d = d 46 | } 47 | )). 48 | [s(a._ref,a._ref),s(a._ref,b._ref),s(a._ref,c._ref),s(b._ref,b._ref),s(b._ref,c._ref),s(c._ref,c._ref),s(d._ref,d._ref)] 49 | note: s(a._ref,c._ref) but no a-d or b-d alias 50 | 51 | */ 52 | 53 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% old 54 | 55 | % test3 :: bool -> pair(bool,bool). 56 | % test3(b) = { 57 | % m = just(true); 58 | % f = maybenot(m); 59 | % f1 = maybenot1(m); 60 | % cases m of { 61 | % case just(*bp): 62 | % *!bp := false; % !f % XX smashes f but not f1 63 | % return(pair(f(b), f1(b))) 64 | % } 65 | % }. 66 | % 67 | % maybenot :: maybe(bool) -> bool -> bool. 68 | % maybenot(m, b) = extern. 69 | % maybenot1 :: maybe(bool) -> bool -> bool. 70 | % maybenot1(m, b) = extern. 71 | -------------------------------------------------------------------------------- /examples/test.pns: -------------------------------------------------------------------------------- 1 | % more testing of sharing analysis subtleties 2 | % syntax munged? 3 | 4 | type cb ---> leaf(rrb) ; branch(cb, cb). 5 | type rb = ref(bool). 6 | type rrb = ref(rb). 7 | 8 | proc test1(void:: v) 9 | pre nosharing 10 | post nosharing. 11 | test1(v) = { 12 | bool:: * *aax = true; 13 | bool:: * *ay = false; 14 | cb:: l = leaf(aax); 15 | cb:: r = leaf(ay); 16 | cb:: t = branch(l, r); 17 | cases cb:: t of { 18 | case branch(zl1, zr1): % zl1=l, zr1=r 19 | cases cb:: zl1 of { 20 | case leaf(zx1): % zx1=aax 21 | cases cb:: zr1 of { 22 | case leaf(zy1): % zy1=ay 23 | rb:: *!zx1 := *zy1 !aax!zl1!zr1!l!r!t!zy1!ay 24 | } 25 | } 26 | }; 27 | ref(bool):: aaxp = *aax; 28 | bool:: *!aaxp := true !l!t!aax!zl1!zx1!zr1!zy1!ay!r; 29 | bool:: * *!aax := true !l!t!aaxp!r!zl1!zr1!zx1!zy1!r!ay; 30 | return 31 | }. 32 | 33 | % bool:: tmp = true 34 | /* 35 | bool:: * *a = true; 36 | bool:: * *b = false; 37 | 38 | sa(( 39 | ref(ref(bool))::aa = a; 40 | ref(bool):: *!a := *b; % !aa; 41 | bool:: * *!a := false !aa; % XXX !b needed 42 | bool:: tmp = true)). 43 | 44 | sa((bool:: *rt = true; 45 | ref(bool):: *rrt = rt; 46 | ref(ref(bool)):: rrt1 = rrt; 47 | bool:: *rf = false; 48 | ref(bool):: *rrt := rf)). 49 | 50 | % XX next example shows old(?) sharing anal too conservative: 51 | % because p shares with j at := we don't throw away some sharing, 52 | % whereas for next example below there isn't any. 53 | % for both, sharing for q is not thrown away but new is added 54 | sa(( 55 | (p:: ref(pair(maybe(bool),maybe(bool)))); 56 | j = just(true); 57 | *p = pair(nothing,j); 58 | *q = *p; 59 | *p := pair(j,nothing) 60 | )). 61 | 62 | sa(( 63 | (p:: ref(pair(maybe(bool),maybe(bool)))); 64 | j = just(true); 65 | k = just(true); 66 | *p = pair(nothing,j); 67 | *q = *p; 68 | *p := pair(k,nothing) 69 | )). 70 | 71 | % similar to 2 above but we have q = p instead of *q = *p, so 72 | % we get q.ref.pair/2.1.ref.just.ref in sharing. We must also keep 73 | % q.ref.pair/2.2.ref.just.ref if we only know there is possible 74 | % sharing between q and p (not definite). Because *p is assigned 75 | % we would be able to avoid p.ref.pair/2.2.ref.just.ref in sharing 76 | % but it shares with q - is this a problem??? shouldn't be??? 77 | sa(( 78 | (p:: ref(pair(maybe(bool),maybe(bool)))); 79 | j = just(true); 80 | *p = pair(nothing,j); 81 | q = p; 82 | *p := pair(j,nothing) 83 | )). 84 | 85 | % need to keep aliasing between p and q 86 | sa(( 87 | (q :: ref(maybe(bool))); 88 | p = q; 89 | j = just(true); 90 | *p := j 91 | )). 92 | 93 | % don't need to keep aliasing between p and q 94 | sa(( 95 | (q :: ref(maybe(bool))); 96 | *p = *q; 97 | j = just(true); 98 | *p := j 99 | )). 100 | 101 | */ 102 | -------------------------------------------------------------------------------- /examples/testio.pns: -------------------------------------------------------------------------------- 1 | % test of basic IO functionality 2 | % like cat but a line at a time 3 | 4 | import from io. 5 | 6 | main :: void -> void 7 | implicit rw io. 8 | main(v) = { 9 | ms = !read_line(void); 10 | cases ms of { 11 | case nothing: % eof 12 | void % should support exit(0) 13 | case just(s): 14 | !print_string(s); 15 | !main(v) 16 | } 17 | }. 18 | -------------------------------------------------------------------------------- /examples/testq.pns: -------------------------------------------------------------------------------- 1 | % test of basic queue functionality 2 | % 63 = ASCII code for question mark - add nicer way of doing this XXX 3 | 4 | import from queue_du. 5 | import from io. 6 | 7 | main1:: void -> void 8 | sharing main1(v) = v1 % XXX omit =v1 for weird type error message: 9 | % 'Error: incompatible return type:'(void, (void sharing 10 | % main1(v)pre nosharing post nosharing)) 11 | pre nosharing 12 | post nosharing. 13 | main1(v) = { 14 | % q = (q_empty(v) :: queue(int)); 15 | q = q_empty(v); 16 | return(void) 17 | }. 18 | 19 | % as described above 20 | type queue(T) = pair(list(T), ref(list(T))). 21 | 22 | % create empty queue 23 | % Need to create a temporary pointer to nil that gets thrown away 24 | % because we can't have uninitialised components in data structures. 25 | % Also need a cast to link up the type parameter in the signature with 26 | % the the introduced type param of the empty list(s) - could potentially 27 | % weaken type checking to make this unnecessary; also need to change 28 | % syntax/reading to link type vars in declarations with type vars in 29 | % function definitions 30 | % Need to say args of pair share because DU is used in other queue functions 31 | % - a bit cumbersome. 32 | q_empty:: void -> queue(T) 33 | sharing q_empty(v) = q 34 | pre nosharing 35 | post nosharing. 36 | q_empty(v) = { 37 | % n = (nil :: list('_type_param'(1))); 38 | n = nil; 39 | *np = n; 40 | q = t2(n, np); % second arg points to the wrong nil 41 | return(q) 42 | }. 43 | -------------------------------------------------------------------------------- /examples/testuf.pns: -------------------------------------------------------------------------------- 1 | % test union-find stuff 2 | 3 | import from union_find. 4 | % import print_ref from io. 5 | import from io. 6 | 7 | main :: void -> void 8 | implicit rw io. 9 | main(v) = { 10 | !put_char(10); 11 | s1 = singleton(void); 12 | s2 = singleton(void); 13 | s3 = singleton(void); 14 | s4 = singleton(void); 15 | s5 = singleton(void); 16 | s6 = singleton(void); 17 | s7 = singleton(void); 18 | s8 = singleton(void); 19 | s9 = singleton(void); 20 | !print_raw(*s1); 21 | !print_raw(*s2); 22 | !print_raw(*s3); 23 | !print_raw(*s4); 24 | !print_raw(*s5); 25 | !print_raw(*s6); 26 | !print_raw(*s7); 27 | !put_char(10); 28 | !print_raw(*find(!s1)); 29 | !print_raw(*find(!s1)); 30 | !print_raw(*find(!s5)); 31 | !print_raw(*find(!s6)); 32 | merge(!s5, !s6); 33 | !put_char(10); 34 | !put_char(10); 35 | !print_raw(*s5); 36 | !print_raw(*s6); 37 | !print_raw(*find(!s5)) !s6; 38 | !print_raw(*find(!s6)) !s5; 39 | merge(!s7, !s6) !s5; 40 | merge(!s1, !s6) !s5!s7; 41 | !put_char(10); 42 | !print_raw(*find(!s1)) !s5!s6; % !s7 (but s7 is dead) 43 | !print_raw(*find(!s5)) !s6; 44 | !print_raw(*find(!s6)); 45 | void 46 | }. 47 | -------------------------------------------------------------------------------- /examples/tuple.pns: -------------------------------------------------------------------------------- 1 | % Some utilities for tuples 2 | 3 | % Types for tuples (just pair currently built-in) 4 | % data constructors are t2, t3, t4,... (no t1 or t0 - could add) 5 | % types are tuple2 (= pair), tuple3 (= triple),... 6 | % Best have functions that return *pointer* to each arg: 7 | % t3_2r take a tuple2 and returns pointer to arg 2, etc 8 | % Sharing is as precise as possible given polymorphism. 9 | % 10 | % Older interface (can easily be defined in terms of above) 11 | % - they have been left in for now 12 | % Extract arguments/fields 13 | % t2_1 returns first arg of a tuple2, t2_2 returns second, etc 14 | % Assign to arguments/fields 15 | % t2_1assign assigns to first arg of a tuple2, etc 16 | % 17 | % XXX not all functions are defined yet - need some more copy/paste/edit 18 | % 19 | % For extracting arguments of tuples the code here is abstract - no 20 | % sharing is declared. For use with code where sharing needs to be 21 | % tracked renaming can be used and the renamed function(s), with more 22 | % specific types, can have whatever sharing is required (or you can just 23 | % copy/paste/edit though its more error prone). For the assignment 24 | % functions, the tuple can't be abstract so sharing must be declared and 25 | % we have nosharing for all the preconditions (we can't have sharing 26 | % between tuple args in this polymorphic code because they have different 27 | % types). If tuples are used where there is sharing, renaming can be used 28 | % as above. 29 | 30 | export_imp 31 | tuple2, 32 | tuple3, 33 | triple, 34 | tuple4, 35 | quadruple, 36 | tuple5, 37 | t2_1r, 38 | t2_2r, 39 | t3_1r, 40 | t3_2r, 41 | t3_3r, 42 | % could delete following?? 43 | t2_1, 44 | t2_2, 45 | t2_1assign, 46 | t2_2assign, 47 | t3_1, 48 | t3_2, 49 | t3_3. 50 | 51 | type tuple2(A, B) = pair(A, B). % added for consistent naming 52 | 53 | type tuple3(A, B, C) ---> t3(A, B, C). 54 | type triple(A, B, C) = tuple3(A, B, C). 55 | type tuple4(A, B, C, D) ---> t4(A, B, C, D). 56 | type quadruple(A, B, C, D) = tuple4(A, B, C, D). 57 | type tuple5(A, B, C, D, E) ---> t5(A, B, C, D, E). 58 | 59 | 60 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 61 | % ref functions 62 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 63 | 64 | t2_1r:: tuple2(A, B) -> ref(A) 65 | sharing t2_1r(t) = v 66 | pre nosharing 67 | post inferred. 68 | t2_1r(t) = { 69 | cases t of { 70 | case t2(*r, b): 71 | r 72 | } 73 | }. 74 | 75 | t2_2r:: tuple2(A, B) -> ref(B). 76 | t2_2r(t) = { 77 | cases t of { 78 | case t2(a, *r): 79 | r 80 | } 81 | }. 82 | 83 | t3_1r:: tuple3(A, B, C) -> ref(A) 84 | sharing t3_1r(t) = v 85 | pre nosharing 86 | post inferred. 87 | t3_1r(t) = { 88 | cases t of { 89 | case t3(*r, b, c): 90 | r 91 | } 92 | }. 93 | 94 | t3_2r:: tuple3(A, B, C) -> ref(B). 95 | t3_2r(t) = { 96 | cases t of { 97 | case t3(a, *r, c): 98 | r 99 | } 100 | }. 101 | 102 | t3_3r:: tuple3(A, B, C) -> ref(C). 103 | t3_3r(t) = { 104 | cases t of { 105 | case t3(a, b, *r): 106 | r 107 | } 108 | }. 109 | 110 | % add t4 etc 111 | 112 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 113 | % t2 114 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 115 | 116 | t2_1:: tuple2(A, B) -> A. 117 | t2_1(t) = { 118 | cases t of { 119 | case t2(a, b): 120 | a 121 | } 122 | }. 123 | 124 | t2_1assign:: tuple2(A, B) -> A -> void 125 | sharing t2_1assign(!t, n) = v 126 | pre nosharing 127 | post 128 | cases t of { 129 | case t2(a, b): 130 | n = a 131 | }. 132 | t2_1assign(t, n) = { 133 | cases t of { 134 | case t2(*a, *b): 135 | *!a := n !t 136 | } 137 | }. 138 | 139 | t2_2:: tuple2(A, B) -> B. 140 | t2_2(t) = { 141 | cases t of { 142 | case t2(a, b): 143 | b 144 | } 145 | }. 146 | 147 | t2_2assign:: tuple2(A, B) -> B -> void 148 | sharing t2_2assign(!t, n) = v 149 | pre nosharing 150 | post 151 | cases t of { 152 | case t2(a, b): 153 | n = b 154 | }. 155 | t2_2assign(t, n) = { 156 | cases t of { 157 | case t2(*a, *b): 158 | *!b := n !t 159 | } 160 | }. 161 | 162 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 163 | % t3 164 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 165 | 166 | t3_1:: tuple3(A, B, C) -> A. 167 | t3_1(t) = { 168 | cases t of { 169 | case t3(a, b, c): 170 | a 171 | } 172 | }. 173 | 174 | t3_2:: tuple3(A, B, C) -> B. 175 | t3_2(t) = { 176 | cases t of { 177 | case t3(a, b, c): 178 | b 179 | } 180 | }. 181 | 182 | t3_3:: tuple3(A, B, C) -> C. 183 | t3_3(t) = { 184 | cases t of { 185 | case t3(a, b, c): 186 | c 187 | } 188 | }. 189 | 190 | % XXX add t3_1_assign etc 191 | 192 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 193 | % add t4 etc 194 | %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 195 | -------------------------------------------------------------------------------- /examples/union_find.pns: -------------------------------------------------------------------------------- 1 | % Union-Find data structure using destructive update to get 2 | % asymptotically optimal performance (and should be reasonable 3 | % constant factors). 4 | 5 | export_imp 6 | singleton, % create singleton set/element 7 | find, % find representative element from set/element 8 | merge, % merge/union two sets 9 | same, % test if two elements are in the same set 10 | eq_ptr, % should be built-in (test for equality of elements) 11 | uf_node, % type for DS used 12 | element. % type for elements = ref(uf_node) 13 | 14 | % Rather than use an array of integers (with max size or the 15 | % complexities of dynamic arrays) we use pointers to nodes which are 16 | % either root nodes containing a rank (so chain length can be reduced) 17 | % or child nodes, which point to their parent. New elements can be 18 | % added just by creating a new root node (with zero rank). Rank is only 19 | % stored at root nodes (saves a little space but no big deal) and we 20 | % don't use self-pointers for root nodes (so some tricky coding tricks 21 | % can't be used) 22 | 23 | type uf_node ---> root(int) ; child(uf_node). 24 | type element = ref(uf_node). 25 | 26 | % return new singleton set - a pointer to a root node with rank 0 27 | % We explicitly state nosharing because we don't want sharing with 28 | % abstract as destructive update may be used later. 29 | singleton :: void -> element 30 | sharing singleton(v) = a 31 | pre nosharing 32 | post nosharing. 33 | singleton(v) = { 34 | *rp = root(0); 35 | rp 36 | }. 37 | 38 | % find representative element of set from an element 39 | % Result may share with argument, which may be updated to shorten chain. 40 | % Recursive coding that effectively traverses the chain twice and 41 | % collapses it completely (child nodes that are no longer needed can be 42 | % garbage collected) 43 | % For efficiency it might be best to unfold the recursion one step as 44 | % this is the "inner loop" of union-find?? 45 | find :: element -> element 46 | sharing find(!np) = rp 47 | pre nosharing 48 | post rp = np. 49 | find(np) = { 50 | cases *np of { 51 | % case root(rank): np 52 | case child(*pparent): 53 | % rp = find(!pparent) !np; 54 | rp = np; 55 | *!pparent := *rp !np!rp; % collapse chain (rp not really changed) 56 | rp 57 | } 58 | }. 59 | 60 | % merge (create union of) two element sets 61 | % We allow sharing between arguments in precondition. Normally there 62 | % would be no sharing but because sharing analysis may lose precision we 63 | % want to allow the compiler to accept possible sharing here. Either 64 | % argument may be updated. 65 | % The rank is used to make the tree reasonably balanced in the worst 66 | % case - its an upper bound on the height. The root of the 67 | % smaller-ranked tree is destructively updated to be a child of the 68 | % other tree, whose rank is incremented (the rank of the smaller tree 69 | % can be garbage collected). 70 | merge :: element -> element -> void 71 | sharing merge(!ap, !bp) = v 72 | pre ap = bp 73 | post ap = bp. 74 | merge(ap, bp) = { 75 | arp = find(!ap) !bp; 76 | brp = find(!bp) !arp!ap; 77 | cases *arp of { 78 | case root(*arankp): 79 | cases *brp of { 80 | case root(*brankp): 81 | if *arankp <= *brankp then { 82 | *!arp := child(*brp) !ap!bp; 83 | *!brankp := *brankp + 1 !ap!bp 84 | } else { 85 | *!brp := child(*arp) !ap!bp; 86 | *!arankp := *arankp + 1 !ap!bp 87 | } 88 | } 89 | } 90 | }. 91 | 92 | % test if two elements are in the same set 93 | same :: element -> element -> bool 94 | sharing same(!ap, !bp) = r 95 | pre ap = bp 96 | post nosharing. 97 | same(ap, bp) = { 98 | arp = find(!ap) !bp; 99 | brp = find(!bp) !arp!ap; 100 | eq_ptr(!arp, !brp) !ap!bp 101 | }. 102 | 103 | % equality for pointers should be built in 104 | eq_ptr :: element -> element -> bool 105 | sharing eq_ptr(!p0,!p1)=r 106 | pre p0=p1 107 | post nosharing. 108 | eq_ptr(x, y) = as_C 109 | "{if (x == y) return PAWNS_true(); else return PAWNS_false();}". 110 | 111 | % :set ts=4 et 112 | -------------------------------------------------------------------------------- /examples/wam.pns: -------------------------------------------------------------------------------- 1 | % Simple WAM-style term representation/manipulation 2 | % OLD hacked C interface with wam_main.c - should merge properly 3 | % and get rid of stubs 4 | 5 | % type for terms (ignore ints and other special builtin types): 6 | % Terms are non-vars nv(fs, terms) where fs represents the function 7 | % symbol (its name and arity, perhaps represented by a pointer 8 | % into a name table) and terms is the list of the arguments, 9 | % (best specialised for different arities, and/or use an array of terms) 10 | % or variables, var(term), where term is the what the term is bound to. 11 | % Unbound variables are represented as cyclic terms: *p == var(*p) 12 | % (Andrew Taylor's scheme can use the same type, with longer cycles) 13 | % 14 | % The representation will be typically be a tagged pointer. Hopefully 15 | % the tag for vars will be zero (so they are just raw pointers) and for 16 | % non-var terms the tag will be 1). 17 | type term ---> 18 | var(term) ; 19 | % nv0(fs) ; % arity 0 function symbol 20 | % nv1(fs, term) ; % arity 1 function symbos 21 | % nv2(fs, term, term) ; % ... 22 | % nv3(fs, term, term, term) ; 23 | % ... 24 | nv(fs, terms). % general case 25 | type terms = list(term). 26 | type fs ---> f0 ; f1 ; f2. % XXX 27 | 28 | % unify two (pointers to) terms 29 | % For unify and deref it seems most convenient to use pointers 30 | % to terms rather than terms. They are essentially the same thing at 31 | % the implementation level (for unbound vars at least) but with pointers 32 | % you can directly assign (and compare with the argument of var/1), 33 | % which can't be done with plain terms. It also allows us to shorten 34 | % reference chains a bit more. For example, with Prolog X=Y, f(X)=f(Z) 35 | % we get something like nv(f,[x=var(*yp=var(*yp))] and nv(f,[*zp=var(*zp)]) 36 | % and when we unify we want the first to become nv(f,[*zp=var(*zp)]) 37 | % rather than nv(f,[x=var(*zp=var(*zp))] ie, we want pointers to x and z 38 | % passed to the recursive call to unify rather than x and y so we can 39 | % update the argument of f/1 directly rather than use an indirection. 40 | % (Essential for the Andrew Taylor "Parma" variable representation) 41 | unify :: ref(term) -> ref(term) -> bool 42 | sharing unify(!pa,!pb)=r 43 | pre pa=pb 44 | post nosharing. 45 | unify(pa, pb) = { 46 | % *!pa := tderef(pa); % could use pa1 = tderef(pa) - using := 47 | % *!pb := tderef(pb); % here can shorten reference chains 48 | dpa = tderef(pa) !pa!pb; 49 | dpb = tderef(pb) !pa!pb!dpa; 50 | cases *dpa of { 51 | case var(*p1): 52 | *!dpa := *pb !pa!pb; 53 | true 54 | case nv(fsa, aas): 55 | cases *dpb of { 56 | case var(*p1): 57 | *!dpb := *pa !pb!pa; 58 | true 59 | case nv(fsb, bas): 60 | if fs_eq(fsa, fsb) then 61 | unify_all(!aas, !bas) !pa!pb 62 | else 63 | false 64 | } 65 | } 66 | }. 67 | 68 | % unifies elements of two lists (assumes same length) 69 | unify_all :: list(term) -> list(term) -> bool 70 | sharing unify_all(!cs,!bs)=r 71 | pre cs=bs 72 | post nosharing. 73 | unify_all(cs, bs) = { 74 | cases cs of { 75 | case nil: 76 | true 77 | case cons(*c, *cs1): 78 | cases bs of { 79 | case cons(*b, *bs1): 80 | r = unify(!c, !b) !cs!bs!bs1!cs1; 81 | if r then { 82 | dcs1 = *cs1; 83 | dbs1 = *bs1; 84 | unify_all(!dcs1, !dbs1) !cs!bs 85 | } else 86 | false 87 | } 88 | } 89 | }. 90 | 91 | % dereference a pointer to a term - returns a pointer to a nonvar term 92 | % or a var which points to itself 93 | % p0 not modified but we need store view for eq_ptr 94 | tderef :: ref(term) -> ref(term) 95 | sharing tderef(!p0)=p 96 | pre nosharing 97 | post p=p0. 98 | tderef(p0) = { 99 | cases *p0 of { 100 | case var(*p1): 101 | if eq_ptr(!p0, !p1) then 102 | p0 103 | else 104 | tderef(!p1) !p0 105 | case nv(fs, p2): 106 | p0 107 | } 108 | }. 109 | 110 | % returns new unbound variable 111 | % There is a bit a problem due to the cyclic structure. We create a 112 | % non-cyclic (bound) var then smash it. Or support binding pointers to 113 | % args of data constructors (and allow cycles there). Or just use C. 114 | % Currently uses dodgey uninitialised var (will be an error at some 115 | % stage). Another option is to add a constant to the type to init the var 116 | % (not as bad as creating a function symbol but there is an extra test 117 | % whenever we switch on the type). 118 | newvar :: void -> term 119 | sharing newvar(v)=t 120 | pre nosharing 121 | post nosharing. 122 | % newvar(v) = { 123 | % % *p = var(*p1=nv(dummyval, nil)); % want to support this syntax 124 | % % *p = var(*p1= *p1); % or this + check p1 assigned? 125 | % % *!p1 := p !p; 126 | % % *p = var(*p1= *p); % or this 127 | % % return(*p) 128 | % % *p = var(nv(f1, nil)); 129 | % (dummy :: term); % uninitialised XXX 130 | % % dummy = dummy; % uninitialised var 131 | % *p = var(dummy); 132 | % cases *p of { 133 | % case var(*p1): 134 | % *!p1 := *p !p!dummy; 135 | % return(*p) 136 | % } 137 | % }. 138 | newvar(v) = as_C "{ \n\c 139 | term *argp, v = var(v); \n\c 140 | if_var_ptr(v, argp) \n\c 141 | *argp = v; \n\c 142 | end_if() \n\c 143 | }". 144 | 145 | 146 | print_term :: ref(term) -> void 147 | sharing print_term(!p0)=voidvar % no DU 148 | pre nosharing 149 | post nosharing. 150 | print_term(p0) = { 151 | dp0 = tderef(!p0); 152 | cases *dp0 of { 153 | case var(*dp1): 154 | print_var(dp0); 155 | return 156 | case nv(fs, ts): 157 | print_fs(fs); 158 | print_terms(!ts) !p0; % no DU 159 | return 160 | } 161 | }. 162 | 163 | print_terms :: list(term) -> void 164 | sharing print_terms(!ts)=voidvar % no DU 165 | pre nosharing 166 | post nosharing. 167 | print_terms(ts) = { 168 | cases ts of { 169 | case nil: 170 | return 171 | case cons(*t, *ts1): 172 | print_term(!t) !ts!ts1; 173 | print_terms(*!ts1) !ts; 174 | return 175 | } 176 | }. 177 | 178 | % stubs - we currently need to have definitions so its known these are 179 | % functions, as we also know the arity 180 | % Should add io state var here and above 181 | 182 | print_var :: ref(term) -> void 183 | sharing print_var(p0)=voidvar 184 | pre nosharing 185 | post nosharing. 186 | print_var(x) = void. 187 | 188 | print_fs :: fs -> void 189 | sharing print_fs(p0)=voidvar 190 | pre nosharing 191 | post nosharing. 192 | print_fs(x) = void. 193 | 194 | % STUB - should be builtin 195 | fs_eq :: fs -> fs -> bool 196 | sharing fs_eq(p0,p1)=r 197 | pre nosharing 198 | post nosharing. 199 | fs_eq(x, y) = true. 200 | 201 | % STUB - should be builtin 202 | % args are banged because we need low level view (they are not modified 203 | % though) 204 | eq_ptr :: ref(term) -> ref(term) -> bool 205 | sharing eq_ptr(!p0,!p1)=r 206 | pre p0=p1 207 | post nosharing. 208 | % eq_ptr(x, y) = true. 209 | eq_ptr(x, y) = as_C 210 | "{if (x == y) return PAWNS_true(); else return PAWNS_false();}". 211 | -------------------------------------------------------------------------------- /examples/wam_main.c: -------------------------------------------------------------------------------- 1 | // OLD see wam.pns - should be merged 2 | // harness for wam.pns -> wam_out.c 3 | 4 | #include 5 | #include 6 | #include "wam_adt.h" 7 | #include "wam_out.c" 8 | 9 | 10 | bool 11 | eq(fs i, fs j) { 12 | if (((intptr_t)i & 7) == ((intptr_t)j & 7)) % XXXX 13 | return true(); 14 | else 15 | return false(); 16 | } 17 | 18 | __inline bool 19 | eq_ptr(term* i, term* j) { 20 | if (i == j) 21 | return true(); 22 | else 23 | return false(); 24 | } 25 | 26 | void 27 | print_var(term *i) { 28 | printf("_%lx ", (intptr_t)i); 29 | } 30 | 31 | void 32 | print_fs(fs i) { 33 | printf("f%ld ", (intptr_t)i & 7); % XXXX 34 | } 35 | 36 | void 37 | main() { 38 | bool b; 39 | term t, t1, t2, t3, t4, t5; 40 | t = nv(f0(), nil()); 41 | t2 = newvar(); 42 | t1 = nv(f2(), cons(t, cons(t2, nil()))); 43 | print_term(&t1); 44 | printf("\n"); 45 | t4 = var(var(newvar())); 46 | t3 = nv(f2(), cons(t4, cons(t4, nil()))); 47 | print_term(&t3); 48 | printf("\n"); 49 | b = unify(&t1, &t3); 50 | // printf("true %lx\n", (intptr_t)true() & 7); 51 | // printf("false %lx\n", (intptr_t)false() & 7); 52 | // printf("b %lx\n", (intptr_t)b & 7); 53 | if(((intptr_t)b & 7) == ((intptr_t)true() & 7)) 54 | printf("succeeded\n"); 55 | else 56 | printf("failed\n"); 57 | print_term(&t3); 58 | printf("\n"); 59 | print_term(&t2); 60 | printf("\n"); 61 | } 62 | --------------------------------------------------------------------------------