Compare commits
1524
Commits
9dddcac821
...
master
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
ca20a13f99 | ||
|
|
7581439c04 | ||
|
|
656daeacda | ||
|
|
d2d4061a4b | ||
|
|
37155bba6f | ||
|
|
99e613a73c | ||
|
|
4c372cf345 | ||
|
|
92d662702b | ||
|
|
b55a3ac612 | ||
|
|
cd1a9ef387 | ||
|
|
ed6ade38b6 | ||
|
|
0bb030c40b | ||
|
|
e2389ce16f | ||
|
|
a96b748c10 | ||
|
|
4cb39c4ae3 | ||
|
|
c02710ad46 | ||
|
|
a0a2406c8c | ||
|
|
3023a3ba96 | ||
|
|
dbdb6cdea2 | ||
|
|
fafec47907 | ||
|
|
15c53f5a52 | ||
|
|
f4c8b3e6dc | ||
|
|
889b22c309 | ||
|
|
343fd1dc3d | ||
|
|
128b94ba4a | ||
|
|
7fc8007f06 | ||
|
|
f07befbc0c | ||
|
|
a05be7dbcf | ||
|
|
2cd1e380e3 | ||
|
|
9e14ca50a9 | ||
|
|
72eca05d6e | ||
|
|
19164384f7 | ||
|
|
ebdbf5587e | ||
|
|
96da2eb9f1 | ||
|
|
6d28823307 | ||
|
|
b855cc4815 | ||
|
|
662233f317 | ||
|
|
9ab1229993 | ||
|
|
c47150632e | ||
|
|
62025c7d33 | ||
|
|
fb8432a90a | ||
|
|
da6fa71ca0 | ||
|
|
4bb622c81f | ||
|
|
f866999767 | ||
|
|
6b4240a673 | ||
|
|
9b13c10d67 | ||
|
|
7489d4d87e | ||
|
|
364bc3f571 | ||
|
|
16e29a720c | ||
|
|
1aeabc94ed | ||
|
|
9cdd7a2d3f | ||
|
|
9fdc262b76 | ||
|
|
cbfbc9ce67 | ||
|
|
9d0f10727d | ||
|
|
974c4ccff5 | ||
|
|
3d7a9aee79 | ||
|
|
1ccb5e14e1 | ||
|
|
65fbc06993 | ||
|
|
e0bc389c6b | ||
|
|
8361ca3d13 | ||
|
|
cdf281f094 | ||
|
|
a8845b0d93 | ||
|
|
278a877597 | ||
|
|
0f3df9dcbf | ||
|
|
a1cf3282d0 | ||
|
|
3b58e0d0f7 | ||
|
|
b2d3c15c59 | ||
|
|
11633b8971 | ||
|
|
398af8e967 | ||
|
|
3786081160 | ||
|
|
720350d59b | ||
|
|
66a5b7be3e | ||
|
|
be93be194f | ||
|
|
856ab8afce | ||
|
|
a9dc89954b | ||
|
|
65027341f9 | ||
|
|
ac848db7ab | ||
|
|
937e65f340 | ||
|
|
97b81938bc | ||
|
|
750c1eed3d | ||
|
|
6fa476089d | ||
|
|
cd0623bb59 | ||
|
|
6730f88cee | ||
|
|
69a151bd33 | ||
|
|
e30c5bf0ee | ||
|
|
f4570cb7c9 | ||
|
|
c3ed92ff40 | ||
|
|
3b5a1dfa85 | ||
|
|
8f63e2b3f0 | ||
|
|
a7b5d09c95 | ||
|
|
eb02bf01c4 | ||
|
|
e2aeb9b9de | ||
|
|
3599b741ca | ||
|
|
6ed8b454f8 | ||
|
|
56c514a980 | ||
|
|
65d37aca7e | ||
|
|
e60844ea0d | ||
|
|
6ca11f142d | ||
|
|
b177649815 | ||
|
|
93af417732 | ||
|
|
1b9b95ec12 | ||
|
|
94f19a7a26 | ||
|
|
332cb3ddd9 | ||
|
|
a4cf382887 | ||
|
|
64fd9aae39 | ||
|
|
77377c1203 | ||
|
|
de93e4e190 | ||
|
|
8b9c1bf3e8 | ||
|
|
0b1feda713 | ||
|
|
a2e259510e | ||
|
|
03df3bce0e | ||
|
|
2044220688 | ||
|
|
e14450e504 | ||
|
|
2642bab5f4 | ||
|
|
a5278a3e9d | ||
|
|
c3aaa736dc | ||
|
|
6b2ab59de5 | ||
|
|
ae625214d7 | ||
|
|
bde8e744de | ||
|
|
d9209cb956 | ||
|
|
81461bb951 | ||
|
|
adcebeb076 | ||
|
|
5d2a00cad9 | ||
|
|
ff81858beb | ||
|
|
7d85390b52 | ||
|
|
70ebfa4e0e | ||
|
|
d17998e7f9 | ||
|
|
cf54e37513 | ||
|
|
e36cd70736 | ||
|
|
d235900dd2 | ||
|
|
fdbb22d4b3 | ||
|
|
f6c33e95b4 | ||
|
|
1c231c9e2f | ||
|
|
7129ecf72b | ||
|
|
a2fa4636a4 | ||
|
|
e13185064f | ||
|
|
e3586771c8 | ||
|
|
f056a6eccc | ||
|
|
2d4c5b24b7 | ||
|
|
bb77b73cb8 | ||
|
|
604d66dd74 | ||
|
|
028680ee06 | ||
|
|
c12e6c60dd | ||
|
|
e57469327f | ||
|
|
a0c7db1f3d | ||
|
|
729f213404 | ||
|
|
3feef61b41 | ||
|
|
c473d3d5a6 | ||
|
|
c2e8fb1ee2 | ||
|
|
02531f809b | ||
|
|
b7fe3bc2a6 | ||
|
|
3c41da12a8 | ||
|
|
85746bfa8e | ||
|
|
3a268ce227 | ||
|
|
6c21964582 | ||
|
|
cde0955e60 | ||
|
|
07c47ccd00 | ||
|
|
d9638a62c8 | ||
|
|
bc7aa46e21 | ||
|
|
b512fe2618 | ||
|
|
7964c15cfd | ||
|
|
787c4cf40c | ||
|
|
f224fd0e4c | ||
|
|
733a3a9862 | ||
|
|
9633c141d4 | ||
|
|
7c3110ed29 | ||
|
|
1db1a2fbf3 | ||
|
|
4b70385b57 | ||
|
|
da6a61862b | ||
|
|
069549797e | ||
|
|
013792d8a0 | ||
|
|
c2a96f00d3 | ||
|
|
798f4bfca7 | ||
|
|
c8e5dfa006 | ||
|
|
4c2dd69411 | ||
|
|
f846ca94c2 | ||
|
|
8b8b2cf151 | ||
|
|
c623fcbb6b | ||
|
|
240c079f50 | ||
|
|
8f5b3f2497 | ||
|
|
3550117ebb | ||
|
|
0da1e2b3f3 | ||
|
|
753283e949 | ||
|
|
6e227d60d1 | ||
|
|
0c53666cd1 | ||
|
|
7122fe5a7c | ||
|
|
a3e439872b | ||
|
|
bf5afd7c9a | ||
|
|
72d86c9a29 | ||
|
|
86ff0047ee | ||
|
|
735545e9cb | ||
|
|
3f6a84c45c | ||
|
|
789221a48a | ||
|
|
5172b84964 | ||
|
|
a069b88138 | ||
|
|
97614ee62f | ||
|
|
9e2fb44e78 | ||
|
|
152c13039e | ||
|
|
0a6851c42b | ||
|
|
13eabbfc8d | ||
|
|
f50485a383 | ||
|
|
f0a2c5a550 | ||
|
|
8ac3c02705 | ||
|
|
d5acd10af1 | ||
|
|
ebfe1476eb | ||
|
|
dbf7a9e1e2 | ||
|
|
9da6e558ad | ||
|
|
be55983b10 | ||
|
|
a246cddec1 | ||
|
|
0cdc7e3589 | ||
|
|
406d9e9041 | ||
|
|
3e450e2531 | ||
|
|
9e01d23f5d | ||
|
|
29bb944406 | ||
|
|
6edd1c2ee7 | ||
|
|
581bcf80fd | ||
|
|
dbb8269cb5 | ||
|
|
171a8dea35 | ||
|
|
757bbdb4d2 | ||
|
|
9ba1b0bf86 | ||
|
|
c9f1cf83c5 | ||
|
|
988c8b69f3 | ||
|
|
0a6b9c06a2 | ||
|
|
7d1bc00e1b | ||
|
|
40916ad9a9 | ||
|
|
aced491634 | ||
|
|
cd55700806 | ||
|
|
fd396dd38c | ||
|
|
33da181792 | ||
|
|
787e1cdda9 | ||
|
|
b53a121563 | ||
|
|
d226e52702 | ||
|
|
81542dfa33 | ||
|
|
2d90a2f26a | ||
|
|
c55d157b3e | ||
|
|
00a391f006 | ||
|
|
6d31c456ef | ||
|
|
66759b1b85 | ||
|
|
3a2cabeff1 | ||
|
|
bb39a3a693 | ||
|
|
69df331bb4 | ||
|
|
243a8f9435 | ||
|
|
994e4c4fa4 | ||
|
|
d8bc2e79e9 | ||
|
|
f741444d75 | ||
|
|
c599dce220 | ||
|
|
53bcfd5f49 | ||
|
|
4a64fd3bf6 | ||
|
|
dbf50385be | ||
|
|
26cf46a399 | ||
|
|
cbc69f6d9a | ||
|
|
a6b03c33b5 | ||
|
|
60000bffb2 | ||
|
|
0e7ebd2623 | ||
|
|
84a3286480 | ||
|
|
145a2e417d | ||
|
|
573367e4d1 | ||
|
|
80d682141f | ||
|
|
39538c9450 | ||
|
|
f3b1c62005 | ||
|
|
31ee4fb182 | ||
|
|
50098ed8f1 | ||
|
|
e8075ab76c | ||
|
|
c66934f629 | ||
|
|
f3b62bfad8 | ||
|
|
e8a0d10364 | ||
|
|
a04d8b3f5b | ||
|
|
3f2e590be0 | ||
|
|
bba7d55533 | ||
|
|
bd324700c2 | ||
|
|
564a549225 | ||
|
|
deca12f0cb | ||
|
|
2ad55044a6 | ||
|
|
b6196f0e1e | ||
|
|
2e8e5135b3 | ||
|
|
36f4876e03 | ||
|
|
395d5545bf | ||
|
|
c0d1be7b98 | ||
|
|
2396dc8bb5 | ||
|
|
256b6ca874 | ||
|
|
a2ca40d596 | ||
|
|
6ac258dadc | ||
|
|
c9d56b2d4a | ||
|
|
8573290e1b | ||
|
|
ac5f7c22da | ||
|
|
062085aa13 | ||
|
|
a01e12a58f | ||
|
|
bfa920ac52 | ||
|
|
2082774c96 | ||
|
|
035531f136 | ||
|
|
1acc8e9999 | ||
|
|
bcd11d3848 | ||
|
|
7aa9c705db | ||
|
|
d67b5b9f47 | ||
|
|
9f15469e13 | ||
|
|
ff2570809e | ||
|
|
fb37e3bbe3 | ||
|
|
1d07f6c449 | ||
|
|
9188a60f3e | ||
|
|
3e5248b0f9 | ||
|
|
366def24e6 | ||
|
|
ec988b5f6c | ||
|
|
b1626b3281 | ||
|
|
bb0a604654 | ||
|
|
a467376bc8 | ||
|
|
0cf7f6f2c2 | ||
|
|
fc6129bff2 | ||
|
|
11e182bdf9 | ||
|
|
c3273bb82a | ||
|
|
26c5149845 | ||
|
|
2258f61adc | ||
|
|
17a6e0be2b | ||
|
|
2cd735fbdd | ||
|
|
181a2c38ef | ||
|
|
56fb094280 | ||
|
|
82c1e7b8c6 | ||
|
|
ed40a1d338 | ||
|
|
851f8e638d | ||
|
|
ce17f51bd3 | ||
|
|
0c0fbaf793 | ||
|
|
99546948a0 | ||
|
|
a5811a9325 | ||
|
|
ba8a6ce838 | ||
|
|
6fd669c396 | ||
|
|
ec7fabfd45 | ||
|
|
44c8f81e61 | ||
|
|
d3aa1e7b08 | ||
|
|
991c6bcc47 | ||
|
|
1c31fcdc19 | ||
|
|
5dfc3cd1af | ||
|
|
681efbdc6a | ||
|
|
3a8f9e5f4f | ||
|
|
8be506fce8 | ||
|
|
135462027e | ||
|
|
b7fcccc663 | ||
|
|
603a37b5da | ||
|
|
5cd83d2595 | ||
|
|
525e3d32a0 | ||
|
|
036149db37 | ||
|
|
6af0485084 | ||
|
|
ddfc062530 | ||
|
|
1bd2360e77 | ||
|
|
6e85682cf8 | ||
|
|
40cbb42bc6 | ||
|
|
1bef6677e1 | ||
|
|
82df0fa262 | ||
|
|
c623b93949 | ||
|
|
5089663e40 | ||
|
|
bb9a9db699 | ||
|
|
a082d4c1fc | ||
|
|
1d8bfd9089 | ||
|
|
ec2b836060 | ||
|
|
d5181eead1 | ||
|
|
fd63b56a96 | ||
|
|
9beff10914 | ||
|
|
128cb8c172 | ||
|
|
6c2f7c34c7 | ||
|
|
82cbc8e63a | ||
|
|
49f8035c55 | ||
|
|
024ec3b128 | ||
|
|
fae322955e | ||
|
|
487c981799 | ||
|
|
e5a9a5a99b | ||
|
|
69ea773ce4 | ||
|
|
bbaca242e5 | ||
|
|
08ecba92f6 | ||
|
|
b84412d997 | ||
|
|
c82a3b79d6 | ||
|
|
5274f83f88 | ||
|
|
ae41ec8454 | ||
|
|
1215db7d26 | ||
|
|
c3f1adb0c3 | ||
|
|
2010655d60 | ||
|
|
5a8e7fa87b | ||
|
|
8d198f88c9 | ||
|
|
cfdc6e29fd | ||
|
|
d6c33928f5 | ||
|
|
c1018d87c5 | ||
|
|
7d2da19c0c | ||
|
|
fd6510e0b5 | ||
|
|
8333ba017d | ||
|
|
b814aca187 | ||
|
|
83bb65957d | ||
|
|
09ffc27883 | ||
|
|
e4d0e9c60e | ||
|
|
44812855c7 | ||
|
|
b8e68a48f7 | ||
|
|
d14cffa23a | ||
|
|
c4547adb25 | ||
|
|
488a6a3295 | ||
|
|
dd719766ee | ||
|
|
c60cc33b95 | ||
|
|
e85ca2c431 | ||
|
|
3afb7e13af | ||
|
|
8f46a43e7a | ||
|
|
89d54a47f4 | ||
|
|
70be2a57e6 | ||
|
|
f25f69c0be | ||
|
|
4d85cefbe2 | ||
|
|
3f59c18257 | ||
|
|
2af5dee0d0 | ||
|
|
09f1e4369f | ||
|
|
87709618f9 | ||
|
|
21c2e78808 | ||
|
|
0c7a53f526 | ||
|
|
cb60df1dc0 | ||
|
|
29494c7978 | ||
|
|
179156b105 | ||
|
|
e219e90446 | ||
|
|
0598949fcb | ||
|
|
5d5018011e | ||
|
|
c1916ed819 | ||
|
|
5a3d480edf | ||
|
|
f484f16190 | ||
|
|
7dcef05df3 | ||
|
|
1763157ef2 | ||
|
|
edd2955383 | ||
|
|
d8a70fea04 | ||
|
|
66fce31dbd | ||
|
|
b49c6ad9cd | ||
|
|
15ff547e52 | ||
|
|
3a2f3327f6 | ||
|
|
f4d79b0147 | ||
|
|
181f7da037 | ||
|
|
97e89c8d40 | ||
|
|
ac752d1405 | ||
|
|
bd08d6524c | ||
|
|
adfab2d482 | ||
|
|
d138155eae | ||
|
|
2243b55259 | ||
|
|
8afa054349 | ||
|
|
d252eee2b2 | ||
|
|
6c6b5a60cb | ||
|
|
e3f431ea79 | ||
|
|
85482956ea | ||
|
|
570d2d88fb | ||
|
|
7361830938 | ||
|
|
33203bd3c5 | ||
|
|
c9f33feb6c | ||
|
|
37c4f2ee10 | ||
|
|
178c129c97 | ||
|
|
ce19ee615c | ||
|
|
7db1a81d1f | ||
|
|
2ace3bfe2b | ||
|
|
3cc8ca9cbb | ||
|
|
ed5b56f212 | ||
|
|
398bd7b851 | ||
|
|
3134246511 | ||
|
|
92fbeb4fc9 | ||
|
|
ce0068c0f7 | ||
|
|
322a675f1b | ||
|
|
fd8620516c | ||
|
|
e122782577 | ||
|
|
38078cada3 | ||
|
|
717f07f985 | ||
|
|
5038c5954a | ||
|
|
b545584de8 | ||
|
|
6170f50061 | ||
|
|
aa6a007c7e | ||
|
|
2752d57655 | ||
|
|
9f4a50538e | ||
|
|
c24b19e7b1 | ||
|
|
1b588df6b5 | ||
|
|
79430aca77 | ||
|
|
764c2d10af | ||
|
|
1243504ac6 | ||
|
|
d980251632 | ||
|
|
4a7df449aa | ||
|
|
e5fd44920e | ||
|
|
5d41a2d424 | ||
|
|
a3899f3ecb | ||
|
|
f35a2b240a | ||
|
|
473a9528b9 | ||
|
|
28d4c0f8dc | ||
|
|
d415d5da15 | ||
|
|
56b254d81c | ||
|
|
659f4d8c6c | ||
|
|
ef87bdb3b3 | ||
|
|
10a2a2b376 | ||
|
|
9c47d3bacc | ||
|
|
0b56818569 | ||
|
|
36655025c0 | ||
|
|
83fa52a9c3 | ||
|
|
bfdd971baa | ||
|
|
b1cba196b9 | ||
|
|
8d08e82b7c | ||
|
|
f7781dbb78 | ||
|
|
d5437c3f22 | ||
|
|
62fd7b19bc | ||
|
|
5ee433a38f | ||
|
|
349e2d7e72 | ||
|
|
78e25dfa48 | ||
|
|
5cc661d6ab | ||
|
|
db67ab19b4 | ||
|
|
66ea0b3abe | ||
|
|
4fb9d3b3fe | ||
|
|
d742be75bd | ||
|
|
8a698076eb | ||
|
|
0ed3ce93e2 | ||
|
|
24b346d927 | ||
|
|
ca9e28860a | ||
|
|
6d8ced2ba3 | ||
|
|
bcdb6250a9 | ||
|
|
e24395a737 | ||
|
|
68fddf90a1 | ||
|
|
dad9c02dc6 | ||
|
|
c7fb0e5422 | ||
|
|
1d09f2fd3d | ||
|
|
71f2b0b9b6 | ||
|
|
17ff7cb348 | ||
|
|
3d5caf25ae | ||
|
|
5712d4bdc0 | ||
|
|
c4452fc500 | ||
|
|
75fe42d310 | ||
|
|
a546bde112 | ||
|
|
4188c47b76 | ||
|
|
7123d4d3f0 | ||
|
|
473bf0a2b7 | ||
|
|
23663c4773 | ||
|
|
17a7afb297 | ||
|
|
9644b8a616 | ||
|
|
63dc853121 | ||
|
|
b5380b4750 | ||
|
|
fc463cf320 | ||
|
|
0a05d83b3b | ||
|
|
207f5d7bad | ||
|
|
ee6fa5297a | ||
|
|
0e9d647aca | ||
|
|
497c9f470f | ||
|
|
5f1b9b9e7e | ||
|
|
163c224d0d | ||
|
|
7991e00e76 | ||
|
|
697c016231 | ||
|
|
d519ca81dd | ||
|
|
36156c9de9 | ||
|
|
25e7db944f | ||
|
|
12cd4feff0 | ||
|
|
0a1f5a3483 | ||
|
|
749b4aeb84 | ||
|
|
5177586848 | ||
|
|
f39612bc7c | ||
|
|
04b29f283d | ||
|
|
f91ed8ad27 | ||
|
|
e79d9c0d07 | ||
|
|
6e006fce27 | ||
|
|
26fc9d82a6 | ||
|
|
d5d9dc1538 | ||
|
|
8291e62d7a | ||
|
|
06eaf738b9 | ||
|
|
7953376e4e | ||
|
|
b1404727b6 | ||
|
|
2dbc8539e5 | ||
|
|
4eefd25df9 | ||
|
|
65be0bf774 | ||
|
|
d8fd89e31c | ||
|
|
e0652f2970 | ||
|
|
1330f2cbc6 | ||
|
|
444d2384ce | ||
|
|
1022b7c7f9 | ||
|
|
5a4ed94b65 | ||
|
|
6f6e01db06 | ||
|
|
605eb97e75 | ||
|
|
8e8015cb2d | ||
|
|
7c197e3bb0 | ||
|
|
895828992e | ||
|
|
a8f98c86f1 | ||
|
|
f9dadce5d0 | ||
|
|
702ebdc9c5 | ||
|
|
cde4f2ab1b | ||
|
|
905a4c53be | ||
|
|
de0c8791f3 | ||
|
|
3f4e5a930f | ||
|
|
72c73117d6 | ||
|
|
1a97dfff77 | ||
|
|
aefd2b7887 | ||
|
|
49e6ac6512 | ||
|
|
34ef99d1f2 | ||
|
|
69e5e7fe4a | ||
|
|
6e56fce7fa | ||
|
|
7e5ea096a5 | ||
|
|
b92e91bcaa | ||
|
|
3520e2d73e | ||
|
|
267db2cd91 | ||
|
|
8d24b024a2 | ||
|
|
3c962197f4 | ||
|
|
ada798f875 | ||
|
|
7d898beb91 | ||
|
|
78e0091e3e | ||
|
|
1ef3022599 | ||
|
|
15fc197f9d | ||
|
|
ba3ad6b1bc | ||
|
|
02fcb1725e | ||
|
|
3d97c73c32 | ||
|
|
6c32383539 | ||
|
|
fff1c0b9c3 | ||
|
|
9befc558a0 | ||
|
|
40eb57a5b6 | ||
|
|
fd1a7f2b36 | ||
|
|
dbddc61b30 | ||
|
|
dca29a5605 | ||
|
|
263214e639 | ||
|
|
7e48f1eaf5 | ||
|
|
2135f6d37f | ||
|
|
8fe8062a0c | ||
|
|
3e504deb6f | ||
|
|
c1beb602a7 | ||
|
|
0e26af2107 | ||
|
|
93e614e239 | ||
|
|
bdda16a461 | ||
|
|
69ac194ba7 | ||
|
|
6583392504 | ||
|
|
e18b28be3e | ||
|
|
319a3c78c4 | ||
|
|
eb08f1300d | ||
|
|
55ab1a98ae | ||
|
|
a14e633a21 | ||
|
|
a39d96149d | ||
|
|
ccdadeeb6e | ||
|
|
70b9040512 | ||
|
|
d07c7b4e2c | ||
|
|
41273c9d22 | ||
|
|
35aa5a8c0f | ||
|
|
24761dcf54 | ||
|
|
c41d27ec45 | ||
|
|
4b1e722854 | ||
|
|
285bb1047f | ||
|
|
0b80c1956f | ||
|
|
e0f71bba9c | ||
|
|
c1b21edaf4 | ||
|
|
e80411d283 | ||
|
|
47cc213b42 | ||
|
|
ff0679cbb1 | ||
|
|
a1e5e39dba | ||
|
|
2b35085358 | ||
|
|
d16fe79b79 | ||
|
|
8aaf33589e | ||
|
|
5adabd9f3c | ||
|
|
85283c2e87 | ||
|
|
c3d36b5108 | ||
|
|
4f060bb648 | ||
|
|
cf8fea9b3c | ||
|
|
c9b556a539 | ||
|
|
af6e00bc2a | ||
|
|
1cfe97548a | ||
|
|
cecbec6c71 | ||
|
|
cc45b8a55d | ||
|
|
2dec18b87f | ||
|
|
d8ece682d3 | ||
|
|
e81191d770 | ||
|
|
bb800903d8 | ||
|
|
7bc04cc434 | ||
|
|
c3a05d7447 | ||
|
|
18581a452c | ||
|
|
94134da25a | ||
|
|
d991e1986c | ||
|
|
d77d541360 | ||
|
|
ed7258c80f | ||
|
|
d574031609 | ||
|
|
d4f24adbc8 | ||
|
|
ab5fe36a48 | ||
|
|
bd70dfa913 | ||
|
|
4fa11f6360 | ||
|
|
0fc258c434 | ||
|
|
3001aadff3 | ||
|
|
5c044a7b40 | ||
|
|
f76d0d6e9f | ||
|
|
095701b29b | ||
|
|
fcd32c21c5 | ||
|
|
76b2ab3113 | ||
|
|
9e09375d7b | ||
|
|
4d3688a519 | ||
|
|
69eb11ce9b | ||
|
|
111ee66a4b | ||
|
|
a6ccce0e67 | ||
|
|
c6a3259a62 | ||
|
|
df7078d586 | ||
|
|
f1bdcc8840 | ||
|
|
36c2d14c28 | ||
|
|
db7f703c0e | ||
|
|
25911d7c9d | ||
|
|
e7d82cb640 | ||
|
|
c3ba4c9e08 | ||
|
|
72c35ff05c | ||
|
|
8fdf8513fd | ||
|
|
267e84bada | ||
|
|
5d3a0fc316 | ||
|
|
241ea67fbb | ||
|
|
f6384fdf38 | ||
|
|
df00848910 | ||
|
|
ad40123b25 | ||
|
|
ff8b61e44c | ||
|
|
ae23787c04 | ||
|
|
8c814b39c1 | ||
|
|
89e4f53895 | ||
|
|
d6e6a5dc0c | ||
|
|
ff88b9dad6 | ||
|
|
20684c2d9f | ||
|
|
dbdaf66e29 | ||
|
|
7bcf9e5054 | ||
|
|
4c336687ef | ||
|
|
2f321fd061 | ||
|
|
1e8086b4d3 | ||
|
|
7c1cbd3a9f | ||
|
|
9d0d42e467 | ||
|
|
fc6e2f7dfb | ||
|
|
2c8bd61a20 | ||
|
|
37938db7c2 | ||
|
|
43c7494d54 | ||
|
|
d5978aeab8 | ||
|
|
96dbcb1f2f | ||
|
|
00fd022330 | ||
|
|
a95b4c288e | ||
|
|
83dc716133 | ||
|
|
730730a1a7 | ||
|
|
020392b064 | ||
|
|
7b3e7f0efa | ||
|
|
f32f88413e | ||
|
|
b51b7d0a53 | ||
|
|
0f9160f3bc | ||
|
|
30373ffda5 | ||
|
|
8eac6734f0 | ||
|
|
ea67e058bf | ||
|
|
78261fccda | ||
|
|
729d1a27ed | ||
|
|
8fe2a666a1 | ||
|
|
4054c4921b | ||
|
|
6c8f503ebf | ||
|
|
69d17a9d59 | ||
|
|
527da37633 | ||
|
|
4b64dc5f65 | ||
|
|
25e303caf4 | ||
|
|
a13c2f9ec3 | ||
|
|
8200120bf3 | ||
|
|
9a91440486 | ||
|
|
d46067962d | ||
|
|
d0fc036bba | ||
|
|
a615e4ecfc | ||
|
|
e616a29ceb | ||
|
|
17f0358e92 | ||
|
|
1716b146cd | ||
|
|
f67498c789 | ||
|
|
da9f21ddcd | ||
|
|
6e29c19097 | ||
|
|
23af8a4dd3 | ||
|
|
074b2da6f3 | ||
|
|
0f0fbc68ef | ||
|
|
f6ba1e6c4d | ||
|
|
8cc63ed9f6 | ||
|
|
b8c81d94ee | ||
|
|
c30f52c5a7 | ||
|
|
58d1e35225 | ||
|
|
5b8c4a68fa | ||
|
|
580d377847 | ||
|
|
82b02b6584 | ||
|
|
a41e43cbba | ||
|
|
d5fc3aa657 | ||
|
|
6745aa7cb4 | ||
|
|
52c154e306 | ||
|
|
b0323606fc | ||
|
|
8dc90416d4 | ||
|
|
680b8e7e59 | ||
|
|
d7016f91c7 | ||
|
|
e2aa0196cf | ||
|
|
1bada92870 | ||
|
|
610e9fcf9d | ||
|
|
d6621827b3 | ||
|
|
409c5f5c0d | ||
|
|
bb4705b7e0 | ||
|
|
b6dbc08c78 | ||
|
|
22d2a4cfb2 | ||
|
|
5646ae148e | ||
|
|
f04cd18c0a | ||
|
|
38055b8fdc | ||
|
|
9373c43113 | ||
|
|
46a89aac0c | ||
|
|
8bb2885e63 | ||
|
|
a0a86d0b80 | ||
|
|
a4e45d9a78 | ||
|
|
e6ea657263 | ||
|
|
b2eb81f7bf | ||
|
|
5a78cdd202 | ||
|
|
d2f25a6e44 | ||
|
|
f3d969618d | ||
|
|
c6ad71dc5b | ||
|
|
8eca8c78f2 | ||
|
|
5066b8d288 | ||
|
|
53880eb685 | ||
|
|
639ff1859c | ||
|
|
3e09a1f722 | ||
|
|
9d6694fd92 | ||
|
|
bbfb8ca58c | ||
|
|
9aeee9d676 | ||
|
|
d864818956 | ||
|
|
0358f6637c | ||
|
|
1998f57ca8 | ||
|
|
4742d7e7ef | ||
|
|
1e5be63a1a | ||
|
|
02e4fef830 | ||
|
|
f87d596bdc | ||
|
|
9394a26449 | ||
|
|
325c3662a8 | ||
|
|
e7b01ea01c | ||
|
|
9ba99d7d5b | ||
|
|
042c969e30 | ||
|
|
16427f8d07 | ||
|
|
59a0fc80de | ||
|
|
b74002be02 | ||
|
|
e75a66e463 | ||
|
|
2e586ef45f | ||
|
|
bfd176cce9 | ||
|
|
cc95006024 | ||
|
|
35f455acb3 | ||
|
|
1fb4b37125 | ||
|
|
37e577d5e1 | ||
|
|
11e1ff10a7 | ||
|
|
acec25f8a1 | ||
|
|
ce66bb7f3b | ||
|
|
d8945ae4ae | ||
|
|
d3ac1ab4dc | ||
|
|
aedd50c646 | ||
|
|
1d219b526c | ||
|
|
23b144178a | ||
|
|
c6cb018b9f | ||
|
|
c0b4b22357 | ||
|
|
93ff39c01d | ||
|
|
bf0a939093 | ||
|
|
c116237621 | ||
|
|
73dfaacbc8 | ||
|
|
caf39c4346 | ||
|
|
6e8cc52bc7 | ||
|
|
5e9be2150f | ||
|
|
77497cfc2c | ||
|
|
5c0698d749 | ||
|
|
9bb1bde665 | ||
|
|
f629123561 | ||
|
|
e0af3c9b1d | ||
|
|
b181003695 | ||
|
|
6c8611cece | ||
|
|
2ea47f91eb | ||
|
|
3892f1ed34 | ||
|
|
d6217830ff | ||
|
|
7cf57eb8ba | ||
|
|
c671bba490 | ||
|
|
0636eb3b8d | ||
|
|
c9eb425ed1 | ||
|
|
2ff1da88da | ||
|
|
a2eeb65f50 | ||
|
|
20fa04d9df | ||
|
|
d2867a4267 | ||
|
|
b05a97b029 | ||
|
|
cb83014715 | ||
|
|
2682214499 | ||
|
|
3cb6cebdbe | ||
|
|
c6f0dd5450 | ||
|
|
c671f23b2c | ||
|
|
680c12e686 | ||
|
|
de8e00314b | ||
|
|
315125c677 | ||
|
|
5062052425 | ||
|
|
14bac84f53 | ||
|
|
05d86b243f | ||
|
|
9e26275f9b | ||
|
|
0b9ae9318e | ||
|
|
97a2795cb2 | ||
|
|
de26d6e625 | ||
|
|
b818e38cff | ||
|
|
7b22f0ed98 | ||
|
|
494c57d764 | ||
|
|
840b3b215e | ||
|
|
14da41e1d9 | ||
|
|
f4725788c5 | ||
|
|
ed8dbbcd62 | ||
|
|
389e93ff09 | ||
|
|
d03b02b347 | ||
|
|
8b4c6f81df | ||
|
|
56fdfabc84 | ||
|
|
40bd96ec65 | ||
|
|
0d771494a6 | ||
|
|
892989fe85 | ||
|
|
8bebff61eb | ||
|
|
cbfac9f474 | ||
|
|
573076994e | ||
|
|
e158cd3a66 | ||
|
|
3f30b82bcb | ||
|
|
2f3544e7f5 | ||
|
|
0a6ea7c32b | ||
|
|
fe20f68ada | ||
|
|
08545c757f | ||
|
|
cc39ff2a01 | ||
|
|
a49ed2243a | ||
|
|
0beafedd14 | ||
|
|
0863b62711 | ||
|
|
146be41bd4 | ||
|
|
12c3d07acf | ||
|
|
22401a6521 | ||
|
|
85a1368826 | ||
|
|
39d35f51db | ||
|
|
60ef7b2e06 | ||
|
|
222dc0ae90 | ||
|
|
066fb18940 | ||
|
|
e9e151e1a4 | ||
|
|
aca3edff41 | ||
|
|
3a2837c278 | ||
|
|
83b244475a | ||
|
|
7abe760288 | ||
|
|
5214343251 | ||
|
|
d1fd323043 | ||
|
|
6c9635cd53 | ||
|
|
5581bafacb | ||
|
|
fc9f3059f9 | ||
|
|
e16b5cbced | ||
|
|
0e7a9ab98f | ||
|
|
cf04bfc8fd | ||
|
|
ca031d6b38 | ||
|
|
dd160aa31b | ||
|
|
e85b2d3e98 | ||
|
|
4d10f3c327 | ||
|
|
ea19dedb90 | ||
|
|
49a7860cc4 | ||
|
|
2b42cecded | ||
|
|
e511174d3c | ||
|
|
3636f31cba | ||
|
|
ddf7ca4974 | ||
|
|
c1dcdeb5af | ||
|
|
f0fc66940f | ||
|
|
9dd7dd4137 | ||
|
|
0167fcef43 | ||
|
|
d006a8b480 | ||
|
|
dab556ab7f | ||
|
|
1e462e06f6 | ||
|
|
764c5d4561 | ||
|
|
c2f26a9909 | ||
|
|
96b7ffb654 | ||
|
|
9cc820cb52 | ||
|
|
96be1193c0 | ||
|
|
4a292b5a73 | ||
|
|
763c835496 | ||
|
|
cf737076e9 | ||
|
|
aa1bbe550c | ||
|
|
b153f325b8 | ||
|
|
0fb30ad945 | ||
|
|
299b3bcb61 | ||
|
|
8006f8728f | ||
|
|
4ae7beb6ce | ||
|
|
bf827dc55b | ||
|
|
16d04cbb49 | ||
|
|
f7deba7a3e | ||
|
|
9650f331d6 | ||
|
|
81569b60d8 | ||
|
|
f6cdb4e31b | ||
|
|
ddff84ffed | ||
|
|
497881a333 | ||
|
|
51ce9a2ba6 | ||
|
|
1cec47b5d4 | ||
|
|
7a1d9c1263 | ||
|
|
931000fcb5 | ||
|
|
af4da764b2 | ||
|
|
836185a174 | ||
|
|
6a1182df5d | ||
|
|
ff89f25e48 | ||
|
|
92d63e3b36 | ||
|
|
795ba945d9 | ||
|
|
0d629d791f | ||
|
|
11dc230974 | ||
|
|
793b0eea9e | ||
|
|
96314accd0 | ||
|
|
00f116ea29 | ||
|
|
376e990689 | ||
|
|
6f0f4957f4 | ||
|
|
ff744120fc | ||
|
|
0653f341d0 | ||
|
|
63f1a1357f | ||
|
|
cb0be62087 | ||
|
|
6fd456c0a2 | ||
|
|
f986c0728a | ||
|
|
414e1e5ae6 | ||
|
|
88584f76bc | ||
|
|
f83e803ef8 | ||
|
|
918edfb0b5 | ||
|
|
cf71caefc2 | ||
|
|
cbd910c117 | ||
|
|
52681ec58c | ||
|
|
cda939c8be | ||
|
|
7d75cc0a5d | ||
|
|
54ec52fde6 | ||
|
|
377ada8d27 | ||
|
|
5477c75909 | ||
|
|
37ccca56a3 | ||
|
|
85b9f35a66 | ||
|
|
04f5d5a349 | ||
|
|
2250548b07 | ||
|
|
991e4423aa | ||
|
|
7b843f6753 | ||
|
|
f142cfaadf | ||
|
|
aa5052e401 | ||
|
|
aa629da2e5 | ||
|
|
cf028e23ea | ||
|
|
b4e19bebf8 | ||
|
|
8b354d4bc8 | ||
|
|
9194f918fc | ||
|
|
2e58880160 | ||
|
|
3a3674efb7 | ||
|
|
9c0e659209 | ||
|
|
6b9d1fa644 | ||
|
|
5557594f31 | ||
|
|
9d7da2ba7a | ||
|
|
45cc4d20e8 | ||
|
|
57fe91f303 | ||
|
|
91ba4a0743 | ||
|
|
594b4bae2e | ||
|
|
cc90aa6655 | ||
|
|
23e272a24f | ||
|
|
37d4e7b32b | ||
|
|
a14a872a44 | ||
|
|
bcfcf130f7 | ||
|
|
612411021c | ||
|
|
d9bb882bbe | ||
|
|
ca237adb22 | ||
|
|
f2c20e2a4a | ||
|
|
2d1d88e9d1 | ||
|
|
0c711942f7 | ||
|
|
2ba6a6cbf0 | ||
|
|
a28aeda633 | ||
|
|
4cb53a0a9f | ||
|
|
2572f0a537 | ||
|
|
a885c1b0f1 | ||
|
|
09b77adc38 | ||
|
|
290d322b44 | ||
|
|
54d12811f8 | ||
|
|
9ae134beaa | ||
|
|
ef2ac41172 | ||
|
|
ae46c5a878 | ||
|
|
13145cc52a | ||
|
|
3df49184a7 | ||
|
|
1440ae4119 | ||
|
|
8eaeb992d6 | ||
|
|
970d5ac38f | ||
|
|
d6fc15474b | ||
|
|
df2f23609b | ||
|
|
a29424a7b6 | ||
|
|
8f05ece441 | ||
|
|
b8856bef3a | ||
|
|
3672da28be | ||
|
|
af714598b8 | ||
|
|
7b4f99261e | ||
|
|
b98108791d | ||
|
|
6df50e9ce1 | ||
|
|
165685490e | ||
|
|
0c03550999 | ||
|
|
efcee7ea07 | ||
|
|
69c1116efc | ||
|
|
a0278378ab | ||
|
|
bb274432a7 | ||
|
|
7794f06f00 | ||
|
|
75177a5a18 | ||
|
|
9573884d97 | ||
|
|
5ad16d6815 | ||
|
|
482b869835 | ||
|
|
4ab1d872b0 | ||
|
|
c3319e6268 | ||
|
|
9ce51ba94e | ||
|
|
892366e86d | ||
|
|
f75b0ca033 | ||
|
|
10b1abbf09 | ||
|
|
da987169c8 | ||
|
|
0a0517f1d1 | ||
|
|
41334b3a8f | ||
|
|
fe6744ae41 | ||
|
|
216d1c0ab0 | ||
|
|
190fdadcb8 | ||
|
|
2d8d9cd5a8 | ||
|
|
52e9c92b0f | ||
|
|
0a8dc1d82b | ||
|
|
9cfe7e7218 | ||
|
|
1cd4e0ec2e | ||
|
|
a64bee6d96 | ||
|
|
801c70bd0d | ||
|
|
a4c6b996ff | ||
|
|
9bb01b77df | ||
|
|
787eb5095f | ||
|
|
450728c9f2 | ||
|
|
785d8f93cd | ||
|
|
700e762b27 | ||
|
|
d1443808c6 | ||
|
|
2e203f64b8 | ||
|
|
4a2c04bcc7 | ||
|
|
ac440d44b0 | ||
|
|
831cab9fb2 | ||
|
|
abe7e8cd46 | ||
|
|
7ebb97d327 | ||
|
|
3a9dbea20a | ||
|
|
1cbe8ed386 | ||
|
|
aa989931dc | ||
|
|
2b91fd2146 | ||
|
|
df89869962 | ||
|
|
5b76237af2 | ||
|
|
612696d880 | ||
|
|
49ec1651ae | ||
|
|
cdda829835 | ||
|
|
f71cc40bb5 | ||
|
|
86091541d4 | ||
|
|
c6523fd408 | ||
|
|
47b3ceb878 | ||
|
|
97f34a0558 | ||
|
|
70b999f8f4 | ||
|
|
c20a4b90dc | ||
|
|
9fae298816 | ||
|
|
e83a50b5c3 | ||
|
|
56040ec6bd | ||
|
|
b64770feb7 | ||
|
|
d5fed12d48 | ||
|
|
c372a98238 | ||
|
|
6ef0f46bea | ||
|
|
c91fd51ad6 | ||
|
|
8d49d0dddc | ||
|
|
879a439951 | ||
|
|
40d62e7643 | ||
|
|
07981cfbff | ||
|
|
38a570bc7a | ||
|
|
d737625a3f | ||
|
|
f1721e650c | ||
|
|
f8dfdaa9a0 | ||
|
|
765562f23e | ||
|
|
66f925c36f | ||
|
|
5b53043fd5 | ||
|
|
d9dd1435a6 | ||
|
|
a983a46ea5 | ||
|
|
5cfefa586b | ||
|
|
77d6e43b09 | ||
|
|
0d34831199 | ||
|
|
63fb5c629c | ||
|
|
7f92136401 | ||
|
|
e03028819c | ||
|
|
e9c0e96a9b | ||
|
|
114ea391aa | ||
|
|
8ea1ff4481 | ||
|
|
eb0d883e84 | ||
|
|
b4dbbb67ab | ||
|
|
657f640ec7 | ||
|
|
3efa261539 | ||
|
|
13b391b7bf | ||
|
|
b34a7bbf11 | ||
|
|
3b91afd47b | ||
|
|
f9ae500949 | ||
|
|
3e4267f57c | ||
|
|
d0e33331b5 | ||
|
|
0c50f34916 | ||
|
|
080d294bc9 | ||
|
|
b87ae11fa8 | ||
|
|
bbacbcb666 | ||
|
|
0a4c52d5ee | ||
|
|
0cc229dc6c | ||
|
|
f6416858bb | ||
|
|
d225aa4172 | ||
|
|
26242388b9 | ||
|
|
2afa554cce | ||
|
|
2240100ee9 | ||
|
|
5ea6884d2c | ||
|
|
3c39354833 | ||
|
|
78d9a0f051 | ||
|
|
d4def945a9 | ||
|
|
e807986622 | ||
|
|
7bd2c99353 | ||
|
|
097161fd41 | ||
|
|
9fd1eb113f | ||
|
|
92bf091361 | ||
|
|
865c7e0445 | ||
|
|
b2d1df300b | ||
|
|
eeac54a8e3 | ||
|
|
de3a3ed3c8 | ||
|
|
69646e534e | ||
|
|
1702a62308 | ||
|
|
f4fcbe7745 | ||
|
|
99f519ba6f | ||
|
|
16f90a7ef5 | ||
|
|
ce900acfe4 | ||
|
|
c1b18cb181 | ||
|
|
89481cf8ec | ||
|
|
fa2b56ba5a | ||
|
|
859e3aa7f4 | ||
|
|
ea84394dd0 | ||
|
|
6c017c2cf8 | ||
|
|
8cba440aca | ||
|
|
5afa707d76 | ||
|
|
1526b6fe3f | ||
|
|
2dfab38d06 | ||
|
|
8add0093ba | ||
|
|
db2f6c69b9 | ||
|
|
2b5d793d7a | ||
|
|
6d82221978 | ||
|
|
ac2af7c537 | ||
|
|
36624d6e33 | ||
|
|
dc39631db7 | ||
|
|
0b4bf850ec | ||
|
|
bd29eee3e4 | ||
|
|
ac7608f94b | ||
|
|
90110f525a | ||
|
|
0511cc1a01 | ||
|
|
52a1ea183a | ||
|
|
5a62770e52 | ||
|
|
c4e07256db | ||
|
|
9321547822 | ||
|
|
b2558f04de | ||
|
|
49ee8774d3 | ||
|
|
ce93ac7622 | ||
|
|
e19dd5be29 | ||
|
|
e6ac833626 | ||
|
|
6baed9a0ba | ||
|
|
34790e78af | ||
|
|
a45e3806af | ||
|
|
10610fb76b | ||
|
|
b6ea14f930 | ||
|
|
2127d4d070 | ||
|
|
b0ee9a3ce0 | ||
|
|
0e9707c9ef | ||
|
|
811c37dca4 | ||
|
|
5b39730f07 | ||
|
|
dd239d6cd5 | ||
|
|
2d29528cad | ||
|
|
6461322aa9 | ||
|
|
2daf7e9164 | ||
|
|
9eed4cbd8c | ||
|
|
1829cd43b6 | ||
|
|
f030c5f7f1 | ||
|
|
cb58288f4d | ||
|
|
26439dc22e | ||
|
|
a84026736e | ||
|
|
0b4f5e139e | ||
|
|
d7d6d72877 | ||
|
|
5b0062219e | ||
|
|
e441d62874 | ||
|
|
76270eac0d | ||
|
|
1c49b8c610 | ||
|
|
001f17b8bf | ||
|
|
7db5ec1885 | ||
|
|
da40dc2de2 | ||
|
|
9611fce108 | ||
|
|
6896128407 | ||
|
|
4f060d07db | ||
|
|
58d5ccda94 | ||
|
|
eec9efc94c | ||
|
|
931cf860c3 | ||
|
|
e6af2d3f77 | ||
|
|
c765aad70f | ||
|
|
3a9088604e | ||
|
|
bddc8fc5dd | ||
|
|
633a7b2025 | ||
|
|
3f7c42257f | ||
|
|
f61f83f796 | ||
|
|
b5f17826fe | ||
|
|
ad0f1fbd6a | ||
|
|
29a9441f12 | ||
|
|
d7070501e4 | ||
|
|
264765a6a5 | ||
|
|
221df5af1c | ||
|
|
c71ae8020c | ||
|
|
3c1fb1b31e | ||
|
|
ba7f31e99f | ||
|
|
31b0f2175f | ||
|
|
70f87d90b2 | ||
|
|
a1111f7b3c | ||
|
|
27b672a3d2 | ||
|
|
f6ab3b62fc | ||
|
|
7b3773c344 | ||
|
|
7c1a818001 | ||
|
|
4c667cf062 | ||
|
|
c3e0703642 | ||
|
|
87aeb7b0da | ||
|
|
c76a507d3b | ||
|
|
f360531918 | ||
|
|
e3565b30e8 | ||
|
|
ec1a5358b1 | ||
|
|
624b595869 | ||
|
|
a251dca67f | ||
|
|
5adc1e2b03 | ||
|
|
b77b4f3a1f | ||
|
|
9b4337f9e5 | ||
|
|
d3a9c790f0 | ||
|
|
daed039331 | ||
|
|
ab82e46119 | ||
|
|
73ab213134 | ||
|
|
92fae67fb3 | ||
|
|
5f55c177ba | ||
|
|
d722b267e6 | ||
|
|
01e60fa5b7 | ||
|
|
477ec2226e | ||
|
|
5bd533c64e | ||
|
|
6d87c02584 | ||
|
|
c2d378957e | ||
|
|
5bd25b61df | ||
|
|
18b834275c | ||
|
|
d43c372efe | ||
|
|
416ce10ee7 | ||
|
|
37f8f77380 | ||
|
|
2ec12c064d | ||
|
|
1d74a4f694 | ||
|
|
55543747d3 | ||
|
|
889fdc30d9 | ||
|
|
f885e1abfa | ||
|
|
dc34c62ce0 | ||
|
|
bd981ff87a | ||
|
|
4aa24c0e33 | ||
|
|
7c7586ebc6 | ||
|
|
76f23fc68b | ||
|
|
9f2f0b1635 | ||
|
|
de792fe141 | ||
|
|
a5a77867f9 | ||
|
|
ca192f1691 | ||
|
|
090054bee1 | ||
|
|
c8091bdbf9 | ||
|
|
1422d4faf3 | ||
|
|
7d4bec521e | ||
|
|
3e68089cde | ||
|
|
a2004ae7a6 | ||
|
|
32ff350001 | ||
|
|
4a8a78caac | ||
|
|
95d3da0712 | ||
|
|
a0f37e72a2 | ||
|
|
69c033e946 | ||
|
|
6055e9c247 | ||
|
|
2133ac6f18 | ||
|
|
a7e1208ee4 | ||
|
|
f35af50f51 | ||
|
|
617440aee6 | ||
|
|
495629f5f3 | ||
|
|
7a0b2b7803 | ||
|
|
14416a877f | ||
|
|
e054de610a | ||
|
|
8d64eda2d4 | ||
|
|
9417fdec42 | ||
|
|
d757fd23f5 | ||
|
|
88b21dd5af | ||
|
|
7f9017bb3e | ||
|
|
38a04f7a47 | ||
|
|
668f0d6686 | ||
|
|
5c228d35dc | ||
|
|
14c246c27c | ||
|
|
6960a7e929 | ||
|
|
871d23dcc4 | ||
|
|
d5c969d58b | ||
|
|
08ec402e0b | ||
|
|
3165cb73a6 | ||
|
|
d9404bb34a | ||
|
|
9b877a2835 | ||
|
|
b206e9a9a4 | ||
|
|
51df451e7b | ||
|
|
6b668e7d9d | ||
|
|
cc2cfa175b | ||
|
|
5d1ea9dede | ||
|
|
541c845688 | ||
|
|
233bb780b0 | ||
|
|
6479834ffc | ||
|
|
eb2fbb75dd | ||
|
|
da2280cceb | ||
|
|
e6d85c80dd | ||
|
|
566c010822 | ||
|
|
7187f58ff0 | ||
|
|
e104bca12b | ||
|
|
8b48744864 | ||
|
|
41a794c255 | ||
|
|
0faacb3e57 | ||
|
|
bb2471f7a1 | ||
|
|
4a563d0e67 | ||
|
|
c46fd56447 | ||
|
|
9d73900f3e | ||
|
|
c4b6bb9821 | ||
|
|
28f20eb146 | ||
|
|
a925d31151 | ||
|
|
8e5fcf54cc | ||
|
|
c22c896f83 | ||
|
|
d11dfd8a44 | ||
|
|
534907d204 | ||
|
|
739b871ff1 | ||
|
|
2b9f271cc3 | ||
|
|
d8fc41a142 | ||
|
|
2edd441ecf | ||
|
|
1d788dfda4 | ||
|
|
b23dcf73f3 | ||
|
|
95058502f5 | ||
|
|
8e5798fa1c | ||
|
|
1eea388a47 | ||
|
|
866c0792e0 | ||
|
|
885470820e | ||
|
|
5caf455e66 | ||
|
|
b93b6120d1 | ||
|
|
0c0eadb424 | ||
|
|
f186284a4d | ||
|
|
c1ccc318f7 | ||
|
|
eed0cfa950 | ||
|
|
a2449ed7c1 | ||
|
|
8c9e8a314c | ||
|
|
6197b32b50 | ||
|
|
9585d8c2fe | ||
|
|
acf38ac064 | ||
|
|
a70cfadd94 | ||
|
|
47cb46aa00 | ||
|
|
c31feb85eb | ||
|
|
d36c77ba6b | ||
|
|
cf410c5da3 | ||
|
|
ce3e879e83 | ||
|
|
1f75744b06 | ||
|
|
c0ccbe2df2 | ||
|
|
c59cc95679 | ||
|
|
9f85139f1f | ||
|
|
81b807f544 | ||
|
|
9d10e7edb0 | ||
|
|
594a42b54e | ||
|
|
0fd83dc95e | ||
|
|
aaca776afd | ||
|
|
9a32910882 | ||
|
|
263b9bb627 | ||
|
|
96e5fab77f | ||
|
|
16498a4e60 | ||
|
|
4d1af07cd0 | ||
|
|
98dce374d1 | ||
|
|
f0fd54f0f0 | ||
|
|
dfe0296479 | ||
|
|
dfb02ee26a | ||
|
|
901376ba49 | ||
|
|
c5b8af23a1 | ||
|
|
2dd13b5ae0 | ||
|
|
aeeb6de59d | ||
|
|
ccb100d74c | ||
|
|
366a8724ba | ||
|
|
668268b6cc | ||
|
|
652361e169 | ||
|
|
223e282e44 | ||
|
|
ac7ee912e7 | ||
|
|
8a430bb50c | ||
|
|
fbbd6c4984 | ||
|
|
e9d0b99096 | ||
|
|
1ad146fdbf | ||
|
|
d57eeb3265 | ||
|
|
22866d864a | ||
|
|
aa9a2e03bb | ||
|
|
6cc94e00d6 | ||
|
|
c7e31709d2 | ||
|
|
5a46ab488f | ||
|
|
3eaa3e23bd | ||
|
|
d0d94a05f6 | ||
|
|
9e80147527 | ||
|
|
dd7a4eaea7 | ||
|
|
7704463ecd | ||
|
|
0d72835842 | ||
|
|
ff2c949361 | ||
|
|
836c23295c | ||
|
|
0c523cfe8b | ||
|
|
ce3b62340b | ||
|
|
c124df36ca | ||
|
|
69f5d8a05a | ||
|
|
de3ad8c052 | ||
|
|
3771f6820b | ||
|
|
798c852934 | ||
|
|
65d14f42f0 | ||
|
|
a4dce138c0 | ||
|
|
45c5b43021 | ||
|
|
238f65db59 | ||
|
|
1615e3ed8b | ||
|
|
1961c7cc9d | ||
|
|
042ddd73d9 | ||
|
|
5a2f627842 | ||
|
|
f77216212e | ||
|
|
7f44cc3c8f | ||
|
|
e7bb643d9d | ||
|
|
d0e8bdf051 | ||
|
|
ef1c2e6fa5 | ||
|
|
fd7fa78720 | ||
|
|
391fc62cc8 | ||
|
|
ab5a381de8 | ||
|
|
f182fb4728 | ||
|
|
5b1567c49f | ||
|
|
aa82364066 | ||
|
|
c57ca6a24f | ||
|
|
a003073be7 | ||
|
|
5a67cf458a | ||
|
|
066322c47d | ||
|
|
9ad886abe5 | ||
|
|
f4593525f2 | ||
|
|
3b1d3e82b5 | ||
|
|
a9b7eb1556 | ||
|
|
0661e6042e | ||
|
|
3d668f125c | ||
|
|
7ebf7ec9c4 | ||
|
|
c355739f55 | ||
|
|
155ec0ea31 | ||
|
|
99c5d87125 | ||
|
|
7e59085916 | ||
|
|
37d94ed66f | ||
|
|
bb2a9b202b | ||
|
|
c9bb12e591 | ||
|
|
f543643d19 | ||
|
|
82ca001683 | ||
|
|
ff2bd1da12 | ||
|
|
4074eb7b7f | ||
|
|
fbafee4957 | ||
|
|
330bfa1578 | ||
|
|
0251cf4aaa | ||
|
|
64e4f6cc7e | ||
|
|
8bd5547ddc | ||
|
|
acda9edd7c | ||
|
|
1a6ea7ae69 | ||
|
|
5a4f12bacd | ||
|
|
f47f9ffe59 | ||
|
|
dcba88ffd6 | ||
|
|
0aebef62f3 | ||
|
|
d94e864dba | ||
|
|
daee402026 | ||
|
|
00163bcf34 | ||
|
|
be39f32cb6 | ||
|
|
6ac11be5b1 | ||
|
|
5b54e1b7da | ||
|
|
9735bcc2d8 | ||
|
|
cc6c046ed1 | ||
|
|
38d402e326 | ||
|
|
e62b3bfe04 | ||
|
|
82557df51b | ||
|
|
1f30d9a067 | ||
|
|
1795441140 | ||
|
|
0afa530295 | ||
|
|
fa83056708 | ||
|
|
9d5689ffa2 | ||
|
|
eb641cf8eb | ||
|
|
b47f137b05 | ||
|
|
c1c1f8ed76 |
No files matched your search
@@ -0,0 +1,149 @@
|
|||||||
|
# The thing README.md and test/dune both said did not exist.
|
||||||
|
#
|
||||||
|
# `dune build @checks` on every push, which is the whole job. Both of this
|
||||||
|
# repository's silent failures — two x86 refusals that sat for a month, a page
|
||||||
|
# of examples that stopped compiling for two days — would have been caught by
|
||||||
|
# one person typing one command, and the argument for CI here is not process:
|
||||||
|
# it is that nobody typed it. @x86 parity in particular is *not* under
|
||||||
|
# `dune test`, so the routine suite does not protect it.
|
||||||
|
#
|
||||||
|
# `dune test` stays what it is: seconds, run constantly, unchanged by this
|
||||||
|
# file. The workflow adds a caller, not an alias.
|
||||||
|
#
|
||||||
|
# ── What this does not cover, and why ────────────────────────────────────
|
||||||
|
#
|
||||||
|
# Stated plainly, because a green tick that quietly checks less than it looks
|
||||||
|
# like it does is worse than no tick.
|
||||||
|
#
|
||||||
|
# raylib. vendor/raylib/link names `-l:libraylib.so.550` by exact soname,
|
||||||
|
# which is a Fedora spelling; Ubuntu ships neither that soname nor 5.5.
|
||||||
|
# So every raylib program is skipped here, on three separate paths that
|
||||||
|
# all already existed: the acceptance cases probe with `ldconfig -p |
|
||||||
|
# grep libraylib` and print a skip line; survey.sh records a program that
|
||||||
|
# will not link as `does-not-compile`, which SURVEY_STRICT deliberately
|
||||||
|
# does not fail on; and web/examples/check.sh skips shimdemo.flan by name.
|
||||||
|
# Nothing had to be weakened to make this pass — but the graphics half of
|
||||||
|
# the corpus is unchecked here and is checked only on a machine with
|
||||||
|
# raylib installed.
|
||||||
|
#
|
||||||
|
# emscripten and the web target. test_web probes for emcc and a raylib
|
||||||
|
# archive built by vendor/raylib/build-web.sh and skips with the reason.
|
||||||
|
# Installing an emsdk per run is minutes for a target TODO.org has
|
||||||
|
# deprioritised under "The web target does not reach four things", so it
|
||||||
|
# is left out on purpose.
|
||||||
|
#
|
||||||
|
# wasm32-wasi. Needs a wasi-libc sysroot and a builtins archive that no
|
||||||
|
# Ubuntu package supplies. The acceptance case probes by building and
|
||||||
|
# running the smallest program and skips with what failed, so this is a
|
||||||
|
# gap in coverage and not a failure.
|
||||||
|
#
|
||||||
|
# lldb. The debug-information cases want lldb on PATH and say so when it is
|
||||||
|
# absent. The DWARF is still emitted and still checked for
|
||||||
|
# self-consistency; what is skipped is the half that says a person can
|
||||||
|
# actually sit in a debugger.
|
||||||
|
#
|
||||||
|
# @sanitize and @valgrind. Out of @checks by design — tens of minutes each
|
||||||
|
# — and out of here for the same reason. They are the thing to run before
|
||||||
|
# a release, by hand, not the thing to run on every push.
|
||||||
|
#
|
||||||
|
# One platform. ubuntu-latest only. macOS and Windows portability is
|
||||||
|
# recorded as real and not current (aligned_alloc, MSG_NOSIGNAL,
|
||||||
|
# stdatomic), and a matrix that goes red for known reasons teaches people
|
||||||
|
# to ignore red.
|
||||||
|
|
||||||
|
name: checks
|
||||||
|
|
||||||
|
on:
|
||||||
|
push:
|
||||||
|
pull_request:
|
||||||
|
|
||||||
|
# A superseded run is wasted minutes and a confusing status on the commit it
|
||||||
|
# no longer describes.
|
||||||
|
concurrency:
|
||||||
|
group: checks-${{ github.ref }}
|
||||||
|
cancel-in-progress: true
|
||||||
|
|
||||||
|
jobs:
|
||||||
|
checks:
|
||||||
|
runs-on: ubuntu-latest
|
||||||
|
timeout-minutes: 45
|
||||||
|
|
||||||
|
steps:
|
||||||
|
- uses: actions/checkout@v4
|
||||||
|
|
||||||
|
# clang compiles the IR and the runtime's C; llc and ld are the live
|
||||||
|
# loop, which never calls the clang driver; as is the --x86 path; emacs
|
||||||
|
# is what test_emacs and test_cider drive the client with, and they skip
|
||||||
|
# silently without it, which would be four suites' worth of coverage
|
||||||
|
# disappearing without a word.
|
||||||
|
- name: Install the toolchain
|
||||||
|
run: |
|
||||||
|
sudo apt-get update
|
||||||
|
sudo apt-get install -y --no-install-recommends \
|
||||||
|
clang llvm lld binutils emacs-nox
|
||||||
|
|
||||||
|
# llc has to come from the same LLVM release as clang. The live loop
|
||||||
|
# goes llc + ld -shared + dlopen rather than through the clang driver,
|
||||||
|
# so a mismatch breaks `C-c C-c` and every reload test while `flan
|
||||||
|
# build` keeps working perfectly — which is a confusing shape of failure
|
||||||
|
# to debug from a CI log. Ubuntu installs llc under a version suffix and
|
||||||
|
# may or may not provide the bare name, so the version is read off clang
|
||||||
|
# and FLAN_LLC is pinned to match it rather than left to PATH order.
|
||||||
|
- name: Point FLAN_LLC at the llc that matches clang
|
||||||
|
run: |
|
||||||
|
set -eu
|
||||||
|
clang --version
|
||||||
|
major=$(clang --version | sed -n 's/.*version \([0-9][0-9]*\).*/\1/p' | head -1)
|
||||||
|
if command -v "llc-$major" > /dev/null; then
|
||||||
|
llc="llc-$major"
|
||||||
|
elif command -v llc > /dev/null \
|
||||||
|
&& llc --version | grep -q "LLVM version $major"; then
|
||||||
|
llc=llc
|
||||||
|
else
|
||||||
|
echo "no llc at LLVM $major; clang is $(clang --version | head -1)" >&2
|
||||||
|
echo "what is on PATH: $(ls /usr/bin/llc* 2>/dev/null || echo none)" >&2
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
echo "FLAN_LLC=$llc" >> "$GITHUB_ENV"
|
||||||
|
"$llc" --version | head -3
|
||||||
|
|
||||||
|
- uses: ocaml/setup-ocaml@v3
|
||||||
|
with:
|
||||||
|
ocaml-compiler: "5.2"
|
||||||
|
# There is no (package ...) stanza yet — the install story is Tier 2
|
||||||
|
# of docs/REVIEW-production-readiness.md and undecided — so there is
|
||||||
|
# nothing to pin and nothing to resolve dependencies from. The
|
||||||
|
# library depends on unix and on nothing else.
|
||||||
|
opam-pin: false
|
||||||
|
dune-cache: true
|
||||||
|
|
||||||
|
- run: opam install -y dune
|
||||||
|
|
||||||
|
- name: Build
|
||||||
|
run: opam exec -- dune build
|
||||||
|
|
||||||
|
# --force because the point of a CI run is to run the tests, not to
|
||||||
|
# discover that dune's cache already knew the answer.
|
||||||
|
#
|
||||||
|
# The log is kept and then read, because a suite that passes while
|
||||||
|
# leaving an unhandled exception on stderr is a suite telling you
|
||||||
|
# something and being ignored. That happened here — three suites left a
|
||||||
|
# message-less `Fatal error: exception Flan.Loc.Error(_)` while
|
||||||
|
# reporting zero failures — and it was found by a person reading a log,
|
||||||
|
# which is exactly the kind of finding that should not need a person.
|
||||||
|
- name: The suite
|
||||||
|
run: |
|
||||||
|
set -eu
|
||||||
|
set -o pipefail
|
||||||
|
opam exec -- dune test --force 2>&1 | tee suite.log
|
||||||
|
if grep -n 'Fatal error' suite.log; then
|
||||||
|
echo "the suite passed but left an unhandled exception above" >&2
|
||||||
|
exit 1
|
||||||
|
fi
|
||||||
|
|
||||||
|
# The part `dune test` does not cover: the reference page's examples
|
||||||
|
# still print what the page says, the hand-written x86 backend still
|
||||||
|
# agrees with LLVM over the whole corpus, and a --dev build still calls
|
||||||
|
# through its indirection cells.
|
||||||
|
- name: Everything else that can fail
|
||||||
|
run: opam exec -- dune build @checks
|
||||||
+16
@@ -50,7 +50,18 @@ old-ocaml/
|
|||||||
/sand.html
|
/sand.html
|
||||||
/sand.js
|
/sand.js
|
||||||
/sand.wasm
|
/sand.wasm
|
||||||
|
|
||||||
|
# The agent harness: its settings, its transcripts and the worktrees it
|
||||||
|
# registers all live here, and none of them are this repository's business.
|
||||||
.claude/
|
.claude/
|
||||||
|
|
||||||
|
# A stale unix socket left behind by `flan dev`. The daemon writes one beside
|
||||||
|
# the program it is serving and unlinks it on a clean exit; a killed daemon
|
||||||
|
# does not, and the leftover is a socket, not a file worth keeping.
|
||||||
|
.flan-dev.sock
|
||||||
|
|
||||||
|
# Hand-run scratch: a `probe` executable and the C it was compiled from, from
|
||||||
|
# poking at codegen by hand rather than through a test.
|
||||||
probe
|
probe
|
||||||
probe.c
|
probe.c
|
||||||
|
|
||||||
@@ -68,5 +79,10 @@ test/web-files-out.txt
|
|||||||
# Python bytecode from the tools directory
|
# Python bytecode from the tools directory
|
||||||
__pycache__/
|
__pycache__/
|
||||||
*.pyc
|
*.pyc
|
||||||
|
|
||||||
|
# Two more hand-run leftovers: a shared object built beside a form experiment,
|
||||||
|
# and the history directory a spike driver writes when it is run from the
|
||||||
|
# source tree. Anchored where they appear, and nothing in the build makes
|
||||||
|
# either one.
|
||||||
/forms.so
|
/forms.so
|
||||||
_hist/
|
_hist/
|
||||||
@@ -0,0 +1,72 @@
|
|||||||
|
# Working in this repository
|
||||||
|
|
||||||
|
Standing rules for any agent here, including a lane in its own worktree.
|
||||||
|
|
||||||
|
## Never
|
||||||
|
|
||||||
|
- **Touch anything under `/home/joe/Development/fnm/`.** The author's live
|
||||||
|
working copy, with an editor session attached. This repository's `sand.fln`
|
||||||
|
is a different file and may be edited normally.
|
||||||
|
- **Execute `examples/*.fln`, `sand.fln`, or anything linking raylib.** They
|
||||||
|
open a window that strobes the author's desktop. Compile, emit, diff — never run.
|
||||||
|
- **Run `dune clean`.** It escapes a worktree and deletes the main checkout's
|
||||||
|
`_build`. Run `dune` with `--root .` from inside your own worktree.
|
||||||
|
- **Kill a `flan dev` daemon you did not start.** The author keeps one attached
|
||||||
|
to their editor.
|
||||||
|
- **Put `Co-Authored-By`, a `Claude-Session` trailer or any watermark in a commit.**
|
||||||
|
|
||||||
|
## Commits
|
||||||
|
|
||||||
|
`master` is the trunk. Lanes work in their own worktree and never merge or push;
|
||||||
|
the dispatching session merges. A commit message is one declarative sentence
|
||||||
|
saying what is now true, not what was done.
|
||||||
|
|
||||||
|
## Tests
|
||||||
|
|
||||||
|
A lane never runs the full `dune test`: it builds with `-j 2` and runs only the
|
||||||
|
programs and test executables its change touches, one at a time, and lists them in
|
||||||
|
its report. After about five lanes merge, one tester agent runs `dune test --root .`
|
||||||
|
on master and fixes what broke; grep its output for FAIL, since the exit code alone
|
||||||
|
has lied. `@checks` (`@page`, `@x86`, `@cells`), `@sanitize` and `@valgrind` are
|
||||||
|
slow and run only with the author's permission. ASan misses uninitialised stack
|
||||||
|
reads; `@valgrind` catches them.
|
||||||
|
`test_acceptance` compiles `FLAN_TEST_JOBS` programs at once, 2 by default.
|
||||||
|
|
||||||
|
Run any compiled program under a memory cap and a timeout, one at a time:
|
||||||
|
`timeout 60 systemd-run --user --scope -p MemoryMax=1G -q <cmd>`. A runaway once
|
||||||
|
pushed the author's machine 10 GB into swap.
|
||||||
|
|
||||||
|
A test executable run straight from `_build` reads stale copies of its inputs unless
|
||||||
|
their dune deps are built first: build `@test/corpus` and the test's own deps before
|
||||||
|
running it, and run test executables under `MemoryMax=4G`.
|
||||||
|
|
||||||
|
## Evidence
|
||||||
|
|
||||||
|
Read the source, do not recall it — this repository and the reference clones
|
||||||
|
listed in `docs/REFERENCES.md`. Verify a brief's facts before building on them.
|
||||||
|
|
||||||
|
## Records
|
||||||
|
|
||||||
|
Keep only what the code cannot say.
|
||||||
|
|
||||||
|
- `TODO.org` — one `**` heading per item under a subsystem: `TODO` a gap, `NEXT`
|
||||||
|
decided and queued, `WAIT` blocked (say on what), `CANCELLED` rejected with a
|
||||||
|
one-line reason so it is not re-proposed, `DONE` only when the decision is not
|
||||||
|
obvious from the code (two lines, what it rules out). On a merge conflict keep
|
||||||
|
both sides.
|
||||||
|
- The reason for non-obvious code goes in a comment beside it.
|
||||||
|
- `docs/BUILT.md` holds only reasoning that spans several files.
|
||||||
|
- No handoff files.
|
||||||
|
|
||||||
|
## Dispatching
|
||||||
|
|
||||||
|
Group TODO items that touch the same files into one lane. Lanes and reviews run
|
||||||
|
on Sonnet; use Opus only for a subtle design call or after a Sonnet attempt fails.
|
||||||
|
|
||||||
|
## Reviews
|
||||||
|
|
||||||
|
Every lane except a trivial one (a one-line fix, a rename, an added binding)
|
||||||
|
gets an independent adversarial review before it merges: build and run rather
|
||||||
|
than read, measure both sides of a claimed fix, and reproduce any number a lane
|
||||||
|
reports. The dispatching session never reviews; a review subagent covers up to
|
||||||
|
five lanes at once, preferably related ones, and reports findings per lane.
|
||||||
-1432
File diff suppressed because it is too large.
Load diff
@@ -1,4 +0,0 @@
|
|||||||
* Additional things
|
|
||||||
** Why do we have prints dedicted per type? That's terrible, what do we need to have proper (println) work for everything?
|
|
||||||
** The current std is suffering from the same problem, functions should be generic? Why is it like this?
|
|
||||||
** Why do we have =at= and =nth= if they're the same? Pick one, maybe =at=. For all STD functions make sure we don't have redundancy, even if it matches clojure or lisp
|
|
||||||
@@ -1,231 +1,311 @@
|
|||||||
<div align="center">
|
<div align="center">
|
||||||
|
|
||||||
<img src="assets/flan-logo.svg" alt="Flan" width="360">
|
<img src="assets/flan-logo.svg" alt="Flan" width="300">
|
||||||
|
|
||||||
# flan<span>.</span>
|
# Flan
|
||||||
|
|
||||||
**A statically typed Lisp for making games.**
|
**A statically typed Lisp for native games and interactive development.**
|
||||||
Clojure's brackets. C's memory. No garbage collector. A REPL into the running process.
|
|
||||||
|
|
||||||
</div>
|
</div>
|
||||||
|
|
||||||
---
|
Flan is an experimental, ahead-of-time compiled Lisp for programs that need
|
||||||
|
predictable memory use and a fast edit–run loop. It combines S-expressions,
|
||||||
|
static types, explicit allocation, and a development session that can replace a
|
||||||
|
function in a running program without resetting its state.
|
||||||
|
|
||||||
Flan is what happens when you want Odin's memory model and Common Lisp's debugger
|
It is being built around games, but the interesting part is broader: a compiled
|
||||||
at the same time and refuse to pick.
|
language where the running program remains available for inspection,
|
||||||
|
experimentation, and small changes.
|
||||||
|
|
||||||
There are no object headers, so a Flan struct **is** its C struct. There is no
|
In practical terms: you get parentheses, a debugger that would like to have a
|
||||||
collector, so nothing runs between your frames that you did not write. And the
|
conversation, and a collector that only ever touches values you asked to be
|
||||||
program you are running is not a build artifact you replace — it is a thing you
|
dynamic.
|
||||||
can edit while it is still going.
|
|
||||||
|
|
||||||
```
|
## What it has
|
||||||
Edit the code, keep the sand.
|
|
||||||
```
|
|
||||||
|
|
||||||
## The twenty-millisecond loop
|
- Native compilation through LLVM, plus an in-progress direct x86-64 backend.
|
||||||
|
- C-like data layout: structs, fixed arrays, pointers, slices, and explicit
|
||||||
|
allocation.
|
||||||
|
- `Vec` and `Map` containers that take the allocator they are to use, plus
|
||||||
|
slices as the non-owning view of them.
|
||||||
|
- Generics, algebraic unions, enums, macros, packages, `defer`, and a C FFI.
|
||||||
|
- Conditions and restarts for recoverable failures and interactive debugging.
|
||||||
|
- A raylib package and a collection of ported raylib examples.
|
||||||
|
- Native, WASI, and web build targets. The cross targets are useful but less
|
||||||
|
complete than the native development workflow.
|
||||||
|
|
||||||
Run `flan dev sand.flan`. A window opens, sand falls, and a socket appears next to
|
There is also a `dyn` type: one machine word whose contents the runtime knows
|
||||||
your source file. Open Emacs, hit `C-c C-z`, and you are attached to the live process.
|
and the type checker does not. Writing `dyn` is how a value opts in to being
|
||||||
|
dynamic, and those values — and only those — live on a collected heap. A
|
||||||
|
program that writes it nowhere pays nothing for it, and `--no-gc` is how to
|
||||||
|
have that checked: it names every `dyn` in the program and refuses to build.
|
||||||
|
|
||||||
Now put your cursor in a function and press `C-c C-c`.
|
The project is exploratory software, not a stable language release. Some
|
||||||
|
features are deliberately refused while their semantics are still undecided;
|
||||||
|
the compiler aims to say why rather than quietly accepting a partial version.
|
||||||
|
It has opinions, but at least they arrive as error messages.
|
||||||
|
|
||||||
That function is recompiled and installed into the running program at its next frame
|
## Quick start
|
||||||
boundary. The whole round trip is about **19 milliseconds**, of which the actual
|
|
||||||
hot-swap — `dlopen` plus `dlsym` — is **0.04 ms**. The rest is the compiler doing
|
|
||||||
its job. It reads your *buffer*, not your saved file, so there is no ceremony.
|
|
||||||
|
|
||||||
The window does not blink. The grid does not reset. Your sand keeps falling.
|
Building requires a current OCaml/Dune toolchain, LLVM/Clang, and the native C
|
||||||
|
toolchain. Raylib is only needed for programs that use the bundled graphics
|
||||||
| | |
|
package.
|
||||||
|---|---|
|
|
||||||
| `C-c C-c` | recompile this function into the live program |
|
|
||||||
| `C-x C-e` | run this expression **inside** the running process — `(len enemies)` returns the real number |
|
|
||||||
| `C-u C-c C-c` | set a breakpoint without editing the buffer |
|
|
||||||
| `C-c C-m` | expand a macro, one step or to the fixpoint |
|
|
||||||
| `C-c C-b` | open the break loop when something goes wrong |
|
|
||||||
| `C-c C-r` | a REPL, scoped to the program |
|
|
||||||
|
|
||||||
## When it breaks, it does not die
|
|
||||||
|
|
||||||
Most languages give you two options when something goes wrong: crash, or have
|
|
||||||
guessed in advance what you wanted. Flan has Common Lisp's third option.
|
|
||||||
|
|
||||||
```
|
|
||||||
flan: unhandled Missing — stopped, not dead.
|
|
||||||
0. restart: carry-on
|
|
||||||
1. restart: use-placeholder
|
|
||||||
```
|
|
||||||
|
|
||||||
The program is sitting on the frame where the error happened, with everything it
|
|
||||||
had still in scope, waiting for you to decide. Pick a restart and it carries on —
|
|
||||||
it never unwound, so there is nothing to reconstruct.
|
|
||||||
|
|
||||||
Handlers run **on the signalling frame, without unwinding**, which means you can
|
|
||||||
also just… not have an error:
|
|
||||||
|
|
||||||
```lisp
|
|
||||||
;; A handler that returns normally accumulates and lets the signaller run on.
|
|
||||||
(handler-bind [(AssetMissing [c] (set seen (+ seen (i64 (.id c)))))]
|
|
||||||
(load-all))
|
|
||||||
```
|
|
||||||
|
|
||||||
No monad. No `Result` threading. No early return. The signaller carries on.
|
|
||||||
|
|
||||||
A breakpoint, incidentally, is not a feature. `pause` is an ordinary function that
|
|
||||||
signals a `Pause` condition, and a breakpoint is just a condition nobody handled.
|
|
||||||
|
|
||||||
## The language
|
|
||||||
|
|
||||||
**Four container types, four honest ownership stories.** `[n T]` is a fixed array
|
|
||||||
and it is a *value* — it copies. `[T]` is a slice: a pointer and a length that owns
|
|
||||||
nothing. `(Vec T)` and `(Map K V)` own their storage and move rather than copy.
|
|
||||||
|
|
||||||
```lisp
|
|
||||||
;; No initialiser means all-bytes-zero, so this lives in BSS and costs nothing.
|
|
||||||
(defvar grid [rows [cols i32]])
|
|
||||||
|
|
||||||
(let [row (slice (at grid 1) 0 cols)] ; ptr+len, borrows
|
|
||||||
(set (at row 0) 5)
|
|
||||||
(println (at grid 1 0))) ; 5 — the same storage
|
|
||||||
|
|
||||||
(set grid (zeroed)) ; a memset, not an allocation
|
|
||||||
```
|
|
||||||
|
|
||||||
**`defer` is a compile-time construct**, copied into the exit paths. Innermost
|
|
||||||
first. There is no runtime stack of thunks to pay for.
|
|
||||||
|
|
||||||
```lisp
|
|
||||||
(defn work [n i32] i32
|
|
||||||
(defer (println "second"))
|
|
||||||
(defer (println "first"))
|
|
||||||
(when (< n 0)
|
|
||||||
(return 0)) ; runs both defers above it
|
|
||||||
n)
|
|
||||||
```
|
|
||||||
|
|
||||||
**Generics are monomorphised, and checked once.** The body is verified abstractly at
|
|
||||||
the definition, so an unsupported operation is an error where you wrote it — not at
|
|
||||||
whichever call site happened to pass a type that worked.
|
|
||||||
|
|
||||||
```lisp
|
|
||||||
(defn clamp-to [x $t lo $t hi $t] $t
|
|
||||||
{:where (ordered? $t)}
|
|
||||||
(min (max x lo) hi))
|
|
||||||
```
|
|
||||||
|
|
||||||
**Macros are compiled, dlopened, and called.** There is no interpreter in this
|
|
||||||
project and there is not going to be one — compiling is the only way a form is ever
|
|
||||||
run, so there is no second evaluator to disagree with the first. Running a file that
|
|
||||||
calls a macro means the compiler built a shared object and loaded it into *itself*
|
|
||||||
before parsing your first line.
|
|
||||||
|
|
||||||
**The FFI is one line per function.** No wrapper, no `shim.c`:
|
|
||||||
|
|
||||||
```lisp
|
|
||||||
(declare-c init-window [width i32 height i32 title string] "InitWindow")
|
|
||||||
(declare-c window-should-close? [] bool "WindowShouldClose")
|
|
||||||
```
|
|
||||||
|
|
||||||
`Color` crosses by value. `Vector2` comes back by value. The compiler writes the
|
|
||||||
flattening C so you don't. There are **more than 470** raylib bindings in the box, and
|
|
||||||
**29** of raylib's own examples ported.
|
|
||||||
|
|
||||||
**Keywords are enums with an integer's ABI:**
|
|
||||||
|
|
||||||
```lisp
|
|
||||||
(defenum Key [space 32 escape 256 left 263 right 262])
|
|
||||||
(key-pressed? :space) ; resolved at compile time; a typo is an error here
|
|
||||||
```
|
|
||||||
|
|
||||||
## The demo
|
|
||||||
|
|
||||||
`sand.flan` is a falling-sand toy: 180×120 grains at 120fps. Hold the mouse and
|
|
||||||
sand pours out of the cursor, release and the colour cycles, `R` clears it.
|
|
||||||
|
|
||||||
It is 206 lines, and it deliberately uses almost nothing — no `Vec`, no `Map`, no
|
|
||||||
generics, no macros of its own, no allocator beyond the stack and static storage.
|
|
||||||
The grid is `[rows [cols u32]]`: flat, unboxed, in BSS, exactly `rows*cols*4` bytes.
|
|
||||||
The same memory the Odin port has. Nothing in the frame loop allocates.
|
|
||||||
|
|
||||||
The same file is also the regression test. `sand-headless.flan` imports it as a
|
|
||||||
package and — because the linker follows what the program actually reaches — pulls
|
|
||||||
in neither a window nor libraylib. It runs N frames and hashes the grid:
|
|
||||||
|
|
||||||
```
|
|
||||||
15595743031174623232
|
|
||||||
```
|
|
||||||
|
|
||||||
That number is byte-identical on native x86-64 and on wasm32-wasi, at `-O2` and at
|
|
||||||
`-O0`. The random number generator is written in Flan rather than borrowed from
|
|
||||||
libc precisely so that it would be.
|
|
||||||
|
|
||||||
## Two backends that agree
|
|
||||||
|
|
||||||
There is the LLVM backend, and there is a second one — about 3,400 lines of OCaml
|
|
||||||
that emits x86-64 machine code directly, byte by byte, because `llc` was most of
|
|
||||||
those 19 milliseconds and that was annoying.
|
|
||||||
|
|
||||||
Every program in the test corpus produces **byte-identical stdout, stderr and exit
|
|
||||||
status under both backends**. Not similar. Identical. There is a script that checks
|
|
||||||
this and it is the only reason anyone trusts the second one.
|
|
||||||
|
|
||||||
It also has a rule, stated in capital letters in two separate file headers:
|
|
||||||
|
|
||||||
> There is still no aggregate classifier and there must not be one.
|
|
||||||
|
|
||||||
## What works, and what doesn't
|
|
||||||
|
|
||||||
**Works, and is tested at `-O2`, `-O0` and `--dev`** — often under Valgrind and
|
|
||||||
ASan too: structs, unions, enums, `match`, generics, `Option`, macros, packages,
|
|
||||||
conditions and restarts, `defer`, arenas and explicit allocators, all four
|
|
||||||
containers, handles and pools, bounds checking, arithmetic errors as conditions,
|
|
||||||
the raylib FFI, UTF-8 strings, compile-time `embed`, the whole Emacs loop, a
|
|
||||||
wasm32 target, and DWARF debug info you can step through in lldb.
|
|
||||||
|
|
||||||
**Designed, refused by name, not built yet:** `(Result T E)` and `try`, `errdefer`,
|
|
||||||
`handler-case`, `find-restart`, user-written allocators, threading macros, and
|
|
||||||
`await`. The compiler will tell you which milestone each belongs to rather than
|
|
||||||
producing a confusing parse error.
|
|
||||||
|
|
||||||
**Honest limits.** Redefinition cannot patch a frame that is currently executing and
|
|
||||||
resume at the same instruction — its register allocation belonged to the old
|
|
||||||
compilation. "Resume" means re-entering from a restart. And changing a function's
|
|
||||||
*signature* is rejected rather than applied; changing its *body* is always safe,
|
|
||||||
because old code is never unloaded.
|
|
||||||
|
|
||||||
## Try it
|
|
||||||
|
|
||||||
```sh
|
```sh
|
||||||
dune build # the compiler
|
dune build
|
||||||
dune test # 232 checks
|
dune exec ./bin/main.exe -- run web/examples/hello.flan
|
||||||
flan run sand.flan # falling sand
|
|
||||||
flan dev sand.flan # falling sand you can edit
|
|
||||||
```
|
```
|
||||||
|
|
||||||
Then in Emacs: `M-x flan-dev`, or `C-c C-z` to attach to the one you just started.
|
To build a standalone native executable:
|
||||||
|
|
||||||
## Reading further
|
```sh
|
||||||
|
dune exec ./bin/main.exe -- build web/examples/hello.flan -o hello
|
||||||
|
./hello
|
||||||
|
```
|
||||||
|
|
||||||
- [`plan.org`](plan.org) — the design and the open decisions
|
The falling-sand demo uses raylib:
|
||||||
- [`spec-memory.md`](spec-memory.md) — ownership, containers, generics
|
|
||||||
- [`spec-conditions.md`](spec-conditions.md) — what a restart actually is
|
|
||||||
- [`emacs/MANUAL.md`](emacs/MANUAL.md) — every key binding and what it does
|
|
||||||
- [`web/index.html`](web/index.html) — the language reference, including a table of
|
|
||||||
everything that is *not* implemented and the exact words the compiler uses to
|
|
||||||
refuse it
|
|
||||||
|
|
||||||
## Licence
|
```sh
|
||||||
|
dune exec ./bin/main.exe -- run sand.fln
|
||||||
|
```
|
||||||
|
|
||||||
MIT. See [`LICENSE`](LICENSE).
|
Once you are iterating regularly, put the built executable on your `PATH` if
|
||||||
|
you want to use the shorter `flan` commands shown below.
|
||||||
|
|
||||||
The `vendor/` directory carries other people's work under their own terms —
|
## The live development loop
|
||||||
raylib is zlib/libpng, and the committed `raylib-5.5.h` stays under it.
|
|
||||||
|
|
||||||
---
|
Start a long-lived development session:
|
||||||
|
|
||||||
<div align="center">
|
```sh
|
||||||
|
flan dev sand.fln
|
||||||
|
```
|
||||||
|
|
||||||
Flan is a custard.
|
The program runs normally and publishes a local socket beside the source file.
|
||||||
|
The bundled Emacs mode can attach to it, evaluate expressions in the live
|
||||||
|
process, inspect a stopped program, and recompile a top-level function from
|
||||||
|
the buffer. A body change takes effect on the next call; changing a function's
|
||||||
|
signature is intentionally rejected. The program keeps its state, which is
|
||||||
|
especially nice when you have finally arranged the sand into something almost
|
||||||
|
worth saving.
|
||||||
|
|
||||||
</div>
|
To set up the mode:
|
||||||
|
|
||||||
|
```elisp
|
||||||
|
(add-to-list 'load-path "~/path/to/flan/emacs")
|
||||||
|
(require 'flan-mode)
|
||||||
|
```
|
||||||
|
|
||||||
|
Then use `M-x flan` to start and attach, or `C-c C-z` to attach to a
|
||||||
|
session started in a terminal. The editor workflow is documented in
|
||||||
|
[emacs/MANUAL.md](emacs/MANUAL.md).
|
||||||
|
|
||||||
|
## A small example
|
||||||
|
|
||||||
|
```lisp
|
||||||
|
(defstruct AssetMissing [id i32])
|
||||||
|
|
||||||
|
(defn load-asset [id i32] i32
|
||||||
|
(signal (AssetMissing {.id id}))
|
||||||
|
100)
|
||||||
|
|
||||||
|
(defn asset-or-placeholder [id i32] i32
|
||||||
|
(restart-case (load-asset id)
|
||||||
|
(use-placeholder [] -1)))
|
||||||
|
|
||||||
|
(defn main [] ()
|
||||||
|
(handler-bind [(AssetMissing [_] (invoke-restart 'use-placeholder))]
|
||||||
|
(print (asset-or-placeholder 7))))
|
||||||
|
```
|
||||||
|
|
||||||
|
Here a missing asset signals a typed condition. The handler chooses a restart,
|
||||||
|
so execution continues with a placeholder instead of requiring error values to
|
||||||
|
be threaded through every caller. See
|
||||||
|
[web/examples/restart.flan](web/examples/restart.flan) for a runnable version.
|
||||||
|
|
||||||
|
## Commands
|
||||||
|
|
||||||
|
Eleven of them, and the four anyone starts with:
|
||||||
|
|
||||||
|
```text
|
||||||
|
flan check <file.flan> type-check a program
|
||||||
|
flan run <file.flan> [flags] [-- args...] build and run it
|
||||||
|
flan build <file.flan> [-o out] [flags] build a native executable
|
||||||
|
flan dev <file.flan> [-s socket] [--llvm] start a live development session
|
||||||
|
```
|
||||||
|
|
||||||
|
Useful build options include `-O0`…`-O3`, `--debug`, `--sanitize`,
|
||||||
|
`--no-bounds-checks`, `--x86`, and `--target=wasm32-wasi|web`. `run` takes the
|
||||||
|
same build flags and keeps them: everything after `--` goes to the program, and
|
||||||
|
a dash-argument before it that `run` does not offer is refused rather than
|
||||||
|
guessed at. `run` is native-only; cross-built output should be run with an
|
||||||
|
appropriate WASI runtime or browser. A `.wasm` file is not a tiny native
|
||||||
|
executable in a trench coat.
|
||||||
|
|
||||||
|
`--x86` picks the hand-written backend (lib/x86.ml) instead of LLVM, and
|
||||||
|
`flan dev` is the one command that takes it unasked: a dev session is what it
|
||||||
|
was written for, it halves the `C-c C-c` round trip, and nothing it builds
|
||||||
|
outlives the session. `--llvm` is how to ask for the other one there — for a
|
||||||
|
program this backend refuses by name, and for `--debug`. Every other command here is LLVM
|
||||||
|
by default and stays that way; `emacs/MANUAL.md` lists what the dev backend
|
||||||
|
does not do.
|
||||||
|
|
||||||
|
The other seven. Four print a stage of the pipeline, which is how you find out
|
||||||
|
what the compiler thinks it was given:
|
||||||
|
|
||||||
|
```text
|
||||||
|
flan read <file.flan>... the forms the reader produced
|
||||||
|
flan parse <file.flan>... one line per declaration
|
||||||
|
flan shim <file.flan>... the C a (declare-c ...) generated
|
||||||
|
flan emit <file.flan> [--x86] [--dev] [--debug] [--no-bounds-checks]
|
||||||
|
LLVM IR, or x86-64 assembly under --x86
|
||||||
|
```
|
||||||
|
|
||||||
|
One builds a redefinition module the way `flan dev` does, for scripting the
|
||||||
|
loop without an editor:
|
||||||
|
|
||||||
|
```text
|
||||||
|
flan reload <program.flan> <forms.flan> [-o out.so] [--debug] [--x86]
|
||||||
|
```
|
||||||
|
|
||||||
|
And two are the C binding tools, which are the most useful thing here that
|
||||||
|
nothing else documents.
|
||||||
|
|
||||||
|
### `flan import-c` — read a header, print the bindings it implies
|
||||||
|
|
||||||
|
It builds nothing and writes nothing. It reads a C header (through clang's own
|
||||||
|
parser), prints the `declare-c` forms it would generate, and then prints every
|
||||||
|
function it *refused* and the reason — which is the half that earns its keep,
|
||||||
|
because "this binding is missing" and "this binding cannot exist" are different
|
||||||
|
problems:
|
||||||
|
|
||||||
|
```text
|
||||||
|
$ flan import-c test/headers/sample.h
|
||||||
|
(declare-c set-seed [seed u32] "set_seed")
|
||||||
|
(declare-c add-ints [a i32 b i32] i32 "add_ints")
|
||||||
|
(declare-c name-length [text str] i32 "name_length")
|
||||||
|
...
|
||||||
|
;; 9 imported, 12 refused, of 22 functions in test/headers/sample.h
|
||||||
|
;; refused owned-text: owned_text returns char *, which the caller owns and
|
||||||
|
;; releases through the library — a copy would leave the original with no
|
||||||
|
;; owner. Declare it with a declare-c returning (Ptr u8)
|
||||||
|
;; refused printf-like: printf_like is variadic, and a wrapper cannot forward
|
||||||
|
;; an argument list it does not know the shape of
|
||||||
|
;; refused file-time: file_time long has a width that differs between this
|
||||||
|
;; project's own targets (64 bits on x86-64, 32 on wasm32), so no single
|
||||||
|
;; Flan type is right for it
|
||||||
|
```
|
||||||
|
|
||||||
|
Hand the package's `.flan` files along with the header and it diffs against
|
||||||
|
them too: a `defstruct` whose layout no longer matches the header's record is
|
||||||
|
named, which is the failure that otherwise shows up as a wrong pixel.
|
||||||
|
|
||||||
|
```text
|
||||||
|
$ flan import-c vendor/raylib/raylib-5.5.h vendor/raylib/*.flan
|
||||||
|
```
|
||||||
|
|
||||||
|
Anything after the header that is not a `.flan` file is passed to clang, so
|
||||||
|
`-I` and `-D` work as they do anywhere else.
|
||||||
|
|
||||||
|
### `flan generate-c` — write those bindings into the package
|
||||||
|
|
||||||
|
The same machinery, committing its answer. It takes a package *directory*, not
|
||||||
|
a header: the header comes from the package's own `headers` file, at the
|
||||||
|
version its `link` file names, because which version may be read is a property
|
||||||
|
of the package and not of the command line. It reads every `.flan` in the
|
||||||
|
directory except the one it writes, so hand-written declarations keep winning,
|
||||||
|
and it writes `generated.fln`.
|
||||||
|
|
||||||
|
```text
|
||||||
|
$ flan generate-c vendor/raylib
|
||||||
|
;; refused text-format: TextFormat is variadic, and a wrapper cannot forward
|
||||||
|
;; an argument list it does not know the shape of
|
||||||
|
;; refused load-shader: LoadShader Shader is a struct the package does not
|
||||||
|
;; describe — add a defstruct for it, or keep a hand-written declare-c
|
||||||
|
```
|
||||||
|
|
||||||
|
It exits non-zero and writes nothing if the package and the header disagree.
|
||||||
|
That is the point of it: the committed file is the one thing in the package
|
||||||
|
with no second opinion, so the moment of writing it is the last moment at which
|
||||||
|
the installed library can contradict it.
|
||||||
|
|
||||||
|
## Environment
|
||||||
|
|
||||||
|
Thirteen variables the toolchain reads, none of which has to be set on a
|
||||||
|
machine with clang, LLVM and binutils on `PATH`. Each exists for a machine
|
||||||
|
where the thing is somewhere else, or is the wrong one.
|
||||||
|
|
||||||
|
| Variable | What it replaces | Read at |
|
||||||
|
|---|---|---|
|
||||||
|
| `FLAN_CLANG` | `clang`, which compiles the IR and the runtime's C | `lib/build.ml:14` |
|
||||||
|
| `FLAN_LLC` | `llc`, used only by the live loop | `lib/build.ml:886` |
|
||||||
|
| `FLAN_LD` | `ld`, used only by the live loop | `lib/build.ml:887` |
|
||||||
|
| `FLAN_AS` | `as`, used only by `--x86` | `lib/build.ml:978` |
|
||||||
|
| `FLAN_OBJDUMP` | `objdump`, used only by the disassembly verb | `lib/dev.ml:2018` |
|
||||||
|
| `FLAN_OCAMLFIND` | `ocamlfind`, which a merged `flan dev` needs **at run time** | `lib/dev.ml:2898` |
|
||||||
|
| `FLAN_EMCC` | `emcc`, for `--target=web` | `lib/build.ml:23` |
|
||||||
|
| `FLAN_LIBDIR` | where `flan.cmxa` and `flan.a` are, if not beside the binary | `lib/dev.ml:3187` |
|
||||||
|
| `FLAN_CACHE_DIR` | the object cache, default `$XDG_CACHE_HOME/flan/objcache` | `lib/build.ml:84` |
|
||||||
|
| `FLAN_WASM_SYSROOT` | the wasi-libc sysroot, default `/usr/wasm32-wasi` | `lib/build.ml:239` |
|
||||||
|
| `FLAN_WASM_BUILTINS` | `libclang_rt.builtins-wasm32.a`, which is not in clang's resource directory on Fedora | `lib/build.ml:272` |
|
||||||
|
| `FLAN_WEB_SHELL` | the HTML shell a `--target=web` build wraps the module in | `lib/build.ml:458` |
|
||||||
|
| `FLAN_DEV_LEAKS` | set (to anything) to have a `--dev` build print what it still held at exit | `runtime/flan_dev.c:1084` |
|
||||||
|
|
||||||
|
`${FLAN_RAYLIB_WEB}` is not read by the compiler: it is expanded inside
|
||||||
|
`vendor/raylib/link`, which is where a package writes a linker argument that
|
||||||
|
has to differ per target. Any `${NAME}` in a `link` file expands from the
|
||||||
|
environment and an unset one is refused by name.
|
||||||
|
|
||||||
|
**`llc` and `ld` have to match `clang`.** The live loop does not call the clang
|
||||||
|
driver at all — it goes `llc` + `ld -shared` + `dlopen`, which is what makes
|
||||||
|
`C-c C-c` cost milliseconds. So an `llc` from a different LLVM release than
|
||||||
|
`clang` breaks the dev loop while `flan build` keeps working perfectly, which
|
||||||
|
is a confusing shape of failure to meet without warning.
|
||||||
|
|
||||||
|
Variables beginning `FLAN_DEV_` other than `FLAN_DEV_LEAKS`, plus
|
||||||
|
`FLAN_AGENT_SOCKET`, `FLAN_AGENT_OWNER` and `FLAN_COMPILER_STAMP`, are
|
||||||
|
internal: `flan dev` sets them across its own `exec` to hand the merged binary
|
||||||
|
what it needs. Setting them by hand is not supported.
|
||||||
|
|
||||||
|
## Checking it
|
||||||
|
|
||||||
|
```text
|
||||||
|
dune test the suite. Seconds. Run it constantly.
|
||||||
|
dune build @checks everything else that can fail. A couple of minutes.
|
||||||
|
dune build @sanitize the corpus under ASan and UBSan.
|
||||||
|
dune build @valgrind the corpus under memcheck. Tens of minutes.
|
||||||
|
```
|
||||||
|
|
||||||
|
`dune test` means "the language still works". `@checks` — which is `@page`,
|
||||||
|
`@x86` and `@cells` — means "and everything written down about it is still
|
||||||
|
true": the reference page's examples still print what the page says, the
|
||||||
|
hand-written x86 backend still agrees with LLVM, and a `--dev` build still calls
|
||||||
|
through its indirection cells.
|
||||||
|
|
||||||
|
The two are separate on purpose. A suite that goes red because prose drifted
|
||||||
|
teaches you to skim past red. Both of this repository's silent failures — two
|
||||||
|
backend refusals that sat for a month, a page of examples that stopped
|
||||||
|
compiling for two days — were found by accident, and neither would have
|
||||||
|
survived one person typing one command.
|
||||||
|
|
||||||
|
`.github/workflows/checks.yml` is now that person: it runs `dune build`,
|
||||||
|
`dune test --force` and `dune build @checks` on every push. What it cannot run
|
||||||
|
is written down in the workflow itself rather than left to be discovered —
|
||||||
|
raylib, emscripten, wasm32-wasi and lldb are all absent from an Ubuntu runner,
|
||||||
|
and every one of them was already a self-skip, so the tick is green over less
|
||||||
|
than it is on a machine with those installed. The habit that covers the rest is
|
||||||
|
still worth keeping: a lane's handoff quotes `@checks`, the way the x86
|
||||||
|
handoffs already quote the survey's counts.
|
||||||
|
|
||||||
|
## Project map
|
||||||
|
|
||||||
|
- [web/index.html](web/index.html) — language reference and fuller examples.
|
||||||
|
- [spec-memory.md](spec-memory.md) — ownership, containers, and generics.
|
||||||
|
- [spec-conditions.md](spec-conditions.md) — conditions, handlers, and restarts.
|
||||||
|
- [emacs/MANUAL.md](emacs/MANUAL.md) — the interactive editor workflow.
|
||||||
|
- [docs/BUILT.md](docs/BUILT.md) — implementation rationale.
|
||||||
|
- [TODO.org](TODO.org) — decisions, current work, and known limits.
|
||||||
|
|
||||||
|
## License
|
||||||
|
|
||||||
|
Flan is released under the [MIT License](LICENSE). Third-party material under
|
||||||
|
`vendor/` is distributed under its own licenses.
|
||||||
+585
-83
@@ -4,8 +4,15 @@
|
|||||||
still exits 1 and still opens with [file:line:col: message]; a driver that
|
still exits 1 and still opens with [file:line:col: message]; a driver that
|
||||||
got to the end of the file hands over everything it found, sorted, with a
|
got to the end of the file hands over everything it found, sorted, with a
|
||||||
count after it. Nothing here parses the message — the squiggle comes from
|
count after it. Nothing here parses the message — the squiggle comes from
|
||||||
the span and the classification from the kind. *)
|
the span and the classification from the kind.
|
||||||
let with_errors path f =
|
|
||||||
|
[?x86_hint] is the one thing here that is not the same for every command.
|
||||||
|
A refusal from the dev backend is actionable in a different way depending on
|
||||||
|
how that backend was chosen: somebody who typed [--x86] already knows they
|
||||||
|
asked for it, and somebody who typed [flan dev] did not ask for anything.
|
||||||
|
The second is the common case now that it is the default, so the command
|
||||||
|
that takes it by default hands over the sentence naming the way out. *)
|
||||||
|
let with_errors ?x86_hint path f =
|
||||||
try f () with
|
try f () with
|
||||||
| Flan.Loc.Error d ->
|
| Flan.Loc.Error d ->
|
||||||
prerr_endline (Flan.Loc.report d);
|
prerr_endline (Flan.Loc.report d);
|
||||||
@@ -21,8 +28,50 @@ let with_errors path f =
|
|||||||
"did not compile". *)
|
"did not compile". *)
|
||||||
| Flan.X86.Unsupported m ->
|
| Flan.X86.Unsupported m ->
|
||||||
prerr_endline ("x86: " ^ m);
|
prerr_endline ("x86: " ^ m);
|
||||||
|
Option.iter prerr_endline x86_hint;
|
||||||
ignore path;
|
ignore path;
|
||||||
exit 3
|
exit 3
|
||||||
|
(* The JS dialect's refusal, and the same status for the same reason. It is
|
||||||
|
a wider category than the x86 one — that backend is behind on a node, and
|
||||||
|
this one is a dialect that deliberately does not carry the memory model —
|
||||||
|
but a sweep counts them the same way: refused by name, not a failure. *)
|
||||||
|
| Flan.Js.Unsupported m ->
|
||||||
|
prerr_endline ("js: " ^ m);
|
||||||
|
ignore path;
|
||||||
|
exit 3
|
||||||
|
(* A refusal with no location: a combination of flags this command does not
|
||||||
|
offer, or a build step that failed. Every [failwith] this binary can reach
|
||||||
|
is one of those, and a sentence is what a user can act on where an
|
||||||
|
uncaught OCaml exception and its backtrace are not. *)
|
||||||
|
| Failure m ->
|
||||||
|
prerr_endline ("flan: " ^ m);
|
||||||
|
ignore path;
|
||||||
|
exit 1
|
||||||
|
(* A file that is not there, or that cannot be read. The exception already
|
||||||
|
carries the path and the reason the operating system gave, which is the
|
||||||
|
whole of what anybody can act on, so it is passed through as it is —
|
||||||
|
[lib/dev.ml]'s [message_of_exn] does the same for the same reason, and
|
||||||
|
the daemon has had this arm since before the CLI did. Without it
|
||||||
|
[flan check nosuch.flan] ends in [Fatal error: exception Sys_error(...)],
|
||||||
|
which is the compiler telling the user it did not expect to be asked. *)
|
||||||
|
| Sys_error m ->
|
||||||
|
prerr_endline ("flan: " ^ m);
|
||||||
|
ignore path;
|
||||||
|
exit 1
|
||||||
|
(* The backstop. Nothing in this binary reaches it today: every [Hashtbl.find]
|
||||||
|
on a path a command can take is guarded by a [find_opt]. It is here so
|
||||||
|
that the day one is not, the failure is a sentence naming the file being
|
||||||
|
worked on rather than a bare [Fatal error: exception Not_found] — which
|
||||||
|
says nothing at all, not even which file. Its own exit status, because a
|
||||||
|
compiler bug is not a refusal of the program and a script should be able
|
||||||
|
to tell the two apart. *)
|
||||||
|
| Not_found ->
|
||||||
|
prerr_endline
|
||||||
|
("flan: internal error — a lookup failed with no name to report, while \
|
||||||
|
working on " ^ path
|
||||||
|
^ ". This is a bug in the compiler and not a fault in the program; \
|
||||||
|
please report the file that provoked it.");
|
||||||
|
exit 4
|
||||||
|
|
||||||
let summarise (d : Flan.Ast.decl) =
|
let summarise (d : Flan.Ast.decl) =
|
||||||
let open Flan.Ast in
|
let open Flan.Ast in
|
||||||
@@ -30,9 +79,13 @@ let summarise (d : Flan.Ast.decl) =
|
|||||||
| Package n -> Printf.sprintf "package %s" n
|
| Package n -> Printf.sprintf "package %s" n
|
||||||
| Import (a, p) -> Printf.sprintf "import %s %S" a p
|
| Import (a, p) -> Printf.sprintf "import %s %S" a p
|
||||||
| Defalias (n, _) -> Printf.sprintf "defalias %s" n
|
| Defalias (n, _) -> Printf.sprintf "defalias %s" n
|
||||||
| Defstruct (n, fs) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs)
|
| Defsymbol (n, _) -> Printf.sprintf "symbol %s" n
|
||||||
| Defunion (n, vs) -> Printf.sprintf "defunion %s (%d cases)" n (List.length vs)
|
| Defstruct (n, fs, _) -> Printf.sprintf "defstruct %s (%d fields)" n (List.length fs)
|
||||||
| Defvar (n, _, _) -> Printf.sprintf "defvar %s" n
|
| Defdata (n, vs) -> Printf.sprintf "defdata %s (%d cases)" n (List.length vs)
|
||||||
|
| Defunion (n, ms) ->
|
||||||
|
Printf.sprintf "defunion %s (%d members)" n (List.length ms)
|
||||||
|
| Defvar (n, _, _, Once) -> Printf.sprintf "defonce %s" n
|
||||||
|
| Defvar (n, _, _, Every) -> Printf.sprintf "def %s" n
|
||||||
| Defconst (n, _, _) -> Printf.sprintf "defconst %s" n
|
| Defconst (n, _, _) -> Printf.sprintf "defconst %s" n
|
||||||
| Declare (fn, csym) ->
|
| Declare (fn, csym) ->
|
||||||
Printf.sprintf "declare %s (%d params) = %s" fn.name (List.length fn.params)
|
Printf.sprintf "declare %s (%d params) = %s" fn.name (List.length fn.params)
|
||||||
@@ -41,23 +94,28 @@ let summarise (d : Flan.Ast.decl) =
|
|||||||
Printf.sprintf "declare-c %s (%d params) = %s" fn.name
|
Printf.sprintf "declare-c %s (%d params) = %s" fn.name
|
||||||
(List.length fn.params) csym
|
(List.length fn.params) csym
|
||||||
| Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms)
|
| Defenum (n, ms) -> Printf.sprintf "defenum %s (%d members)" n (List.length ms)
|
||||||
|
| Defclass (n, slots) ->
|
||||||
|
Printf.sprintf "defclass %s (%d slots)" n (List.length slots)
|
||||||
|
| Defgeneric fn ->
|
||||||
|
Printf.sprintf "defgeneric %s (%d params)" fn.name (List.length fn.params)
|
||||||
|
| Defmulti fn ->
|
||||||
|
Printf.sprintf "defmulti %s (%d params)" fn.name (List.length fn.params)
|
||||||
|
| Defmethod m ->
|
||||||
|
Printf.sprintf "defmethod %s %s (%d body forms)" m.mgen
|
||||||
|
(dispatch_text m.mkey) (List.length m.mfn.fbody)
|
||||||
| Defn fn ->
|
| Defn fn ->
|
||||||
Printf.sprintf "defn %s (%d params, %s return, %d body forms)"
|
Printf.sprintf "defn %s (%d params, %s return, %d body forms)"
|
||||||
fn.name (List.length fn.params)
|
fn.name (List.length fn.params)
|
||||||
(match fn.ret with None -> "Unit" | Some _ -> "explicit")
|
(match fn.ret with None -> "Unit" | Some _ -> "explicit")
|
||||||
(List.length fn.fbody)
|
(List.length fn.fbody)
|
||||||
|
|
||||||
(* Every path past [parse] goes through [Load]: an import is resolved into the
|
(* Every path past [parse] goes through [Front], and so through [Load]: an
|
||||||
declarations it stands for, and the package's C shim and linker arguments
|
import is resolved into the declarations it stands for, and the package's C
|
||||||
come back with them. *)
|
shim and linker arguments come back with them. Every driver here is the
|
||||||
(* Every driver here is the batch case, which is the one the workflow is: write
|
batch case, which is the one the workflow is: write everything, compile at
|
||||||
everything, compile at the end, work through the list. So every one of them
|
the end, work through the list. So every one of them passes [~all:true] and
|
||||||
asks for the whole list rather than the first thing wrong. *)
|
asks for the whole list rather than the first thing wrong. *)
|
||||||
let load path : Flan.Load.t =
|
let checked path = snd (Flan.Front.checked ~all:true path)
|
||||||
Flan.Load.program ~file:path
|
|
||||||
~parse:Flan.Parse.program_all (Flan.Reader.read_file path)
|
|
||||||
|
|
||||||
let checked path = Flan.Check.program_all (load path).decls
|
|
||||||
|
|
||||||
(* What the source called each parameter, per function. The typed IR refers to
|
(* What the source called each parameter, per function. The typed IR refers to
|
||||||
locals by slot index and records no names — [Check] has them in its scope
|
locals by slot index and records no names — [Check] has them in its scope
|
||||||
@@ -79,12 +137,14 @@ let param_names (l : Flan.Load.t) =
|
|||||||
l.Flan.Load.decls
|
l.Flan.Load.decls
|
||||||
|
|
||||||
(* Bounds checks are on unless a build asks for them off — the release
|
(* Bounds checks are on unless a build asks for them off — the release
|
||||||
decision, not the optimisation level (NEXT.md, Bounds checks). *)
|
decision, not the optimisation level (TODO.org, "An index out of range is
|
||||||
|
a condition"). *)
|
||||||
let no_checks_flag = "--no-bounds-checks"
|
let no_checks_flag = "--no-bounds-checks"
|
||||||
|
|
||||||
(* A dev build is the one a REPL can attach to: every call goes through a cell
|
(* A dev build is the one a REPL can attach to: every call goes through a cell
|
||||||
so a redefinition can be installed, and the cells and globals are exported
|
so a redefinition can be installed, and the cells and globals are exported
|
||||||
so a loaded module can reach them (NEXT.md, the dev loop). *)
|
so a loaded module can reach them (TODO.org, "The dev loop, step 1: the
|
||||||
|
reload primitive"). *)
|
||||||
let dev_flag = "--dev"
|
let dev_flag = "--dev"
|
||||||
|
|
||||||
(* Source-level debugging: DWARF in the IR, -g on the C, and -O0 forced.
|
(* Source-level debugging: DWARF in the IR, -g on the C, and -O0 forced.
|
||||||
@@ -109,15 +169,106 @@ let sanitize_flag = "--sanitize"
|
|||||||
let two_process_flag = "--two-process"
|
let two_process_flag = "--two-process"
|
||||||
|
|
||||||
(* The hand-written x86-64 backend (lib/x86.ml) instead of LLVM. The dev
|
(* The hand-written x86-64 backend (lib/x86.ml) instead of LLVM. The dev
|
||||||
backend from DISCUSS.md item 15, off by default and named explicitly:
|
backend written up in docs/BUILT.md, "The hand-written x86 backend, and
|
||||||
LLVM stays the release path and the default one. It covers a subset of the
|
the four measurements behind it". It covers a subset of the IR and
|
||||||
IR and refuses the rest by name, so a build that succeeds is one it really
|
refuses the rest by name, so a build that succeeds is one it really
|
||||||
compiled. *)
|
compiled.
|
||||||
|
|
||||||
|
Where it is the default and where it is not is the whole of the split: it
|
||||||
|
is the dev backend, so [flan dev] takes it unasked, and every other command
|
||||||
|
here builds something that outlives the session and stays on LLVM. That is
|
||||||
|
also what keeps [lib/x86.ml]'s calling convention licensed — a dev build is
|
||||||
|
compiled entirely by it and a release build entirely by LLVM, so the two
|
||||||
|
never meet in one process. On the commands that are still LLVM by default
|
||||||
|
this flag is how you ask for the other backend; on [flan dev] it is how you
|
||||||
|
say you meant it, which is what keeps [--x86 --debug] refused by name
|
||||||
|
rather than reached by accident. *)
|
||||||
let x86_flag = "--x86"
|
let x86_flag = "--x86"
|
||||||
|
|
||||||
|
(* The other direction, and it exists because [flan dev] changed sides: a dev
|
||||||
|
session is the x86 backend now, and this is how to ask for the one that
|
||||||
|
compiles every node. The two reasons to want it are the ones the backend
|
||||||
|
itself names — a program it refuses, and [--debug], which it has no line
|
||||||
|
table for in a redefinition module.
|
||||||
|
|
||||||
|
Every other command already builds through LLVM, so there it names the
|
||||||
|
default and is accepted and ignored. That is deliberate rather than an
|
||||||
|
oversight in the flag table: a flag that states what a command was going to
|
||||||
|
do anyway is a true sentence, and refusing it would make the one spelling
|
||||||
|
mean two different things depending on which subcommand it followed. *)
|
||||||
|
let llvm_flag = "--llvm"
|
||||||
|
|
||||||
|
(* [flan emit] annotates, with --x86 or without, because it exists to be
|
||||||
|
read: each Flan form heads the code it produced. This turns that off, and
|
||||||
|
the callers who want it are the checks that compile the output both ways and
|
||||||
|
compare the objects byte for byte -- a claim that comments, and the splitting
|
||||||
|
of a [.byte] directive, are invisible to the assembler and to [llc] is worth
|
||||||
|
measuring rather than asserting. *)
|
||||||
|
let no_annotate_flag = "--no-annotate"
|
||||||
|
|
||||||
|
(* "This program carries no collector", and the way it is kept is a refusal
|
||||||
|
rather than a different lowering: every dyn left in the program is named,
|
||||||
|
with its location, and nothing downstream is told the flag was given. See
|
||||||
|
[Check.no_gc], which is a pass between checking and emission and answers
|
||||||
|
unit — an annotated program's output is byte for byte what it is without
|
||||||
|
the flag, and that is the property the flag is worth having for. *)
|
||||||
|
let no_gc_flag = "--no-gc"
|
||||||
|
|
||||||
|
(* "Which of these lines allocates?", printed and nothing else. The other side
|
||||||
|
of [--no-gc]: that flag refuses a program for holding a dyn, this one only
|
||||||
|
says where the memory goes — on the collector's heap and on an allocator the
|
||||||
|
program named, told apart by the diagnostic's kind. Off by default, because
|
||||||
|
a warning on every push in a program that means them is noise; asked for,
|
||||||
|
because a frame budget is a question you ask on purpose.
|
||||||
|
|
||||||
|
It is a warning and not an error, and it says so in the one way that
|
||||||
|
matters: the exit status does not move. See [Check.memory_sites], which is
|
||||||
|
a pass over the checked program and, like [Check.no_gc], tells nothing
|
||||||
|
downstream that it ran. *)
|
||||||
|
let warn_memory_flag = "--warn-memory"
|
||||||
|
|
||||||
|
(* [flan check --defs]: every definition the checked program holds, prelude
|
||||||
|
included. Off by default, so a file that checks prints nothing. *)
|
||||||
|
let defs_flag = "--defs"
|
||||||
|
|
||||||
let flags =
|
let flags =
|
||||||
[ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag;
|
[ no_checks_flag; dev_flag; debug_flag; sanitize_flag; two_process_flag;
|
||||||
x86_flag ]
|
x86_flag; llvm_flag; no_annotate_flag; no_gc_flag; warn_memory_flag;
|
||||||
|
defs_flag ]
|
||||||
|
|
||||||
|
(* The warnings, where errors go. Printed one to a location in the repo's
|
||||||
|
standard [file:line:col:] shape, with the squiggle [Loc.entry] draws, so
|
||||||
|
an editor or a flycheck checker parses them exactly as it parses an error.
|
||||||
|
Not through [Loc.report_all]: that appends a count of *errors*, and these
|
||||||
|
are not errors. *)
|
||||||
|
let print_memory_warnings ~file (p : Flan.Tast.program) =
|
||||||
|
List.iter
|
||||||
|
(fun (d : Flan.Loc.diag) ->
|
||||||
|
prerr_endline
|
||||||
|
(Flan.Loc.entry ~mark:'~' ~label:"warning: " d.Flan.Loc.dloc
|
||||||
|
d.Flan.Loc.dmsg))
|
||||||
|
(Flan.Check.memory_sites ~file p)
|
||||||
|
|
||||||
|
(* Which backend a command got, from the two flags and the default it would
|
||||||
|
have taken. One function because there is one rule, and the only thing that
|
||||||
|
varies is which way it falls with neither flag given: [flan dev] true, every
|
||||||
|
other command false.
|
||||||
|
|
||||||
|
Both flags together is refused rather than resolved. Last-one-wins is what
|
||||||
|
[-O] does above, but an optimisation level is a dial and this is a fork: the
|
||||||
|
two backends disagree on every aggregate, and someone who wrote both
|
||||||
|
spellings does not know which half of their session they were asking about.
|
||||||
|
A sentence is more use than a coin flip. *)
|
||||||
|
let backend_x86 ~default args =
|
||||||
|
let x86 = List.mem x86_flag args and llvm = List.mem llvm_flag args in
|
||||||
|
if x86 && llvm then begin
|
||||||
|
prerr_endline
|
||||||
|
"flan: --x86 and --llvm together — one process is compiled by one \
|
||||||
|
backend, so this asks a question with no answer. Pick the one you \
|
||||||
|
meant.";
|
||||||
|
exit 2
|
||||||
|
end;
|
||||||
|
if x86 then true else if llvm then false else default
|
||||||
|
|
||||||
(* [--target=wasm32-wasi] and [--target=web], the two cross targets. Unlike
|
(* [--target=wasm32-wasi] and [--target=web], the two cross targets. Unlike
|
||||||
the flags above, a target
|
the flags above, a target
|
||||||
@@ -126,8 +277,43 @@ let flags =
|
|||||||
usage error. *)
|
usage error. *)
|
||||||
let target_prefix = "--target="
|
let target_prefix = "--target="
|
||||||
|
|
||||||
|
(* The optimisation level, which until now had no spelling at all: [Build.default]
|
||||||
|
pinned -O2 and [--debug] was the only route to anything else. Four levels and
|
||||||
|
not five — -Os is clang's and llc rejects it outright ("invalid optimization
|
||||||
|
level"), and the same string reaches both ([Build] at the clang compile and
|
||||||
|
again at the llc step of the live loop), so offering a level one of the two
|
||||||
|
tools does not know would be a flag that works for [flan build] and breaks
|
||||||
|
[C-c C-c].
|
||||||
|
|
||||||
|
Last one wins, which is what every compiler does with a repeated -O and the
|
||||||
|
only rule that does not need explaining. *)
|
||||||
|
let opt_levels = [ "-O0"; "-O1"; "-O2"; "-O3" ]
|
||||||
|
|
||||||
|
let opt_of args =
|
||||||
|
List.fold_left
|
||||||
|
(fun acc a -> if List.mem a opt_levels then Some a else acc)
|
||||||
|
None args
|
||||||
|
|
||||||
let is_flag a =
|
let is_flag a =
|
||||||
List.mem a flags || String.starts_with ~prefix:target_prefix a
|
List.mem a flags || List.mem a opt_levels
|
||||||
|
|| String.starts_with ~prefix:target_prefix a
|
||||||
|
|
||||||
|
(* [--debug] forces -O0 in [Build] and says why there: [llvm.dbg.declare]
|
||||||
|
describes an alloca and mem2reg deletes the alloca, so a debug build at -O2
|
||||||
|
has a line table over code whose locals are gone. That is a good rule, and
|
||||||
|
it makes [--debug -O2] a request that cannot be honoured — so it is refused
|
||||||
|
here by name instead of being quietly overruled two modules away. *)
|
||||||
|
let check_opt_against_debug ~debug ~opt =
|
||||||
|
match (debug, opt) with
|
||||||
|
| true, Some o when o <> "-O0" ->
|
||||||
|
prerr_endline
|
||||||
|
("flan: --debug and " ^ o
|
||||||
|
^ " ask for opposite things — a debug build is -O0 because \
|
||||||
|
llvm.dbg.declare describes an alloca and mem2reg at any higher level \
|
||||||
|
deletes it, leaving a line table over locals that are not there. \
|
||||||
|
Drop one of the two.");
|
||||||
|
exit 2
|
||||||
|
| _ -> ()
|
||||||
|
|
||||||
let target_of args =
|
let target_of args =
|
||||||
List.find_map
|
List.find_map
|
||||||
@@ -144,36 +330,89 @@ let () =
|
|||||||
List.iter
|
List.iter
|
||||||
(fun path ->
|
(fun path ->
|
||||||
with_errors path (fun () ->
|
with_errors path (fun () ->
|
||||||
Flan.Reader.read_file path
|
Flan.Source.read_file path
|
||||||
|> List.iter (fun f -> print_endline (Flan.Form.to_string f))))
|
|> List.iter (fun f -> print_endline (Flan.Form.to_string f))))
|
||||||
files
|
files
|
||||||
|
(* The other syntax, on stdout: a .flan file printed indented, a .fln file
|
||||||
|
printed with parentheses, comments and number spellings kept both
|
||||||
|
ways. *)
|
||||||
|
| [ _; "convert"; path ] ->
|
||||||
|
with_errors path (fun () ->
|
||||||
|
let forms = Flan.Source.read_file path in
|
||||||
|
let source = In_channel.with_open_bin path In_channel.input_all in
|
||||||
|
if Flan.Source.is_indented path then
|
||||||
|
print_string (Flan.Paren_printer.program ~source forms)
|
||||||
|
else
|
||||||
|
let macros = Flan.Body_macros.table ~file:path forms in
|
||||||
|
match Flan.Indent_printer.program ~source ~macros forms with
|
||||||
|
| text -> print_string text
|
||||||
|
| exception Flan.Indent_printer.Unprintable (f, why) ->
|
||||||
|
Flan.Loc.failk "convert/unprintable" f.Flan.Form.loc
|
||||||
|
"%s has no spelling in the indented syntax, so this file cannot \
|
||||||
|
be converted. Rename it in the .flan file and convert again"
|
||||||
|
why)
|
||||||
| _ :: "parse" :: files when files <> [] ->
|
| _ :: "parse" :: files when files <> [] ->
|
||||||
List.iter
|
List.iter
|
||||||
(fun path ->
|
(fun path ->
|
||||||
with_errors path (fun () ->
|
with_errors path (fun () ->
|
||||||
Flan.Reader.read_file path
|
Flan.Source.read_file path
|
||||||
|> Flan.Parse.program_all
|
|> Flan.Parse.program_all
|
||||||
|> List.iter (fun d -> print_endline (summarise d))))
|
|> List.iter (fun d -> print_endline (summarise d))))
|
||||||
files
|
files
|
||||||
| _ :: "check" :: files when files <> [] ->
|
| _ :: "check" :: args when List.exists (fun a -> not (is_flag a)) args ->
|
||||||
|
let warn_memory = List.mem warn_memory_flag args in
|
||||||
|
let defs = List.mem defs_flag args in
|
||||||
|
let files = List.filter (fun a -> not (is_flag a)) args in
|
||||||
List.iter
|
List.iter
|
||||||
(fun path ->
|
(fun path ->
|
||||||
with_errors path (fun () ->
|
with_errors path (fun () ->
|
||||||
let p = checked path in
|
let p = checked path in
|
||||||
List.iter
|
(* After the listing is decided and before it is printed is not a
|
||||||
(fun (g : Flan.Tast.global) ->
|
distinction anything can see: the warnings go to stderr and the
|
||||||
Printf.printf "%s %s %s\n"
|
listing to stdout. What matters is that they are asked of a
|
||||||
(if g.gconst then "defconst" else "defvar")
|
program that checked, which is what leaves the exit status
|
||||||
g.gname (Flan.Types.to_string g.gty))
|
alone. *)
|
||||||
p.globals;
|
if warn_memory then print_memory_warnings ~file:path p;
|
||||||
List.iter
|
if defs then begin
|
||||||
(fun (f : Flan.Tast.fn) ->
|
List.iter
|
||||||
Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name
|
(fun (g : Flan.Tast.global) ->
|
||||||
(String.concat " "
|
Printf.printf "%s %s %s\n"
|
||||||
(List.map Flan.Types.to_string f.params))
|
(* The three defining forms, told apart the way the compiler
|
||||||
(Flan.Types.to_string f.ret) (Array.length f.slots))
|
tells them apart: [gconst] is the image, and [grerun] is
|
||||||
p.fns))
|
what a re-run does to the storage. A listing that called
|
||||||
|
both mutable forms one name could not answer the question
|
||||||
|
someone runs [flan check] on a dev file to ask. *)
|
||||||
|
(if g.gconst then "defconst"
|
||||||
|
else if g.grerun then "def" else "defonce")
|
||||||
|
g.gname (Flan.Types.to_string g.gty))
|
||||||
|
p.globals;
|
||||||
|
List.iter
|
||||||
|
(fun (f : Flan.Tast.fn) ->
|
||||||
|
if not (Flan.Check.internal_name f.name) then
|
||||||
|
Printf.printf "defn %s : (Fn [%s] %s) %d slots\n" f.name
|
||||||
|
(String.concat " "
|
||||||
|
(List.map Flan.Types.to_string f.params))
|
||||||
|
(Flan.Types.to_string f.ret) (Array.length f.slots))
|
||||||
|
p.fns
|
||||||
|
end))
|
||||||
files
|
files
|
||||||
|
(* [flan copies <file> <name>]: the compiled copies of the generic NAME that
|
||||||
|
the file makes, one name to a line, and nothing when NAME is not generic
|
||||||
|
or nothing calls it. The editor's lowering view asks it with no daemon
|
||||||
|
attached; a daemon's [defs] answers the same from its session. *)
|
||||||
|
| [ _; "copies"; path; name ] ->
|
||||||
|
with_errors path (fun () ->
|
||||||
|
let s, _ = Flan.Session.create ~file:path () in
|
||||||
|
let env = s.Flan.Session.env in
|
||||||
|
if Flan.Check.is_generic env name then
|
||||||
|
List.iter
|
||||||
|
(fun c ->
|
||||||
|
if
|
||||||
|
List.exists
|
||||||
|
(fun (f : Flan.Tast.fn) -> String.equal f.Flan.Tast.name c)
|
||||||
|
s.Flan.Session.program.Flan.Tast.fns
|
||||||
|
then print_endline (Flan.Check.written_name c))
|
||||||
|
(Flan.Check.instantiations env name))
|
||||||
(* The generated C, for looking at. A wrong FFI binding is wrong in the
|
(* The generated C, for looking at. A wrong FFI binding is wrong in the
|
||||||
wrapper, and the wrapper is not on disk anywhere — [Build] hands the text
|
wrapper, and the wrapper is not on disk anywhere — [Build] hands the text
|
||||||
straight to clang — so without this the only way to read one is to catch
|
straight to clang — so without this the only way to read one is to catch
|
||||||
@@ -195,19 +434,27 @@ let () =
|
|||||||
the header's records. *)
|
the header's records. *)
|
||||||
| _ :: "import-c" :: header :: rest ->
|
| _ :: "import-c" :: header :: rest ->
|
||||||
with_errors header (fun () ->
|
with_errors header (fun () ->
|
||||||
let pkg = List.filter (fun a -> Filename.check_suffix a ".flan") rest in
|
let pkg = List.filter Flan.Source.is_source rest in
|
||||||
let flags =
|
let flags =
|
||||||
List.filter (fun a -> not (Filename.check_suffix a ".flan")) rest
|
List.filter (fun a -> not (Flan.Source.is_source a)) rest
|
||||||
in
|
in
|
||||||
let ds =
|
let ds =
|
||||||
List.concat_map
|
List.concat_map
|
||||||
(fun f -> Flan.Parse.program (Flan.Reader.read_file f)) pkg
|
(fun f -> Flan.Parse.program (Flan.Source.read_file f)) pkg
|
||||||
in
|
in
|
||||||
let structs =
|
let structs =
|
||||||
List.filter_map
|
List.filter_map
|
||||||
(fun (d : Flan.Ast.decl) ->
|
(fun (d : Flan.Ast.decl) ->
|
||||||
match d.Flan.Ast.d with
|
match d.Flan.Ast.d with
|
||||||
| Flan.Ast.Defstruct (n, fs) -> Some (n, fs)
|
| Flan.Ast.Defstruct (n, fs, _) -> Some (n, fs)
|
||||||
|
| _ -> None)
|
||||||
|
ds
|
||||||
|
in
|
||||||
|
let unions =
|
||||||
|
List.filter_map
|
||||||
|
(fun (d : Flan.Ast.decl) ->
|
||||||
|
match d.Flan.Ast.d with
|
||||||
|
| Flan.Ast.Defunion (n, ms) -> Some (n, ms)
|
||||||
| _ -> None)
|
| _ -> None)
|
||||||
ds
|
ds
|
||||||
in
|
in
|
||||||
@@ -236,7 +483,8 @@ let () =
|
|||||||
in
|
in
|
||||||
let imported, dump, env =
|
let imported, dump, env =
|
||||||
Flan.Cimport.header ~loc:(Flan.Loc.make header 0 0) ~header ~flags
|
Flan.Cimport.header ~loc:(Flan.Loc.make header 0 0) ~header ~flags
|
||||||
~known_structs:(List.map fst structs) ~known_enums ~taken ~bound_syms
|
~known_structs:(List.map fst structs)
|
||||||
|
~known_unions:(List.map fst unions) ~known_enums ~taken ~bound_syms
|
||||||
~config:
|
~config:
|
||||||
(match pkg with
|
(match pkg with
|
||||||
| f :: _ -> Flan.Load.binding_config (Filename.dirname f)
|
| f :: _ -> Flan.Load.binding_config (Filename.dirname f)
|
||||||
@@ -260,6 +508,14 @@ let () =
|
|||||||
List.iter
|
List.iter
|
||||||
(fun (n, why) -> Printf.printf ";; DISAGREES %s: %s\n" n why)
|
(fun (n, why) -> Printf.printf ";; DISAGREES %s: %s\n" n why)
|
||||||
bad);
|
bad);
|
||||||
|
(match Flan.Cimport.check_unions ~env ~unions dump with
|
||||||
|
| [] ->
|
||||||
|
if unions <> [] then
|
||||||
|
Printf.printf ";; every defunion agrees with the header\n"
|
||||||
|
| bad ->
|
||||||
|
List.iter
|
||||||
|
(fun (n, why) -> Printf.printf ";; DISAGREES %s: %s\n" n why)
|
||||||
|
bad);
|
||||||
(* And the bindings the package already wrote by hand, against the
|
(* And the bindings the package already wrote by hand, against the
|
||||||
header's own signatures. Nothing else in the build can do this: a
|
header's own signatures. Nothing else in the build can do this: a
|
||||||
wrong declare-c is wrong in the generated prototype too, so the two
|
wrong declare-c is wrong in the generated prototype too, so the two
|
||||||
@@ -339,13 +595,13 @@ let () =
|
|||||||
| _ :: "generate-c" :: dir :: _ ->
|
| _ :: "generate-c" :: dir :: _ ->
|
||||||
with_errors dir (fun () ->
|
with_errors dir (fun () ->
|
||||||
let loc = Flan.Loc.make dir 0 0 in
|
let loc = Flan.Loc.make dir 0 0 in
|
||||||
let out = Filename.concat dir "generated.flan" in
|
let out = Filename.concat dir "generated.fln" in
|
||||||
let ds =
|
let ds =
|
||||||
List.concat_map
|
List.concat_map
|
||||||
(fun f -> Flan.Parse.program (Flan.Reader.read_file f))
|
(fun f -> Flan.Parse.program (Flan.Source.read_file f))
|
||||||
(List.filter
|
(List.filter
|
||||||
(fun f -> not (String.equal f out))
|
(fun f -> not (String.equal f out))
|
||||||
(Flan.Load.entries dir ".flan"))
|
(Flan.Load.source_entries dir))
|
||||||
in
|
in
|
||||||
let config = Flan.Load.binding_config dir in
|
let config = Flan.Load.binding_config dir in
|
||||||
match Flan.Load.header_specs ~loc dir with
|
match Flan.Load.header_specs ~loc dir with
|
||||||
@@ -380,6 +636,16 @@ let () =
|
|||||||
(if x.Flan.Cimport.cmapping then "UNMAPPED" else "DISAGREES")
|
(if x.Flan.Cimport.cmapping then "UNMAPPED" else "DISAGREES")
|
||||||
x.Flan.Cimport.cname x.Flan.Cimport.cwhy)
|
x.Flan.Cimport.cname x.Flan.Cimport.cwhy)
|
||||||
r.Flan.Cimport.gconsts;
|
r.Flan.Cimport.gconsts;
|
||||||
|
(* [Cimport.regenerate] only knows the paren syntax; when [out] is a
|
||||||
|
.fln file the paren text it wrote is read back and reprinted
|
||||||
|
indented, the same translation `flan convert` does, so the
|
||||||
|
committed file reads like every other .fln in the package. *)
|
||||||
|
if r.Flan.Cimport.gwrote && Flan.Source.is_indented out then begin
|
||||||
|
let source = In_channel.with_open_bin out In_channel.input_all in
|
||||||
|
let forms = Flan.Reader.read_all ~file:out source in
|
||||||
|
let text = Flan.Indent_printer.program ~source forms in
|
||||||
|
Out_channel.with_open_bin out (fun ch -> Out_channel.output_string ch text)
|
||||||
|
end;
|
||||||
if r.Flan.Cimport.gwrote then
|
if r.Flan.Cimport.gwrote then
|
||||||
Printf.printf
|
Printf.printf
|
||||||
"wrote %s: %d declarations, %d refused, of %d functions in %s.\n\
|
"wrote %s: %d declarations, %d refused, of %d functions in %s.\n\
|
||||||
@@ -415,6 +681,39 @@ let () =
|
|||||||
"flan emit: --target is refused — the emitted IR carries no triple and \
|
"flan emit: --target is refused — the emitted IR carries no triple and \
|
||||||
no datalayout, and the target is chosen at build.";
|
no datalayout, and the target is chosen at build.";
|
||||||
exit 2
|
exit 2
|
||||||
|
(* --x86 prints the hand-written backend's assembly where the default prints
|
||||||
|
LLVM IR. The two are the same act — here is what this program compiles to,
|
||||||
|
before an assembler or an optimiser has touched it — and reading one
|
||||||
|
against the other is the only way to check a lowering by eye. --sanitize
|
||||||
|
is refused rather than ignored: ASan is an LLVM pass and this backend has
|
||||||
|
no arm for it, so honouring the flag is impossible and dropping it
|
||||||
|
silently would print something that is not what --sanitize builds. *)
|
||||||
|
| _ :: "emit" :: args
|
||||||
|
when List.mem x86_flag args && List.exists (fun a -> not (is_flag a)) args ->
|
||||||
|
if List.mem sanitize_flag args then begin
|
||||||
|
prerr_endline
|
||||||
|
"flan emit --x86: --sanitize is an LLVM pass and this backend has no \
|
||||||
|
arm for it — emit without --x86 to see what a sanitized build compiles.";
|
||||||
|
exit 2
|
||||||
|
end;
|
||||||
|
let checks = not (List.mem no_checks_flag args) in
|
||||||
|
let dev = List.mem dev_flag args in
|
||||||
|
let debug = List.mem debug_flag args in
|
||||||
|
(* The listing is annotated because a listing is what this command is for:
|
||||||
|
a person asked to see what their program compiles to, and a wall of
|
||||||
|
[.byte] with nothing saying which form produced which run answers the
|
||||||
|
letter of that and not the question. --no-annotate is here for the one
|
||||||
|
consumer that wants the bare spelling, which is the check that says
|
||||||
|
annotation changed no byte of the object. *)
|
||||||
|
let annotate = not (List.mem no_annotate_flag args) in
|
||||||
|
let files = List.filter (fun a -> not (is_flag a)) args in
|
||||||
|
List.iter
|
||||||
|
(fun path ->
|
||||||
|
with_errors path (fun () ->
|
||||||
|
checked path
|
||||||
|
|> Flan.X86.program ~checks ~dev ~debug ~annotate
|
||||||
|
|> print_string))
|
||||||
|
files
|
||||||
| _ :: "emit" :: args when List.exists (fun a -> not (is_flag a)) args ->
|
| _ :: "emit" :: args when List.exists (fun a -> not (is_flag a)) args ->
|
||||||
let checks = not (List.mem no_checks_flag args) in
|
let checks = not (List.mem no_checks_flag args) in
|
||||||
let dev = List.mem dev_flag args in
|
let dev = List.mem dev_flag args in
|
||||||
@@ -427,10 +726,14 @@ let () =
|
|||||||
List.iter
|
List.iter
|
||||||
(fun path ->
|
(fun path ->
|
||||||
with_errors path (fun () ->
|
with_errors path (fun () ->
|
||||||
let l = load path in
|
let l, p = Flan.Front.checked ~all:true path in
|
||||||
let pnames = if debug then param_names l else [] in
|
let pnames = if debug then param_names l else [] in
|
||||||
Flan.Check.program_all l.decls
|
(* Between checking and emission, and it hands the very same program
|
||||||
|> Flan.Emit.program ~checks ~dev ~debug ~pnames ~sanitize
|
on: the flag is a question asked of what was checked, never a
|
||||||
|
parameter of what is emitted. *)
|
||||||
|
if List.mem no_gc_flag args then Flan.Check.no_gc p;
|
||||||
|
Flan.Emit.program ~checks ~dev ~debug ~pnames ~sanitize
|
||||||
|
~annotate:(not (List.mem no_annotate_flag args)) p
|
||||||
|> print_string))
|
|> print_string))
|
||||||
files
|
files
|
||||||
| _ :: "build" :: path :: rest ->
|
| _ :: "build" :: path :: rest ->
|
||||||
@@ -438,7 +741,13 @@ let () =
|
|||||||
let dev = List.mem dev_flag rest in
|
let dev = List.mem dev_flag rest in
|
||||||
let debug = List.mem debug_flag rest in
|
let debug = List.mem debug_flag rest in
|
||||||
let sanitize = List.mem sanitize_flag rest in
|
let sanitize = List.mem sanitize_flag rest in
|
||||||
let x86 = List.mem x86_flag rest in
|
(* LLVM by default, and deliberately not moved when [flan dev] moved: a
|
||||||
|
release build is the one thing here that outlives the session, and the
|
||||||
|
argument [lib/x86.ml] rests on is exactly that a dev build is compiled
|
||||||
|
entirely by it and a release build entirely by LLVM. *)
|
||||||
|
let x86 = backend_x86 ~default:false rest in
|
||||||
|
let opt = opt_of rest in
|
||||||
|
check_opt_against_debug ~debug ~opt;
|
||||||
let target = target_of rest in
|
let target = target_of rest in
|
||||||
let out =
|
let out =
|
||||||
match List.filter (fun a -> not (is_flag a)) rest with
|
match List.filter (fun a -> not (is_flag a)) rest with
|
||||||
@@ -450,53 +759,146 @@ let () =
|
|||||||
(* A web build is three files — the page, its JS and the module — and
|
(* A web build is three files — the page, its JS and the module — and
|
||||||
the page is the one named here: emcc derives the other two from it,
|
the page is the one named here: emcc derives the other two from it,
|
||||||
and it is the one a browser opens. *)
|
and it is the one a browser opens. *)
|
||||||
|
(* The JS dialect's output is one file and it is source, so it is
|
||||||
|
named the way source is: node runs it by name. *)
|
||||||
(match target with
|
(match target with
|
||||||
| Some t when Flan.Build.is_web t -> base ^ ".html"
|
| Some t when Flan.Build.is_web t -> base ^ ".html"
|
||||||
|
| Some t when Flan.Build.is_js t -> base ^ ".js"
|
||||||
| Some t when String.starts_with ~prefix:"wasm32" t -> base ^ ".wasm"
|
| Some t when String.starts_with ~prefix:"wasm32" t -> base ^ ".wasm"
|
||||||
| _ -> base)
|
| _ -> base)
|
||||||
|
| _ when String.length path > 1 && path.[0] = '-' ->
|
||||||
|
Printf.eprintf
|
||||||
|
"flan build: the file comes before the flags, and %s is a flag. \
|
||||||
|
Write it after the file, as in: flan build prog.fln %s\n"
|
||||||
|
path (String.concat " " (List.filter (fun a -> is_flag a) (path :: rest)));
|
||||||
|
exit 2
|
||||||
| _ ->
|
| _ ->
|
||||||
prerr_endline
|
prerr_endline
|
||||||
"usage: flan build <file.flan> [-o out] [--no-bounds-checks] \
|
"usage: flan build <file.flan> [-o out] [-O0|-O1|-O2|-O3] \
|
||||||
[--dev] [--debug] [--sanitize] [--target=wasm32-wasi|web]";
|
[--no-bounds-checks] \
|
||||||
|
[--dev] [--debug] [--sanitize] [--x86|--llvm] [--no-gc] \
|
||||||
|
[--warn-memory] [--target=wasm32-wasi|web|js]";
|
||||||
exit 2
|
exit 2
|
||||||
in
|
in
|
||||||
with_errors path (fun () ->
|
with_errors path (fun () ->
|
||||||
let l = load path in
|
|
||||||
let p = Flan.Check.program_all l.decls in
|
|
||||||
(* The link follows the program, not the import list: a package nothing
|
(* The link follows the program, not the import list: a package nothing
|
||||||
reachable calls into contributes no C and no linker argument, and its
|
reachable calls into contributes no C and no linker argument, and its
|
||||||
functions are not emitted either. That is what lets one file import
|
functions are not emitted either. That is what lets one file import
|
||||||
raylib and still be buildable for wasm32. *)
|
raylib and still be buildable for wasm32. *)
|
||||||
let p, csrcs, lflags = Flan.Reach.link ~dev l p in
|
let f =
|
||||||
|
Flan.Front.linked ~all:true ~dev path ~before_link:(fun p ->
|
||||||
|
(* Before reachability rather than after: a dyn in a function
|
||||||
|
nothing calls is still a dyn somebody wrote, and a refusal that
|
||||||
|
depended on what [main] happened to reach would come and go as
|
||||||
|
the program was edited elsewhere. *)
|
||||||
|
if List.mem no_gc_flag rest then Flan.Check.no_gc p;
|
||||||
|
(* Before reachability too, and for the same reason: a push in a
|
||||||
|
function nothing calls is still a push somebody wrote. *)
|
||||||
|
if List.mem warn_memory_flag rest then
|
||||||
|
print_memory_warnings ~file:path p)
|
||||||
|
in
|
||||||
|
Flan.Build.need_main ~file:path ~doing:"flan build has nothing to link"
|
||||||
|
f.program;
|
||||||
ignore (Flan.Build.executable
|
ignore (Flan.Build.executable
|
||||||
~opts:{ Flan.Build.default with checks; dev; debug; sanitize;
|
~opts:{ Flan.Build.default with checks; dev; debug; sanitize;
|
||||||
target; x86 }
|
target; x86;
|
||||||
~csrcs ~lflags ~pnames:(if debug then param_names l else [])
|
opt = Option.value opt
|
||||||
p ~out))
|
~default:Flan.Build.default.Flan.Build.opt }
|
||||||
|
~csrcs:f.csrcs ~lflags:f.lflags
|
||||||
|
~pnames:(if debug then param_names f.load else [])
|
||||||
|
f.program ~out))
|
||||||
(* The daemon an editor talks to: one session, the program it belongs to
|
(* The daemon an editor talks to: one session, the program it belongs to
|
||||||
running beside it, and a socket. Unlike [flan reload] the session persists,
|
running beside it, and a socket. Unlike [flan reload] the session persists,
|
||||||
so a defvar added by one evaluation is part of what the next one is checked
|
so a defonce added by one evaluation is part of what the next one is checked
|
||||||
against — and it owns the build, which is what makes its layout rules
|
against — and it owns the build, which is what makes its layout rules
|
||||||
describe the process that is actually running. *)
|
describe the process that is actually running. *)
|
||||||
| _ :: "dev" :: path :: rest ->
|
(* With no file, an empty image: the prelude and nothing else, which files
|
||||||
|
are loaded into. The first word after [dev] is the file unless it is a
|
||||||
|
flag or the [-s] of a socket. *)
|
||||||
|
| _ :: "dev" :: args ->
|
||||||
|
let path, rest =
|
||||||
|
match args with
|
||||||
|
| p :: rest when p <> "-s" && not (is_flag p) -> (Some p, rest)
|
||||||
|
| rest -> (None, rest)
|
||||||
|
in
|
||||||
(* --debug builds the host *and* every module this daemon sends with DWARF,
|
(* --debug builds the host *and* every module this daemon sends with DWARF,
|
||||||
which is one flag because it is one decision: a line breakpoint in a
|
which is one flag because it is one decision: a line breakpoint in a
|
||||||
.flan buffer needs a line table on the host to fire at all, and one in
|
.flan buffer needs a line table on the host to fire at all, and one in
|
||||||
each redefinition module to still be firing after C-c C-c. It implies
|
each redefinition module to still be firing after C-c C-c. It implies
|
||||||
-O0 on both, so it is asked for rather than assumed. *)
|
-O0 on both, so it is asked for rather than assumed. *)
|
||||||
let debug = List.mem debug_flag rest in
|
let debug = List.mem debug_flag rest in
|
||||||
|
(* One decision for both halves of the session, which is what makes it safe
|
||||||
|
at all: the host and every module this daemon sends are compiled by the
|
||||||
|
same backend, because there is one place that says which. The two
|
||||||
|
conventions agree on every scalar and disagree on every aggregate, so a
|
||||||
|
crossed pair is correct until the first redefined function takes or
|
||||||
|
returns a struct — and [flan.abi.x86] refuses that pair at [dlopen] if
|
||||||
|
this is ever got wrong.
|
||||||
|
|
||||||
|
x86 by default, and this is the command where that is true. A dev
|
||||||
|
session is the thing the backend was written for: it turns the round
|
||||||
|
trip from 62ms to 28ms, and nothing it builds outlives the session, so
|
||||||
|
the subset it covers is a subset of one editor's afternoon rather than
|
||||||
|
of a shipped binary. [--llvm] is how to leave it — for a program it
|
||||||
|
refuses by name, and for [--debug].
|
||||||
|
|
||||||
|
[--debug] takes [--llvm]'s side on its own, because it is not a
|
||||||
|
preference: [X86.redefinition] emits no line table, so a [--debug]
|
||||||
|
session on this backend would set breakpoints that stop firing at the
|
||||||
|
first C-c C-c. Asking for the debugger is asking for the backend that
|
||||||
|
has one. Writing [--x86] as well still reaches [Dev.start]'s refusal,
|
||||||
|
which is the point of leaving it readable here — the combination stays
|
||||||
|
refused by name, it is just no longer somewhere you arrive by typing one
|
||||||
|
flag. *)
|
||||||
|
(* --sanitize takes [--llvm]'s side for the reason [--debug] does: the
|
||||||
|
sanitizers are LLVM passes. [--x86] written as well is refused by name
|
||||||
|
in [Dev.start]. *)
|
||||||
|
let sanitize = List.mem sanitize_flag rest in
|
||||||
|
let x86 = backend_x86 ~default:(not (debug || sanitize)) rest in
|
||||||
|
let asked_x86 = List.mem x86_flag rest in
|
||||||
let merged = not (List.mem two_process_flag rest) in
|
let merged = not (List.mem two_process_flag rest) in
|
||||||
let rest = List.filter (fun a -> not (is_flag a)) rest in
|
let rest = List.filter (fun a -> not (is_flag a)) rest in
|
||||||
let sock =
|
let sock =
|
||||||
match rest with
|
match rest with
|
||||||
| [ "-s"; s ] -> s
|
| [ "-s"; s ] -> s
|
||||||
| [] -> Filename.concat (Filename.dirname path) ".flan-dev.sock"
|
| [] ->
|
||||||
|
(match path with
|
||||||
|
| Some path -> Filename.concat (Filename.dirname path) ".flan-dev.sock"
|
||||||
|
(* An image has no program to sit beside, so its socket goes where
|
||||||
|
a user's runtime sockets go. *)
|
||||||
|
| None ->
|
||||||
|
let dir =
|
||||||
|
match Sys.getenv_opt "XDG_RUNTIME_DIR" with
|
||||||
|
| Some d when d <> "" && Sys.file_exists d -> d
|
||||||
|
| _ -> Filename.get_temp_dir_name ()
|
||||||
|
in
|
||||||
|
Filename.concat dir
|
||||||
|
(Printf.sprintf "flan-image-%d.sock" (Unix.getpid ())))
|
||||||
| _ ->
|
| _ ->
|
||||||
prerr_endline
|
prerr_endline
|
||||||
"usage: flan dev <program.flan> [-s socket] [--debug] [--two-process]";
|
"usage: flan dev [program.flan] [-s socket] [--debug] [--sanitize] \
|
||||||
|
[--llvm] [--two-process]";
|
||||||
exit 2
|
exit 2
|
||||||
in
|
in
|
||||||
with_errors path (fun () -> Flan.Dev.start ~debug ~merged ~file:path ~sock ())
|
(* Only this command hands one over, and only when it chose the backend
|
||||||
|
itself. A refusal from a session nobody asked to be on this backend is
|
||||||
|
one flag away from building, and the flag is the half of the sentence
|
||||||
|
[X86.unsupported] cannot know to write. *)
|
||||||
|
let x86_hint =
|
||||||
|
if x86 && not asked_x86 then
|
||||||
|
Some
|
||||||
|
"flan dev: the x86 backend is the default for a dev session because \
|
||||||
|
it is about twice as fast, and it does not compile every program. \
|
||||||
|
Start this one with flan dev --llvm."
|
||||||
|
else None
|
||||||
|
in
|
||||||
|
(match path with
|
||||||
|
| Some path ->
|
||||||
|
with_errors ?x86_hint path (fun () ->
|
||||||
|
Flan.Dev.start ~debug ~sanitize ~merged ~x86 ~file:path ~sock ())
|
||||||
|
| None ->
|
||||||
|
with_errors ?x86_hint "" (fun () ->
|
||||||
|
Flan.Dev.start_image ~debug ~sanitize ~merged ~x86 ~sock ()))
|
||||||
|
|
||||||
(* One redefinition, built the way an editor will ask for it: a session over
|
(* One redefinition, built the way an editor will ask for it: a session over
|
||||||
the program the process was built from, and a file of the forms that
|
the program the process was built from, and a file of the forms that
|
||||||
@@ -505,6 +907,12 @@ let () =
|
|||||||
given only a list of function names could. *)
|
given only a list of function names could. *)
|
||||||
| _ :: "reload" :: prog :: forms :: rest ->
|
| _ :: "reload" :: prog :: forms :: rest ->
|
||||||
let debug = List.mem debug_flag rest in
|
let debug = List.mem debug_flag rest in
|
||||||
|
(* The same flag, for the same reason, and it had to arrive with [flan
|
||||||
|
dev]'s: a command that could build a module for a host the other backend
|
||||||
|
compiled is how the crossed pair was reachable from the CLI at all.
|
||||||
|
Building an --x86 host with [flan build --x86 --dev] and then reloading
|
||||||
|
into it now has a spelling that produces a module it can load. *)
|
||||||
|
let x86 = backend_x86 ~default:false rest in
|
||||||
let rest = List.filter (fun a -> not (is_flag a)) rest in
|
let rest = List.filter (fun a -> not (is_flag a)) rest in
|
||||||
let out =
|
let out =
|
||||||
match rest with
|
match rest with
|
||||||
@@ -512,17 +920,25 @@ let () =
|
|||||||
| [] -> Filename.remove_extension (Filename.basename forms) ^ ".so"
|
| [] -> Filename.remove_extension (Filename.basename forms) ^ ".so"
|
||||||
| _ ->
|
| _ ->
|
||||||
prerr_endline
|
prerr_endline
|
||||||
"usage: flan reload <program.flan> <forms.flan> [-o out.so] [--debug]";
|
"usage: flan reload <program.flan> <forms.flan> [-o out.so] \
|
||||||
|
[--debug] [--x86]";
|
||||||
exit 2
|
exit 2
|
||||||
in
|
in
|
||||||
with_errors forms (fun () ->
|
with_errors forms (fun () ->
|
||||||
let t, _ = Flan.Session.create ~debug ~file:prog () in
|
let t, _ = Flan.Session.create ~debug ~x86 ~file:prog () in
|
||||||
let src = In_channel.with_open_bin forms In_channel.input_all in
|
let src = In_channel.with_open_bin forms In_channel.input_all in
|
||||||
let c = Flan.Session.eval ~origin:forms t src in
|
let c = Flan.Session.eval ~origin:forms t src in
|
||||||
let opts = { Flan.Build.default with dev = true; debug } in
|
let opts = { Flan.Build.default with dev = true; debug; x86 } in
|
||||||
let timing = Flan.Build.shared ~opts ~ir:c.Flan.Session.ir ~out () in
|
let timing =
|
||||||
Printf.eprintf "%s %s llc %.1fms ld %.1fms\n" out
|
if c.Flan.Session.x86 then
|
||||||
(String.concat " " c.Flan.Session.fns) timing.Flan.Build.llc_ms
|
Flan.Build.shared_x86 ~opts ~asm:c.Flan.Session.ir ~out ()
|
||||||
|
else Flan.Build.shared ~opts ~ir:c.Flan.Session.ir ~out ()
|
||||||
|
in
|
||||||
|
(* [as] where the other path has [llc], which is the number the whole
|
||||||
|
backend exists to move. Named for what ran. *)
|
||||||
|
Printf.eprintf "%s %s %s %.1fms ld %.1fms\n" out
|
||||||
|
(String.concat " " (Flan.Session.shown_fns c))
|
||||||
|
(if x86 then "as " else "llc") timing.Flan.Build.llc_ms
|
||||||
timing.Flan.Build.link_ms)
|
timing.Flan.Build.link_ms)
|
||||||
(* [run] builds and execs. A .wasm is not executable, and picking a runtime
|
(* [run] builds and execs. A .wasm is not executable, and picking a runtime
|
||||||
for it is a decision this command has no business making, so a cross
|
for it is a decision this command has no business making, so a cross
|
||||||
@@ -533,28 +949,114 @@ let () =
|
|||||||
this host can exec. Use flan build --target=... and a wasm runtime.";
|
this host can exec. Use flan build --target=... and a wasm runtime.";
|
||||||
exit 2
|
exit 2
|
||||||
| _ :: "run" :: path :: args ->
|
| _ :: "run" :: path :: args ->
|
||||||
|
(* One command, two argument lists, and until now no rule saying which was
|
||||||
|
which: [flan run game.flan --debug] built at -O2 and handed the game a
|
||||||
|
[--debug] it had never heard of. Nothing reported that, because neither
|
||||||
|
side thought it had been given anything wrong.
|
||||||
|
|
||||||
|
The rule, in one line: a build flag is the build's, [--] ends the build
|
||||||
|
flags, and everything after [--] is the program's whatever it looks
|
||||||
|
like. Before [--], an argument that starts with a dash and is not a
|
||||||
|
build flag this command offers is refused by name — not guessed at,
|
||||||
|
because guessing is the failure this exists to stop, and a program of
|
||||||
|
one's own that wants [-v] has [--] to ask for it. Plain arguments need
|
||||||
|
no ceremony: they were never ambiguous and they still go straight
|
||||||
|
through, so [flan run calc-me.flan "1+2"] is unchanged. *)
|
||||||
|
(* --dev is deliberately not on this list, and its absence is the point:
|
||||||
|
a dev build's indirection cells exist so that something can attach and
|
||||||
|
redefine through them, and nothing can attach to a process this command
|
||||||
|
builds, execs, waits for and deletes. Leaving it off means it lands in
|
||||||
|
the refusal below with a sentence, rather than quietly producing a
|
||||||
|
spelling [Build] says does not exist — [flan build]'s --x86 arm records
|
||||||
|
that `flan dev` never reaches its fork because --x86 is read only by
|
||||||
|
[flan build], and an --x86 --dev route through here would have made that
|
||||||
|
sentence false. *)
|
||||||
|
let run_flags =
|
||||||
|
[ no_checks_flag; debug_flag; sanitize_flag; x86_flag; llvm_flag ]
|
||||||
|
@ opt_levels
|
||||||
|
in
|
||||||
|
let build_args, prog_args =
|
||||||
|
let rec split acc = function
|
||||||
|
| "--" :: rest -> (List.rev acc, rest)
|
||||||
|
| a :: rest when String.length a > 1 && a.[0] = '-' ->
|
||||||
|
if List.mem a run_flags then split (a :: acc) rest
|
||||||
|
else begin
|
||||||
|
prerr_endline
|
||||||
|
("flan run: " ^ a
|
||||||
|
^ " is not a flag this command offers, and it will not be \
|
||||||
|
guessed at — a build flag belongs to the build and \
|
||||||
|
anything else belongs to the program. Write it after -- to \
|
||||||
|
send it to the program: flan run "
|
||||||
|
^ Filename.basename path ^ " -- " ^ a);
|
||||||
|
exit 2
|
||||||
|
end
|
||||||
|
| a :: rest -> let l, r = split acc rest in (l, a :: r)
|
||||||
|
| [] -> (List.rev acc, [])
|
||||||
|
in
|
||||||
|
split [] args
|
||||||
|
in
|
||||||
|
let checks = not (List.mem no_checks_flag build_args) in
|
||||||
|
let debug = List.mem debug_flag build_args in
|
||||||
|
let sanitize = List.mem sanitize_flag build_args in
|
||||||
|
let x86 = backend_x86 ~default:false build_args in
|
||||||
|
let opt = opt_of build_args in
|
||||||
|
check_opt_against_debug ~debug ~opt;
|
||||||
with_errors path (fun () ->
|
with_errors path (fun () ->
|
||||||
let exe =
|
let exe =
|
||||||
Filename.concat (Filename.get_temp_dir_name ())
|
Filename.concat (Filename.get_temp_dir_name ())
|
||||||
(Printf.sprintf "flan-run-%d" (Unix.getpid ()))
|
(Printf.sprintf "flan-run-%d" (Unix.getpid ()))
|
||||||
in
|
in
|
||||||
let l = load path in
|
let f = Flan.Front.linked ~all:true path in
|
||||||
let p = Flan.Check.program_all l.decls in
|
Flan.Build.need_main ~file:path ~doing:"flan run has nothing to run"
|
||||||
let p, csrcs, lflags = Flan.Reach.link l p in
|
f.program;
|
||||||
ignore (Flan.Build.executable ~csrcs ~lflags p ~out:exe);
|
ignore (Flan.Build.executable
|
||||||
let code =
|
~opts:{ Flan.Build.default with checks; debug; sanitize;
|
||||||
Sys.command (String.concat " " (List.map Filename.quote (exe :: args)))
|
x86;
|
||||||
|
opt = Option.value opt
|
||||||
|
~default:Flan.Build.default.Flan.Build.opt }
|
||||||
|
~csrcs:f.csrcs ~lflags:f.lflags
|
||||||
|
~pnames:(if debug then param_names f.load else [])
|
||||||
|
f.program ~out:exe);
|
||||||
|
(* Spawned and waited on here rather than through [Sys.command], so a
|
||||||
|
SIGTERM or SIGHUP sent to flan reaches the program and flan still
|
||||||
|
removes the executable and its work directory: the default action
|
||||||
|
would end flan inside the wait with neither removed. SIGINT and
|
||||||
|
SIGQUIT are ignored while the program runs, as [system] does, since
|
||||||
|
the terminal sends them to the program too. A flan killed outright
|
||||||
|
takes the program with it ([Spawn.dying]). *)
|
||||||
|
let pid = Flan.Spawn.dying exe (Array.of_list (exe :: prog_args)) in
|
||||||
|
let caught = ref None in
|
||||||
|
let forward s =
|
||||||
|
Sys.Signal_handle (fun _ ->
|
||||||
|
caught := Some s;
|
||||||
|
try Unix.kill pid s with Unix.Unix_error _ -> ())
|
||||||
in
|
in
|
||||||
|
Sys.set_signal Sys.sigterm (forward Sys.sigterm);
|
||||||
|
Sys.set_signal Sys.sighup (forward Sys.sighup);
|
||||||
|
Sys.set_signal Sys.sigint Sys.Signal_ignore;
|
||||||
|
Sys.set_signal Sys.sigquit Sys.Signal_ignore;
|
||||||
|
let rec wait () =
|
||||||
|
match Unix.waitpid [] pid with
|
||||||
|
| _, Unix.WEXITED c -> c
|
||||||
|
| _, (Unix.WSIGNALED s | Unix.WSTOPPED s) -> 128 + Flan.Spawn.host_signal s
|
||||||
|
| exception Unix.Unix_error (Unix.EINTR, _, _) -> wait ()
|
||||||
|
in
|
||||||
|
let code = wait () in
|
||||||
(try Sys.remove exe with Sys_error _ -> ());
|
(try Sys.remove exe with Sys_error _ -> ());
|
||||||
exit code)
|
exit (match !caught with
|
||||||
|
| Some s when s = Sys.sigterm -> 143
|
||||||
|
| Some _ -> 129
|
||||||
|
| None -> code))
|
||||||
| _ ->
|
| _ ->
|
||||||
prerr_endline
|
prerr_endline
|
||||||
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n\
|
"usage: flan (read|parse|check|emit|shim) <file.flan>...\n flan check <file.flan>... [--warn-memory] [--defs]\n flan copies <file.fln> <generic>\n flan emit <file.flan> [--x86] [--dev] [--debug] [--no-bounds-checks]\n\
|
||||||
\ flan import-c <header.h> [package.flan...] [clang flags...]\n\
|
\ flan import-c <header.h> [package.flan...] [clang flags...]\n\
|
||||||
\ flan generate-c <package-dir>\n\
|
\ flan generate-c <package-dir>\n\
|
||||||
\ flan build <file.flan> [-o out] [--no-bounds-checks] [--dev] \
|
\ flan build <file.flan> [-o out] [-O0|-O1|-O2|-O3] \
|
||||||
[--debug] [--sanitize] [--x86] [--target=wasm32-wasi|web]\n\
|
[--no-bounds-checks] [--dev] \
|
||||||
\ flan run <file.flan> [args...]\n\
|
[--debug] [--sanitize] [--x86] [--warn-memory] [--target=wasm32-wasi|web|js]\n\
|
||||||
\ flan reload <program.flan> <forms.flan> [-o out.so]\n\
|
\ flan run <file.flan> [build flags...] [--] [program args...]\n\
|
||||||
\ flan dev <program.flan> [-s socket]";
|
\ flan reload <program.flan> <forms.flan> [-o out.so] [--x86]\n\
|
||||||
|
\ flan dev [program.flan] [-s socket] [--x86]\n\
|
||||||
|
\ flan convert <file.flan|file.fln>";
|
||||||
exit 2
|
exit 2
|
||||||
+17
-16
@@ -4,8 +4,9 @@
|
|||||||
;;;; 3.5
|
;;;; 3.5
|
||||||
;;;;
|
;;;;
|
||||||
;;;; Chosen to be the smallest program that is still a real one. What it needs:
|
;;;; Chosen to be the smallest program that is still a real one. What it needs:
|
||||||
;;;; functions, recursion, structs, (Ptr T) and `addr`, byte slices, `at`/`len`,
|
;;;; functions, recursion, structs, (Ptr T) and `addr`, byte slices,
|
||||||
;;;; `while`, `set` on locals and on fields, `cond`, `match`, Option, i32/u8/f64,
|
;;;; `at`/`length`, `while`, `set` on locals and on fields, `cond`, `match`,
|
||||||
|
;;;; Option, i32/u8/f64,
|
||||||
;;;; and argv. What it deliberately does NOT need: an allocator, Vec, Map, any
|
;;;; and argv. What it deliberately does NOT need: an allocator, Vec, Map, any
|
||||||
;;;; generic function, any macro the user wrote, FFI beyond argv and stdout,
|
;;;; generic function, any macro the user wrote, FFI beyond argv and stdout,
|
||||||
;;;; a window, or a frame loop. It runs headless, so it is the same test on
|
;;;; a window, or a frame loop. It runs headless, so it is the same test on
|
||||||
@@ -19,11 +20,11 @@
|
|||||||
;; ── one by pointer. `addr` takes the address of a local; the pointer never
|
;; ── one by pointer. `addr` takes the address of a local; the pointer never
|
||||||
;; ── outlives the frame, so no allocator is involved.
|
;; ── outlives the frame, so no allocator is involved.
|
||||||
(defstruct Cursor
|
(defstruct Cursor
|
||||||
[src [u8] ; non-owning slice into argv — calc-me never owns a byte
|
[src [const u8] ; non-owning slice into argv — calc-me never owns a byte
|
||||||
pos i32]) ; no initialiser means zeroed
|
pos i32]) ; no initialiser means zeroed
|
||||||
|
|
||||||
(defn peek [c (Ptr Cursor)] u8
|
(defn peek [c (Ptr Cursor)] u8
|
||||||
(if (< (.pos c) (len (.src c)))
|
(if (< (.pos c) (length (.src c)))
|
||||||
(at (.src c) (.pos c))
|
(at (.src c) (.pos c))
|
||||||
0)) ; 0 doubles as end-of-input
|
0)) ; 0 doubles as end-of-input
|
||||||
|
|
||||||
@@ -34,20 +35,20 @@
|
|||||||
(while (= (peek c) \space)
|
(while (= (peek c) \space)
|
||||||
(advance c)))
|
(advance c)))
|
||||||
|
|
||||||
;; digit? was written here until the prelude grew one. There is a single
|
;; is-digit was written here until the prelude grew one. There is a single
|
||||||
;; top-level namespace, so a second definition is now an error rather than a
|
;; top-level namespace, so a second definition is now an error rather than a
|
||||||
;; shadow — which is the rule working: two byte-identical digit? functions
|
;; shadow — which is the rule working: two byte-identical is-digit functions
|
||||||
;; that later drift apart is exactly what it exists to prevent.
|
;; that later drift apart is exactly what it exists to prevent.
|
||||||
|
|
||||||
;; ── number := digit+ ("." digit+)? ────────────────────────────────────
|
;; ── number := digit+ ("." digit+)? ────────────────────────────────────
|
||||||
(defn parse-number [c (Ptr Cursor)] (Option f64)
|
(defn parse-number [c (Ptr Cursor)] (Option f64)
|
||||||
(skip-spaces c)
|
(skip-spaces c)
|
||||||
(let [start (.pos c)]
|
(let [start (.pos c)]
|
||||||
(while (digit? (peek c))
|
(while (is-digit (peek c))
|
||||||
(advance c))
|
(advance c))
|
||||||
(when (= (peek c) \.)
|
(when (= (peek c) \.)
|
||||||
(advance c)
|
(advance c)
|
||||||
(while (digit? (peek c))
|
(while (is-digit (peek c))
|
||||||
(advance c)))
|
(advance c)))
|
||||||
(if (= start (.pos c))
|
(if (= start (.pos c))
|
||||||
None
|
None
|
||||||
@@ -104,7 +105,7 @@
|
|||||||
(Some lhs)))
|
(Some lhs)))
|
||||||
|
|
||||||
;; ── Whole input, or nothing. Trailing junk is an error, not ignored. ──
|
;; ── Whole input, or nothing. Trailing junk is an error, not ignored. ──
|
||||||
(defn evaluate [src [u8]] (Option f64)
|
(defn evaluate [src [const u8]] (Option f64)
|
||||||
(let [c (Cursor {.src src})] ; pos omitted: zeroed
|
(let [c (Cursor {.src src})] ; pos omitted: zeroed
|
||||||
(let [v (some (parse-expr (addr c) 1))]
|
(let [v (some (parse-expr (addr c) 1))]
|
||||||
(skip-spaces (addr c))
|
(skip-spaces (addr c))
|
||||||
@@ -114,12 +115,12 @@
|
|||||||
|
|
||||||
;; Entry point: (defn main [args [string]] i32). Both the parameter and the
|
;; Entry point: (defn main [args [string]] i32). Both the parameter and the
|
||||||
;; return type are optional — sand.flan uses the bare (defn main []) form.
|
;; return type are optional — sand.flan uses the bare (defn main []) form.
|
||||||
;; print and println are compiler-provided and structural: the walk over the
|
;; print and prin are compiler-provided and structural: the walk over the
|
||||||
;; argument's concrete type happens at compile time, so there is nothing to
|
;; argument's concrete type happens at compile time, so there is nothing to
|
||||||
;; dispatch on at run time and no type to name at the call site.
|
;; dispatch on at run time and no type to name at the call site.
|
||||||
(defn main [args [string]] i32
|
(defn main [args [str]] i32
|
||||||
(if (< (len args) 2)
|
(if (< (length args) 2)
|
||||||
(do (println "usage: calc-me \"1 + 2 * 3\"") 1)
|
(do (print "usage: calc-me \"1 + 2 * 3\"") 1)
|
||||||
(match (evaluate (bytes (at args 1)))
|
(match (evaluate (bytes-view (at args 1)))
|
||||||
(Some v) (do (print v) (println "") 0)
|
(Some v) (do (prin v) (print "") 0)
|
||||||
None (do (println "calc-me: cannot parse") 1))))
|
None (do (print "calc-me: cannot parse") 1))))
|
||||||
@@ -10,8 +10,8 @@
|
|||||||
|
|
||||||
;;; Handlers cannot see the establishing function's locals yet, so anything a
|
;;; Handlers cannot see the establishing function's locals yet, so anything a
|
||||||
;;; handler accumulates into has to be a global.
|
;;; handler accumulates into has to be a global.
|
||||||
(defvar seen i64)
|
(defonce seen i64)
|
||||||
(defvar ticks i64)
|
(defonce ticks i64)
|
||||||
|
|
||||||
;;; Two frames under the restart-case, so a transfer has something to cross.
|
;;; Two frames under the restart-case, so a transfer has something to cross.
|
||||||
(defn probe [n i32] i32
|
(defn probe [n i32] i32
|
||||||
@@ -30,16 +30,16 @@
|
|||||||
(retry [] 7)))
|
(retry [] 7)))
|
||||||
|
|
||||||
(defn run-once [] ()
|
(defn run-once [] ()
|
||||||
(print (fetch 1)) (println "")
|
(prin (fetch 1)) (print "")
|
||||||
|
|
||||||
(handler-bind [(AssetMissing [c] (set seen (+ seen (i64 (.id c)))))]
|
(handler-bind [(AssetMissing [c] (set seen (+ seen (i64 (.id c)))))]
|
||||||
(print (fetch 2)) (println ""))
|
(prin (fetch 2)) (print ""))
|
||||||
|
|
||||||
(handler-bind [(AssetMissing [c] (invoke-restart 'use-placeholder))]
|
(handler-bind [(AssetMissing [c] (invoke-restart 'use-placeholder))]
|
||||||
(print (fetch 3)) (println ""))
|
(prin (fetch 3)) (print ""))
|
||||||
|
|
||||||
(print seen) (println "")
|
(prin seen) (print "")
|
||||||
(print ticks) (println ""))
|
(prin ticks) (print ""))
|
||||||
|
|
||||||
(defn main [] i32
|
(defn main [] i32
|
||||||
(agent/start "/tmp/flan-conditions.sock")
|
(agent/start "/tmp/flan-conditions.sock")
|
||||||
|
|||||||
+14
-1
@@ -10,7 +10,7 @@ Why it is shaped this way: [[file:spec-conditions.md][spec-conditions.md]]. Some
|
|||||||
(signal c) ; (). Handler returns -> carry on. No handler -> no-op.
|
(signal c) ; (). Handler returns -> carry on. No handler -> no-op.
|
||||||
(error c) ; Never. Only a transfer gets past; else the program stops.
|
(error c) ; Never. Only a transfer gets past; else the program stops.
|
||||||
|
|
||||||
(handler-bind [(Type [c] body ...) ...] body ...) ; match by type, no hierarchy
|
(handler-bind [(Type [c] body ...) ...] body ...) ; match by type or a parent's
|
||||||
|
|
||||||
(restart-case BODY ; BODY and every clause have the same type = the form's
|
(restart-case BODY ; BODY and every clause have the same type = the form's
|
||||||
(name [p T ...] CLAUSE) ...)
|
(name [p T ...] CLAUSE) ...)
|
||||||
@@ -102,6 +102,19 @@ the agent's socket instead.
|
|||||||
~BoundsError~ rather than ending the process, abandoning a frame and retrying
|
~BoundsError~ rather than ending the process, abandoning a frame and retrying
|
||||||
it is a real thing to do, and a non-idempotent mutation is what makes it go
|
it is a real thing to do, and a non-idempotent mutation is what makes it go
|
||||||
wrong.
|
wrong.
|
||||||
|
- *Four conditions come from below your program*, all with ~error~:
|
||||||
|
~StorageExhausted~ when an allocator cannot satisfy a request, ~FileError~
|
||||||
|
when a file operation fails, ~BoundsError~ for an index or slice outside its
|
||||||
|
container, and ~ArithError~ for arithmetic with no answer — a divide or
|
||||||
|
remainder by zero, ~INT64_MIN / -1~, and a float-to-integer cast that does not
|
||||||
|
fit, each of which used to be a bare ~SIGFPE~ with no message and no location.
|
||||||
|
The first two offer a ~retry~ at the failing site, because freeing something
|
||||||
|
or supplying another path makes the same operation succeed. The last two offer
|
||||||
|
*nothing*: no handler makes index 51 valid for a length-50 array or gives a
|
||||||
|
division by zero a quotient, so there is nothing to resume into. The restart
|
||||||
|
that answers those is the one your program already established — the frame
|
||||||
|
loop's ~continue~ — and it is on the stack and reachable without anything
|
||||||
|
being pushed at the failure.
|
||||||
- *An unknown restart name is a hard stop.* No ~find-restart~ to test with.
|
- *An unknown restart name is a hard stop.* No ~find-restart~ to test with.
|
||||||
- *So are the wrong arguments*, and for the same reason: nothing static can
|
- *So are the wrong arguments*, and for the same reason: nothing static can
|
||||||
know what a name will find. The message names both signatures.
|
know what a name will find. The message names both signatures.
|
||||||
|
|||||||
@@ -0,0 +1,169 @@
|
|||||||
|
# Bug hunt, 2026-09-18
|
||||||
|
|
||||||
|
Five search agents swept the runtime, checker, backends, dev loop, and Emacs client.
|
||||||
|
Everything below was either executed to failure or traced to the exact line. The five
|
||||||
|
marked **DISPATCHED** have fix lanes; the rest are recorded here and wait.
|
||||||
|
|
||||||
|
## Dispatched
|
||||||
|
|
||||||
|
### 1. `borrowed` grants the borrow flag to whole subtrees — moves inside container targets vanish
|
||||||
|
**Repealed, not fixed (2026-09-18):** the flow analysis this hole lived in was removed wholesale
|
||||||
|
(spec-memory.md, "The repeal"). The trigger programs now compile by design and misbehave at run time.
|
||||||
|
`lib/check.ml:2062-2076`. The flag gates both `moved` (2003) and `global_borrow` (2033),
|
||||||
|
and is set across the entire checking of the target: the index argument of `at`, the base
|
||||||
|
of any `Field`. A move nested there is never recorded.
|
||||||
|
|
||||||
|
Confirmed by execution, two programs:
|
||||||
|
- `(print (at rows (eat w)))` then `(free w)` — double free, exit 134.
|
||||||
|
- Same shape with a move-only global `g`: accepted, `g` freed, `(length g)` reads a freed
|
||||||
|
header, exit 0 silent. Defeats the rule test/test_flan.ml:1067-1068 pins.
|
||||||
|
|
||||||
|
Fix direction: narrow the flag to the target's own read — restore `ctx.borrow` for the
|
||||||
|
index of `at`; treat `Field` as simple only when its base chain bottoms out at a `Var`.
|
||||||
|
|
||||||
|
### 2. A `while` condition is move-checked outside `in_loop` — double free on iteration two
|
||||||
|
**Fixed, then repealed (2026-09-18):** the fix merged (47cb46a) and was removed the same day with the
|
||||||
|
whole flow analysis. The trigger compiles and aborts in the allocator at run time, by design.
|
||||||
|
`lib/check.ml:1688-1691`. The condition is checked before `in_loop` is entered, but
|
||||||
|
emit re-runs it every trip (`emit.ml:1838`). A condition that moves a local frees it
|
||||||
|
once per iteration. Confirmed: glibc double-free abort, exit 134.
|
||||||
|
`dotimes`' count (2504) and `loop`'s inits (2561) are also outside but evaluate once — correct.
|
||||||
|
Fix: check the condition inside `in_loop`.
|
||||||
|
|
||||||
|
### 3. A checked declaration that fails to build or deliver leaves a NULL cell the session will call
|
||||||
|
`lib/session.ml:601` commits `t.program` before `Dev.eval` builds (`dev.ml:603` can raise)
|
||||||
|
or delivers (`dev.ml:596` can refuse — e.g. queue full at `vendor/agent/flan_agent.c:1186`,
|
||||||
|
which a parked program guarantees after 64 installs since nothing drains the ring while
|
||||||
|
parked). The session keeps the declaration; the process never got the body; the next
|
||||||
|
thunk's install prologue interns the name with `cell = NULL` (`runtime/flan_dev.c:65`)
|
||||||
|
and `body_of` calls through it with no null test (`emit.ml:1472`) — jump to address 0
|
||||||
|
on the game thread. Nearest reachable mechanism to the transient SIGSEGV of TODO.org,
|
||||||
|
"A transient signal 11 on a globals daemon"; the
|
||||||
|
stranded-Vec hypothesis there was read out and refuted (reloads never redefine a host
|
||||||
|
global; storage addresses are stable; `global_borrow` holds).
|
||||||
|
Related, same lane: the queue-full refusal says "the program is not calling agent/poll",
|
||||||
|
which is the wrong cause for a parked program.
|
||||||
|
|
||||||
|
### 4. The merged build never drains the program's stdout pipe while serving a request
|
||||||
|
fd 1 is a 64K pipe whose only reader is `accept_loop`'s select (`lib/dev.ml:2739`), not
|
||||||
|
running while `serve` handles a request. `eval_expr`'s wait (664-672) and
|
||||||
|
`run_render_thunk`'s wait (1026-1036) poll for five seconds and never drain, so a
|
||||||
|
program that prints (sand.flan does) blocks in `flan_write_stdout`, stalls the frame
|
||||||
|
thread for the whole timeout, and gets the false diagnostic "is it calling (agent/poll)?".
|
||||||
|
Same root on the exit path: `flan_merged_exit`/`park` `fflush(NULL)` before
|
||||||
|
`program_state = PROGRAM_PARKED` (dev.ml:3000/3017/3024), so a full pipe delays the park
|
||||||
|
and `rerun` refuses a finished program as "already running".
|
||||||
|
Also same family: `rt_die` (`runtime/flan_rt.c:384-388`) starts with `fflush(stdout)` —
|
||||||
|
a bounds trap can hang on the full pipe — and calls `exit(134)`, the route `die_now`
|
||||||
|
documents as unsafe (atexit/ELF destructors want the loader lock a dlopening thread may
|
||||||
|
hold); it should `_exit` like the break loop does.
|
||||||
|
|
||||||
|
### 5. x86 shifts are always 64-bit, so the count is masked to 63 instead of width−1
|
||||||
|
`lib/x86.ml:2530-2534` / `shift_cl` at 369 (`rex ~w:true` unconditionally). The comment
|
||||||
|
claims the hardware masks to operand width; it masks to 63. `emit.ml:2041` masks to
|
||||||
|
`bits-1` explicitly (TODO.org, "A shift count is bounded two different ways", records
|
||||||
|
this as the language's rule). Six
|
||||||
|
confirmed divergences, e.g. `(<< x 32)` on i32: LLVM 1, x86 0; `(>> i8min 8)`: LLVM
|
||||||
|
-128, x86 -1. Invisible because `test/survey-x86.sh:80` never globs `spike/js/*.flan`,
|
||||||
|
where `p1-int-semantics.flan` already catches it — widen the glob in the same lane.
|
||||||
|
Same wide-compute root, second divergence: float→int overflow under `--no-bounds-checks`
|
||||||
|
gives 0 on x86 (64-bit `cvttsd2si` then truncate) vs INT_MIN on LLVM. Acknowledged-UB
|
||||||
|
territory; fix or record, the lane's call.
|
||||||
|
|
||||||
|
## Recorded, not scheduled
|
||||||
|
|
||||||
|
- **Region guard never asks about elements** — **repealed, not fixed (2026-09-18)**: with the flow
|
||||||
|
analysis gone, `free` of an `at` result is no longer a checker question; the mixed-allocator
|
||||||
|
construction is legal and its misuse is a run-time matter. (`lib/check.ml:1272`, refusals 4092/4165):
|
||||||
|
a heap-backed inner Vec pushed into an arena-backed outer passes the guard; `at` then
|
||||||
|
hands out an owning header, `free` accepts it, and the later read is a confirmed UAF
|
||||||
|
(printed garbage). Breaks the premise stated in the clone note at check.ml:4152.
|
||||||
|
Candidate fixes: refuse `free` of a non-binding target, or region-check the element at
|
||||||
|
`push`/`put`. Sixth on the list; needs a deliberate mixed-allocator construction.
|
||||||
|
- **Reversed slice under `--no-bounds-checks`** — **fixed**. The `lo <= hi` test is a
|
||||||
|
representation invariant, not a bounds check, but sat behind `if f.md.checks` in both
|
||||||
|
backends (`emit.ml:1037`, `x86.ml:2164`; same for SliceFromPtr's `n >= 0`), so a
|
||||||
|
negative-length slice reached user code. Split in both backends: `hi <= len` stays
|
||||||
|
behind the flag, `lo <= hi` and `n >= 0` are now emitted in every build, through the
|
||||||
|
same slice-failure path. `flan_vec_as_slice` was the model. See "A slice's length word
|
||||||
|
is a count" in docs/BUILT.md.
|
||||||
|
- ~~**`reg leaks` lies at >3072 live blocks**~~ — **fixed**. Compaction now also asks
|
||||||
|
whether there is an eighth of a table's worth of dead to reclaim, so a table full of
|
||||||
|
live blocks stops thrashing the epoch; `flan_dev_reg_by_type` returns −1 with an unread
|
||||||
|
count rather than zero rows, and the agent refuses in a sentence; a note dropped by a
|
||||||
|
genuinely full table says so on stderr once. `test/dev_limits.c regfull` pins it under
|
||||||
|
a writer thread: 3100 live blocks, 200 asks, 199 wrong before and 200 right after.
|
||||||
|
- **Emacs framing**: a truncated frame raises wrong-type instead of the timeout message
|
||||||
|
and leaves the partial frame in the buffer, desyncing every later request by one frame
|
||||||
|
(`flan-dev.el:220`); `extract-reply` reads before it deletes, so an unreadable payload
|
||||||
|
wedges the connection permanently (:187). One ordering fix covers both.
|
||||||
|
- **Emacs poll vs watch**: `flan-dev--poll` bypasses `flan-dev-settle-hook` and consumes
|
||||||
|
the watch's reply; the two consumers stay swapped for the session (`flan-dev.el:406`).
|
||||||
|
Also `request` reconnects before running the settle hook — 30s freeze after a daemon
|
||||||
|
restart with the watch armed.
|
||||||
|
- **C-x C-e at point-min** installs an empty declaration (`flan-dev.el:1745`
|
||||||
|
`backward-sexp` no-op unchecked); same predicate fires inside strings and misjudges
|
||||||
|
narrowed buffers.
|
||||||
|
- **`flan-connect` + `flan-dev-quit` kill two sessions** (`flan-dev.el:721`): quit sends
|
||||||
|
`close` down the current connection and kills the daemon it started for another program.
|
||||||
|
- ~~**`reg at` TOCTOU**~~ — FIXED. The gate was checked three round trips before the
|
||||||
|
render thunk ran, and nothing held the break across the ~300ms build, so a `restart`
|
||||||
|
in between let the thunk chase freed memory with the gate's blessing. The sound fix is
|
||||||
|
agent-side: the render job now carries the condition it was built under. `inspect` by
|
||||||
|
address delivers its module as `stopped-only <path>`, the job header keeps the flag,
|
||||||
|
and `flan_agent_poll` drops such a job — counted, handle closed, nothing installed and
|
||||||
|
nothing called — when `depth` is 0 at the moment it is claimed. That read is sound
|
||||||
|
rather than narrower: only the game thread polls and only the game thread raises
|
||||||
|
`depth`, so `depth > 0` seen inside a poll means *this* thread is parked in the break
|
||||||
|
loop and cannot be running a frame. The daemon reads the `refusals` count either side
|
||||||
|
of the delivery and surfaces the agent's own sentence — "the program resumed while this
|
||||||
|
inspection was being built — stop it again and re-ask" — instead of the timeout's
|
||||||
|
wrong-cause "is it calling (agent/poll)?". `reg at`'s depth gate stays as the front
|
||||||
|
door. `locals`, `globals` and `inspect` by slot are deliberately *not* stopped-only:
|
||||||
|
they hold no address, re-deriving the frame through `snap_top` or binding a global by
|
||||||
|
name at thunk-run time, so they carry no blessing that can expire. Pinned in
|
||||||
|
`test_agent.ml`, where a stopped-only job delivered to a program that is definitively
|
||||||
|
running is dropped while the eval module beside it installs — one install, not two.
|
||||||
|
- ~~**defenum values never range-checked to i32**~~ — FIXED. Every resolved member value,
|
||||||
|
explicit or autoincremented, is range-checked against i32 in the parser before the collision scan,
|
||||||
|
so the scan compares the numbers the program will actually have. Out of range is refused
|
||||||
|
by name (`parse/enum-value-out-of-range`); explicit-duplicate aliasing stays legal.
|
||||||
|
- **NaN sign** — **fixed**. LLVM constant-folded `0.0/0.0` to `nan`, x86 computed `-nan`
|
||||||
|
— a stdout DIFFER on a two-line program. Resolved by canonicalizing the *printed* form
|
||||||
|
rather than the arithmetic: `flan_f64_to_bytes` and the two dev emitters render any NaN
|
||||||
|
as unsigned `nan`, which is what `format-f64` in the prelude always did. Pinned in
|
||||||
|
`test/programs/format.flan`. See docs/BUILT.md.
|
||||||
|
- **x86's slice-from-ptr refusal is the wrong sentence** — **fixed** 2026-09-25; x86 calls `flan_slice_promise_error`: `x86.ml` still reports a
|
||||||
|
negative promise through `flan_slice_error` — "slice [0 -2) is out of bounds for
|
||||||
|
length 0", naming a range and a length the caller never wrote — where `emit.ml` has
|
||||||
|
its own `flan_slice_promise_error`. Same condition and same exit on both sides, only
|
||||||
|
the text differs. The survey cannot see it: `bounds.flan` picks its case out of
|
||||||
|
`(at args 1)` and `survey.sh` runs every program with no arguments, so nothing in the
|
||||||
|
corpus reaches the `n = -2` case on the x86 path. Noticed while making the check
|
||||||
|
unconditional (which did not change what it prints); the fix is one `bounds_call` with
|
||||||
|
one extra instead of three.
|
||||||
|
- **`emit.ml:3369` transient test ignores `new_globals`**: on the `retains=false` path a
|
||||||
|
module first to intern a global gets dlclosed; zero-init makes it moot today, a literal
|
||||||
|
init would dangle.
|
||||||
|
- **x86 to-bytes helper-return clobber**: `(defn numstr [n] (string (i64->bytes n)))`
|
||||||
|
works on LLVM, garbage on x86 — documented caller's-problem UB, but the divergence
|
||||||
|
makes the documented edge invisible.
|
||||||
|
- **map-grow at log2cap>=40 quotes a stale failure** (`flan_rt.c:2438`, pre-dates
|
||||||
|
yesterday).
|
||||||
|
|
||||||
|
## JS backend (deprioritised 2026-09-18, do not schedule)
|
||||||
|
|
||||||
|
- `lib/js.ml:889` still matches 1-arg `*ToBytes`; commit 81b807f made them 2-arg, so
|
||||||
|
every number-printing program is refused — JS corpus MATCH went 24 → 3 and `@js`
|
||||||
|
stays green because a refusal counts as success. Needs a MATCH floor in strict mode.
|
||||||
|
- f32 literals keep double precision (`js.ml:671` discards the fkind; `Math.fround` it).
|
||||||
|
- The cast-range trap quotes the cast's column, not the operand's (`js.ml:1077`).
|
||||||
|
|
||||||
|
## Verified clean, don't re-hunt
|
||||||
|
|
||||||
|
`flan_map_remove` (two randomized ASan harnesses incl. non-power-of-two cells, zero
|
||||||
|
mismatches), the grow-path overflow guards, the seqlock protocol itself, the park/rerun
|
||||||
|
condvar, `to_bytes`'s 64-byte slot arithmetic, elisp multibyte framing (unibyte
|
||||||
|
throughout, tested), JS struct value semantics and 64-bit integer semantics (broad
|
||||||
|
probes), division sign/INT_MIN traps at all widths, `if`/`match` dead-set joins,
|
||||||
|
`defer`'s kill-at-registration, index widening rules.
|
||||||
+2409
-453
File diff suppressed because it is too large.
Load diff
+102
-48
@@ -27,7 +27,7 @@ hypothetical.
|
|||||||
|
|
||||||
## 1. The one thing that cannot be written at all
|
## 1. The one thing that cannot be written at all
|
||||||
|
|
||||||
> **Bound, 2026-09-13.** `draw-texture-pro`, `image-from-image`, `window-ready?` and
|
> **Bound, 2026-09-13.** `draw-texture-pro`, `image-from-image`, `is-window-ready` and
|
||||||
> `Key/left-shift` are all hand-written in `vendor/raylib/raylib.flan` now. The section
|
> `Key/left-shift` are all hand-written in `vendor/raylib/raylib.flan` now. The section
|
||||||
> is kept as it was written, because the reasoning is the part worth having; what the
|
> is kept as it was written, because the reasoning is the part worth having; what the
|
||||||
> fix cost, and what could and could not be tested, is in the box at the end of it.
|
> fix cost, and what could and could not be tested, is in the box at the end of it.
|
||||||
@@ -74,7 +74,7 @@ Three more the same way, none of them blockers, all one line each:
|
|||||||
| Missing | Used at | Verdict |
|
| Missing | Used at | Verdict |
|
||||||
|---|---|---|
|
|---|---|---|
|
||||||
| `ImageFromImage` | `sprite_atlas.clj` `auto-select-tiles`; `tilemap-blob.lisp` `tile-subimages` | Annoyance — see §3 |
|
| `ImageFromImage` | `sprite_atlas.clj` `auto-select-tiles`; `tilemap-blob.lisp` `tile-subimages` | Annoyance — see §3 |
|
||||||
| `IsWindowReady` | `engine.clj` `run-game!`, `engine.lisp` `run-game` — the "window already open" guard | Annoyance; a `defvar bool` does the same thing |
|
| `IsWindowReady` | `engine.clj` `run-game!`, `engine.lisp` `run-game` — the "window already open" guard | Annoyance; a `defonce bool` does the same thing |
|
||||||
| `SetTextureFilter` | declared in `rl.clj`, called nowhere | Not needed. Point is raylib's default |
|
| `SetTextureFilter` | declared in `rl.clj`, called nowhere | Not needed. Point is raylib's default |
|
||||||
| `UpdateTexture` | declared in `rl.clj`, called nowhere | Not needed |
|
| `UpdateTexture` | declared in `rl.clj`, called nowhere | Not needed |
|
||||||
| `SetClipboardText` | `sprite_atlas.clj`, in a `comment` block only | Not needed |
|
| `SetClipboardText` | `sprite_atlas.clj`, in a `comment` block only | Not needed |
|
||||||
@@ -88,7 +88,7 @@ uses — and this is one member short of what this game needs. One entry.
|
|||||||
### What the four lines actually cost, and what a test could say about them
|
### What the four lines actually cost, and what a test could say about them
|
||||||
|
|
||||||
All four landed together: `draw-texture-pro` beside `draw-texture-rec`,
|
All four landed together: `draw-texture-pro` beside `draw-texture-rec`,
|
||||||
`image-from-image` beside `image-crop`, `window-ready?` beside `window-should-close?`,
|
`image-from-image` beside `image-crop`, `is-window-ready` beside `window-should-close`,
|
||||||
and `left-shift 340` at the end of the `Key` `defenum`. The three signatures were read
|
and `left-shift 340` at the end of the `Key` `defenum`. The three signatures were read
|
||||||
off a raylib header rather than remembered, and all three are unchanged across 5.1, 5.5
|
off a raylib header rather than remembered, and all three are unchanged across 5.1, 5.5
|
||||||
and the 6.0 this game vendors.
|
and the 6.0 this game vendors.
|
||||||
@@ -98,7 +98,7 @@ asked for "an acceptance case that makes raylib compute with the source rect so
|
|||||||
permuted `Rectangle` goes red". `DrawTexturePro` cannot have one: it needs a GL context,
|
permuted `Rectangle` goes red". `DrawTexturePro` cannot have one: it needs a GL context,
|
||||||
and `raylib.flan`'s own Shapes comment already says none of the drawing calls can be in
|
and `raylib.flan`'s own Shapes comment already says none of the drawing calls can be in
|
||||||
the acceptance table. What `raylib-ffi.flan` does instead is link it — the call sits
|
the acceptance table. What `raylib-ffi.flan` does instead is link it — the call sits
|
||||||
behind `(when (rl/window-ready?) …)`, which is false headless, so the shim is generated
|
behind `(when (rl/is-window-ready) …)`, which is false headless, so the shim is generated
|
||||||
and the symbol is resolved at link time and the body never runs. That catches a name or
|
and the symbol is resolved at link time and the body never runs. That catches a name or
|
||||||
an arity that does not exist in libraylib. It does **not** catch the argument order, and
|
an arity that does not exist in libraylib. It does **not** catch the argument order, and
|
||||||
three structs in a row is exactly where an argument order goes wrong. Only looking at
|
three structs in a row is exactly where an argument order goes wrong. Only looking at
|
||||||
@@ -186,10 +186,23 @@ Neither implementation returns errors as values. Both use the host's exception o
|
|||||||
condition system throughout. Porting this game exercises `signal`/`error`/`restart-case`
|
condition system throughout. Porting this game exercises `signal`/`error`/`restart-case`
|
||||||
and never wants a `Result`.
|
and never wants a `Result`.
|
||||||
|
|
||||||
### `handler-case` — one site, and `handler-bind` already covers it
|
### `handler-case` — one site, and it is now the natural spelling of it
|
||||||
|
|
||||||
`engine.clj`'s `reload-config!` is `(try … (catch Exception e (println e)))`. That is
|
`engine.clj`'s `reload-config!` is `(try … (catch Exception e (println e)))`. The ranking
|
||||||
"log it and carry on", which is what a `handler-bind` clause returning normally does.
|
below was written when the operator did not exist, and said `handler-bind` covers it,
|
||||||
|
which it does: "log it and carry on" is what a clause returning normally does. It is no
|
||||||
|
longer the closer translation. `handler-case` landed on 2026-09-19 and is Clojure's
|
||||||
|
try/catch by construction, so that site ports across as itself:
|
||||||
|
|
||||||
|
```
|
||||||
|
(handler-case (read-config path)
|
||||||
|
[(FileError [c] (do (print (.path c)) default-config))])
|
||||||
|
```
|
||||||
|
|
||||||
|
The difference that decides it is not spelling. A `handler-bind` clause is lifted into a
|
||||||
|
function of its own and cannot see `reload-config!`'s locals; a `handler-case` clause runs
|
||||||
|
at the form and can, which is what a catch block is assumed to do everywhere it is
|
||||||
|
written.
|
||||||
|
|
||||||
### `Handle` and pools — nothing to pool
|
### `Handle` and pools — nothing to pool
|
||||||
|
|
||||||
@@ -206,14 +219,19 @@ type's shape rather than its name.
|
|||||||
|
|
||||||
`engine.lisp` `read-data`, `game.lisp` `load-tileset` and `read-bitmask` read plists out
|
`engine.lisp` `read-data`, `game.lisp` `load-tileset` and `read-bitmask` read plists out
|
||||||
of `assets/*.data` at startup, and `reload-config!` re-reads the config while the game
|
of `assets/*.data` at startup, and `reload-config!` re-reads the config while the game
|
||||||
runs. `vendor/edn/edn.flan` is a 561-line tokenizer with `int-of` / `text=?` /
|
runs. `vendor/edn/edn.flan` is the tokenizer — `int-of` / `is-text-equal` / `is-keyword-equal` /
|
||||||
`keyword=?` / `expect`, and `test/programs/edn.flan` includes a hand-written struct
|
`expect` — and `vendor/edn/read.flan` is `(edn/read bytes)`, which answers a dynamic
|
||||||
reader as the worked example.
|
`Value` for a document nobody declared a type for. `test/programs/edn.flan` is the
|
||||||
|
hand-written struct reader as the worked example; `test/programs/edn-read.flan` reads the
|
||||||
|
tileset file itself.
|
||||||
|
|
||||||
So this is writable today. It costs a hand-written reader per schema — two here, the
|
So this is writable today, and the tileset needs no hand-written reader at all: it reads
|
||||||
tileset (`:texture-path`, `:selected-cells`) and the bitmask table — because `(read-edn T
|
as a `Value.Table` whose `:selected-cells` is a `Value.Set` of pairs, against an arena,
|
||||||
bytes)` is not built. Call it ~80 lines, once, at load time. See §3 for whether it should
|
released by one `free-all`. A hand-written reader is no longer what a *struct* costs:
|
||||||
be written at all.
|
`(edn/defedn Tileset "assets/tileset.edn")` derives the struct from the file while the
|
||||||
|
program is compiled and emits the reader with it, so the ~80 lines this used to price are
|
||||||
|
not written at all. See §3 item 9, and `docs/BUILT.md`, "A type provider: the struct a
|
||||||
|
data file implies".
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
@@ -227,7 +245,7 @@ Ordered by how much of the game it touches.
|
|||||||
(`engine.clj`'s `texture-cache` atom, `engine.lisp`'s `*texture-cache*` hash table), and
|
(`engine.clj`'s `texture-cache` atom, `engine.lisp`'s `*texture-cache*` hash table), and
|
||||||
`engine.lisp` keeps `*buffers*` there too.
|
`engine.lisp` keeps `*buffers*` there too.
|
||||||
|
|
||||||
`sand.flan`'s idiom — everything in `defvar` fixed arrays, the loop functions taking no
|
`sand.flan`'s idiom — everything in `defonce` fixed arrays, the loop functions taking no
|
||||||
state — works because nothing it holds is move-only. This game's state is not like that:
|
state — works because nothing it holds is move-only. This game's state is not like that:
|
||||||
`tilesets`, `src-rects`, `dst-rects` and the bitmask table all want a `Vec` or a `Map`.
|
`tilesets`, `src-rects`, `dst-rects` and the bitmask table all want a `Vec` or a `Map`.
|
||||||
|
|
||||||
@@ -237,7 +255,7 @@ host does:
|
|||||||
1. Hold the state in a `let` in `main` and pass `(Ptr Game)` to update and draw. Costs
|
1. Hold the state in a `let` in `main` and pass `(Ptr Game)` to update and draw. Costs
|
||||||
one parameter on three functions.
|
one parameter on three functions.
|
||||||
2. For the texture cache specifically, a `[8 CacheEntry]` fixed array with a count beats a
|
2. For the texture cache specifically, a `[8 CacheEntry]` fixed array with a count beats a
|
||||||
`(Map string Texture2D)` outright — the game loads five textures, and a linear scan of
|
`(Map str Texture2D)` outright — the game loads five textures, and a linear scan of
|
||||||
five path comparisons at load time is not worth a hash table. This is a case where the
|
five path comparisons at load time is not worth a hash table. This is a case where the
|
||||||
restriction pushes toward the right answer.
|
restriction pushes toward the right answer.
|
||||||
|
|
||||||
@@ -246,7 +264,8 @@ host does:
|
|||||||
`lib/check.ml:412` and `:317`. `game.lisp`'s shape is `tilesets` = a vector of `tileset`
|
`lib/check.ml:412` and `:317`. `game.lisp`'s shape is `tilesets` = a vector of `tileset`
|
||||||
structs, each of which owns `tiles`, `src-rects` and `dst-rects` vectors. That is
|
structs, each of which owns `tiles`, `src-rects` and `dst-rects` vectors. That is
|
||||||
`(Vec Tileset)` where `Tileset` owns three `Vec`s, and it is refused — recursive teardown
|
`(Vec Tileset)` where `Tileset` owns three `Vec`s, and it is refused — recursive teardown
|
||||||
waits on `drop`, which `NEXT.md:484` records as deferred, not built.
|
waits on `drop`, which `TODO.org`, "drop, and unwind-protect with it", records as
|
||||||
|
deferred, not built.
|
||||||
|
|
||||||
**Annoyance.** The fix is at the *inner* level, not the outer one: making the outer
|
**Annoyance.** The fix is at the *inner* level, not the outer one: making the outer
|
||||||
container a fixed array changes nothing, because `[4 Tileset]` where `Tileset` owns `Vec`s
|
container a fixed array changes nothing, because `[4 Tileset]` where `Tileset` owns `Vec`s
|
||||||
@@ -284,7 +303,7 @@ piece that needs to touch the state, and the game can supply `snapshot`/`restore
|
|||||||
more callbacks.
|
more callbacks.
|
||||||
|
|
||||||
> **Settled by the author, 2026-09-13: fixed arrays with counts.** The first branch below. So the
|
> **Settled by the author, 2026-09-13: fixed arrays with counts.** The first branch below. So the
|
||||||
> conditional verdict in this section is now unconditional: the state fits in `defvar` globals, the
|
> conditional verdict in this section is now unconditional: the state fits in `defonce` globals, the
|
||||||
> engine takes only `(Fn [] ())` callbacks and never names a state type, generics stays off this
|
> engine takes only `(Fn [] ())` callbacks and never names a state type, generics stays off this
|
||||||
> game's critical path, and `drop` is not needed for this version. Nothing in the language had to be
|
> game's critical path, and `drop` is not needed for this version. Nothing in the language had to be
|
||||||
> built for it — fixed arrays, counts and slices all already work. What is left is writing the game.
|
> built for it — fixed arrays, counts and slices all already work. What is left is writing the game.
|
||||||
@@ -295,7 +314,7 @@ more callbacks.
|
|||||||
**This verdict is conditional, and the condition is one decision.** Both it and the
|
**This verdict is conditional, and the condition is one decision.** Both it and the
|
||||||
globals workaround above hang on the same pivot, so it is worth stating once, flatly:
|
globals workaround above hang on the same pivot, so it is worth stating once, flatly:
|
||||||
*nothing in this game's state needs to be move-only.* Make the inner collections fixed
|
*nothing in this game's state needs to be move-only.* Make the inner collections fixed
|
||||||
arrays with counts, and then the state fits in `defvar` globals, the engine takes only
|
arrays with counts, and then the state fits in `defonce` globals, the engine takes only
|
||||||
`(Fn [] Unit)` callbacks and never names a state type, and generics stays off the critical
|
`(Fn [] Unit)` callbacks and never names a state type, and generics stays off the critical
|
||||||
path. Keep `Vec`s in a let-bound `Game` struct passed as `(Ptr Game)` instead, and
|
path. Keep `Vec`s in a let-bound `Game` struct passed as `(Ptr Game)` instead, and
|
||||||
`run-game` names `Game`, two programs with two state types need two engines, and generics
|
`run-game` names `Game`, two programs with two state types need two engines, and generics
|
||||||
@@ -521,13 +540,13 @@ not compete for the same slot.
|
|||||||
|
|
||||||
1. ~~**`declare-c draw-texture-pro`.**~~ Bound. The renderer is writable. The acceptance
|
1. ~~**`declare-c draw-texture-pro`.**~~ Bound. The renderer is writable. The acceptance
|
||||||
case this asked for could not be written as described — see §1's closing box — so it
|
case this asked for could not be written as described — see §1's closing box — so it
|
||||||
is a link check behind a `window-ready?` guard, and the computed test moved to
|
is a link check behind a `is-window-ready` guard, and the computed test moved to
|
||||||
`image-from-image` where raylib does the arithmetic on the CPU.
|
`image-from-image` where raylib does the arithmetic on the CPU.
|
||||||
|
|
||||||
2. ~~**`left-shift` in the `Key` `defenum`.**~~ One entry, `340`. §5 records that nothing
|
2. ~~**`left-shift` in the `Key` `defenum`.**~~ One entry, `340`. §5 records that nothing
|
||||||
else in the enum was missing.
|
else in the enum was missing.
|
||||||
|
|
||||||
3. ~~**`declare-c image-from-image` and `window-ready?`.**~~ Both bound.
|
3. ~~**`declare-c image-from-image` and `is-window-ready`.**~~ Both bound.
|
||||||
`image-from-image` carries the strongest new assertion in the table: two carves at
|
`image-from-image` carries the strongest new assertion in the table: two carves at
|
||||||
different `y`s out of one sheet, and the sheet re-read afterwards to show it was not
|
different `y`s out of one sheet, and the sheet re-read afterwards to show it was not
|
||||||
destroyed.
|
destroyed.
|
||||||
@@ -617,24 +636,32 @@ not compete for the same slot.
|
|||||||
|
|
||||||
7. **`drop`, or recursive teardown.** Unblocks `(Vec T)` where `T` owns a `Vec`, which is
|
7. **`drop`, or recursive teardown.** Unblocks `(Vec T)` where `T` owns a `Vec`, which is
|
||||||
`game.lisp`'s tileset shape exactly. Fixed arrays sidestep it at this size, so this is
|
`game.lisp`'s tileset shape exactly. Fixed arrays sidestep it at this size, so this is
|
||||||
about the version of the game with several atlases, not this one. `NEXT.md:484` already
|
about the version of the game with several atlases, not this one.
|
||||||
has it deferred with reasons; nothing here argues with that, only records a customer.
|
`TODO.org`, "drop, and unwind-protect with it", already has it deferred with reasons;
|
||||||
|
nothing here argues with that, only records a customer.
|
||||||
|
|
||||||
8. **Generics.** Real, and worth building — but for this game it is five-line loops at
|
8. **Generics.** Real, and worth building — but for this game it is five-line loops at
|
||||||
load time, and the reusable-engine argument for it dissolves once the state lives in the
|
load time, and the reusable-engine argument for it dissolves once the state lives in the
|
||||||
game rather than in the engine. **Do not sequence it ahead of items 4–6 on this game's
|
game rather than in the engine. **Do not sequence it ahead of items 4–6 on this game's
|
||||||
account.**
|
account.**
|
||||||
|
|
||||||
9. **`(read-edn T bytes)`.** `vendor:edn` already makes the asset readers writable; this
|
9. ~~**`(read-edn T bytes)`.**~~ **Built**, and not under that name: `(edn/defedn Tileset
|
||||||
removes ~80 lines of hand-written cursor walking for two schemas. Convenience, and it
|
"assets/tileset.edn")` reads the *file* while the program is compiled, derives the
|
||||||
competes with compile-time embedding, which may be the better answer for both files
|
struct its shape implies, and emits a reader with it — so the ~80 lines are neither
|
||||||
anyway.
|
hand-written nor written by the compiler from a type that was declared by hand. It is a
|
||||||
|
macro in `vendor:edn`, not a builtin, and `defjson` is the same over `vendor:json`.
|
||||||
|
The competition with compile-time embedding was the wrong reading of it: they are the
|
||||||
|
two halves of one answer, the shape from the file at compile time and the bytes from an
|
||||||
|
`embed` beside it. See `docs/BUILT.md`, "A type provider: the struct a data file
|
||||||
|
implies".
|
||||||
|
|
||||||
**Not ranked, because this game does not need them:** escaping closures and capture (one
|
**Not ranked, because this game does not need them:** escaping closures and capture (one
|
||||||
site, fixed by one parameter), `Handle` and pools (nothing to pool), `Result`/`try`
|
site, fixed by one parameter), `Handle` and pools (nothing to pool), `Result`/`try`
|
||||||
(neither host uses that discipline), `handler-case` (one site, `handler-bind` covers it),
|
(neither host uses that discipline), `loop`/`recur` and tail calls (nothing recurses),
|
||||||
`loop`/`recur` and tail calls (nothing recurses), user-written allocators, structural
|
user-written allocators, structural typing. `handler-case` was on this list for the same
|
||||||
typing.
|
reason and has since been built anyway — it cost one function in the checker and nothing
|
||||||
|
in either backend, being a `handler-bind` whose clause invokes a restart the form
|
||||||
|
established around itself.
|
||||||
|
|
||||||
---
|
---
|
||||||
|
|
||||||
@@ -660,8 +687,20 @@ each finding in §A names the command that produced the failure.
|
|||||||
|
|
||||||
### A.1 `GetCodepointPrevious` cannot be called, and closing it is a checker change
|
### A.1 `GetCodepointPrevious` cannot be called, and closing it is a checker change
|
||||||
|
|
||||||
|
> **Closed, 2026-09-14.** It was a checker change and it is made: `agrees` in
|
||||||
|
> `lib/cimport.ml` now has the pointer arm its own comment had been listing among the
|
||||||
|
> differences it accepted. `vendor/raylib/raylib.flan` carries
|
||||||
|
> `get-codepoint-previous-raw` — the exact declaration this section says it wanted — and
|
||||||
|
> a `get-codepoint-previous` wrapper over it that takes the bytes and an offset;
|
||||||
|
> `generated.flan` no longer carries the `str`-faced version at all, because a binding
|
||||||
|
> that is wrong for the only direction it reads in is worse than no binding. The example's
|
||||||
|
> `step-back` is one call to it, the continuation-byte walk is gone, and the expression
|
||||||
|
> below now prints 12356 and 3. The section is kept as written; the reasoning is the part
|
||||||
|
> worth having.
|
||||||
|
|
||||||
|
|
||||||
This is the real find of the round, and it is general: **a C function that reads
|
This is the real find of the round, and it is general: **a C function that reads
|
||||||
*backwards* from the pointer it is handed cannot be given a Flan `string`.**
|
*backwards* from the pointer it is handed cannot be given a Flan `str`.**
|
||||||
|
|
||||||
`lib/shim.ml` is explicit about why — `Pstr` is "ptr+len in, a NUL-terminated copy out",
|
`lib/shim.ml` is explicit about why — `Pstr` is "ptr+len in, a NUL-terminated copy out",
|
||||||
and the wrapper builds that copy for the duration of the call. Forwards, that is invisible
|
and the wrapper builds that copy for the duration of the call. Forwards, that is invisible
|
||||||
@@ -675,8 +714,8 @@ It does not crash, which is the bad part. Run headless:
|
|||||||
(let [text "いろはに"
|
(let [text "いろはに"
|
||||||
b (bytes text)
|
b (bytes text)
|
||||||
sz 0]
|
sz 0]
|
||||||
(println (rl/get-codepoint-previous (string (slice b 3 (len b))) (addr sz)))
|
(print (rl/get-codepoint-previous (str (slice b 3 (length b))) (addr sz)))
|
||||||
(println sz))
|
(print sz))
|
||||||
```
|
```
|
||||||
|
|
||||||
That prints `0` and `0`, where the answer is 12356 (い) and 3. Zero is also what
|
That prints `0` and `0`, where the answer is 12356 (い) and 3. Zero is also what
|
||||||
@@ -696,15 +735,15 @@ and means it, as `load-image-from-memory-raw` and `load-font-ex-raw` do:
|
|||||||
```
|
```
|
||||||
|
|
||||||
with `(addr (at b i))` for the interior pointer. It does not work, and the reason is not
|
with `(addr (at b i))` for the interior pointer. It does not work, and the reason is not
|
||||||
the FFI. `lib/cimport.ml` maps `const char *` to `string`, and `agrees` — the function that
|
the FFI. `lib/cimport.ml` maps `const char *` to `str`, and `agrees` — the function that
|
||||||
decides whether a hand-written declaration and the header say the same thing — accepts
|
decides whether a hand-written declaration and the header say the same thing — accepts
|
||||||
exactly one difference, an enum against a 32-bit integer. `(Ptr u8)` against `string` is not
|
exactly one difference, an enum against a 32-bit integer. `(Ptr u8)` against `str` is not
|
||||||
it. Adding the line above and building *anything*, not only regenerating, gives:
|
it. Adding the line above and building *anything*, not only regenerating, gives:
|
||||||
|
|
||||||
```
|
```
|
||||||
vendor/raylib/generated.flan:233:12: the declare-c of get-codepoint-previous-raw
|
vendor/raylib/generated.flan:233:12: the declare-c of get-codepoint-previous-raw
|
||||||
disagrees with vendor/raylib/raylib-5.5.h: parameter text is (Ptr u8) and the
|
disagrees with vendor/raylib/raylib-5.5.h: parameter text is (Ptr u8) and the
|
||||||
header says string (const char *)
|
header says str (const char *)
|
||||||
```
|
```
|
||||||
|
|
||||||
`headers` is read on every build, so the binding cannot be added without relaxing the
|
`headers` is read on every build, so the binding cannot be added without relaxing the
|
||||||
@@ -739,6 +778,12 @@ binding over a `const char *` cursor meets it.
|
|||||||
|
|
||||||
### A.2 There is no cast between pointer types
|
### A.2 There is no cast between pointer types
|
||||||
|
|
||||||
|
> **Closed, 2026-09-25.** `((Ptr U) p)` casts a pointer's element type, spelled as `(i32 x)`
|
||||||
|
> is, and checks nothing; it may add const and may not drop it. The example's call is now
|
||||||
|
> `(rl/update-texture texture ((Ptr u8) pixels))`; `update-texture-colors` stays as a one-line defn over the cast. There is
|
||||||
|
> still no cast between a pointer and an integer, and no pointer arithmetic.
|
||||||
|
|
||||||
|
|
||||||
`textures_image_processing` hands the pixels `LoadImageColors` returned straight to
|
`textures_image_processing` hands the pixels `LoadImageColors` returned straight to
|
||||||
`UpdateTexture`. In C both are pointers and nothing has to be said. Here
|
`UpdateTexture`. In C both are pointers and nothing has to be said. Here
|
||||||
`load-image-colors` answers `(Ptr Color)` and `update-texture` takes `(Ptr u8)` — the
|
`load-image-colors` answers `(Ptr Color)` and `update-texture` takes `(Ptr u8)` — the
|
||||||
@@ -757,7 +802,7 @@ A.1, with the same message. **Not built.**
|
|||||||
the first element is the address of the buffer.
|
the first element is the address of the buffer.
|
||||||
|
|
||||||
```flan
|
```flan
|
||||||
(rl/update-texture texture (addr (.r (at (slice-from-ptr pixels n) 0))))
|
(rl/update-texture texture (addr (.r (at (slice-from pixels n) 0))))
|
||||||
```
|
```
|
||||||
|
|
||||||
`Color`'s first field is `r`, a `u8`, at offset 0. It compiles, it is the right address,
|
`Color`'s first field is `r`, a `u8`, at offset 0. It compiles, it is the right address,
|
||||||
@@ -768,7 +813,7 @@ often — `void *` appears thirty-odd times in raylib.h alone.
|
|||||||
Two smaller notes on the same call. `(.data im-copy)` is already a `(Ptr u8)` over the same
|
Two smaller notes on the same call. `(.data im-copy)` is already a `(Ptr u8)` over the same
|
||||||
bytes, so the whole round trip is avoidable; the example keeps it because it is what the C
|
bytes, so the whole round trip is avoidable; the example keeps it because it is what the C
|
||||||
does and because nothing else in the corpus exercises
|
does and because nothing else in the corpus exercises
|
||||||
`LoadImageColors`/`UnloadImageColors`. And `slice-from-ptr` is what makes any of this
|
`LoadImageColors`/`UnloadImageColors`. And `slice-from` is what makes any of this
|
||||||
readable — it is the one form that turns a raylib pointer plus a raylib count into
|
readable — it is the one form that turns a raylib pointer plus a raylib count into
|
||||||
something with a length, and it was reached for three times across the two files.
|
something with a length, and it was reached for three times across the two files.
|
||||||
|
|
||||||
@@ -778,16 +823,16 @@ something with a length, and it was reached for three times across the two files
|
|||||||
open question and the answer is clean. The reader takes the bytes, the object file carries
|
open question and the answer is clean. The reader takes the bytes, the object file carries
|
||||||
them, the shim hands them over, and `LoadCodepoints` decodes the 54 codepoints of the Iroha
|
them, the shim hands them over, and `LoadCodepoints` decodes the 54 codepoints of the Iroha
|
||||||
into the 49 distinct ones the atlas is built from. Nothing in Flan claims to know what a
|
into the 49 distinct ones the atlas is built from. Nothing in Flan claims to know what a
|
||||||
character is — a `string` is bytes and `(bytes s)` / `(string b)` say so in both directions
|
character is — a `str` is bytes and `(bytes s)` / `(str b)` say so in both directions
|
||||||
at no cost — and for this job that is exactly the right amount of opinion. There is a
|
at no cost — and for this job that is exactly the right amount of opinion. There is a
|
||||||
`valid-utf8?` in the prelude and this example never needs it.
|
`is-valid-utf8` in the prelude and this example never needs it.
|
||||||
|
|
||||||
**An interior pointer into a string has an idiom already.** `(string (slice b off (len b)))`
|
**An interior pointer into a string has an idiom already.** `(str (slice b off (length b)))`
|
||||||
is the C's `char *ptr` and compiles to nothing: a `string` and a `[u8]` are the same two
|
is the C's `char *ptr` and compiles to nothing: a `str` and a `[u8]` are the same two
|
||||||
words. Every forward-reading `const char *` entry point is reachable that way.
|
words. Every forward-reading `const char *` entry point is reachable that way.
|
||||||
|
|
||||||
**`load-font-ex` needed nothing.** It takes a `[i32]` of codepoints, takes the
|
**`load-font-ex` needed nothing.** It takes a `[i32]` of codepoints, takes the
|
||||||
pointer-and-count apart itself, and uses a zeroed `defvar` as the null pointer that means
|
pointer-and-count apart itself, and uses a zeroed `defonce` as the null pointer that means
|
||||||
"the default ASCII set". It was written for this call before anything called it, and the
|
"the default ASCII set". It was written for this call before anything called it, and the
|
||||||
call fit it exactly.
|
call fit it exactly.
|
||||||
|
|
||||||
@@ -795,12 +840,19 @@ call fit it exactly.
|
|||||||
is `(and (> i 0) (continuation? (at b i)))`, and at the start of the text `i` is -1 — so if
|
is `(and (> i 0) (continuation? (at b i)))`, and at the start of the text `i` is -1 — so if
|
||||||
`and` were a strict function rather than a form, the guard would not save the `(at b -1)`
|
`and` were a strict function rather than a form, the guard would not save the `(at b -1)`
|
||||||
beside it and the first press of LEFT would signal `BoundsError`. It is a form and it does
|
beside it and the first press of LEFT would signal `BoundsError`. It is a form and it does
|
||||||
short-circuit; `test/programs/raylib-codepoints.flan` has a row for it, because the walk
|
short-circuit; `test/programs/raylib-codepoints.flan` had a row for it, because the walk
|
||||||
itself never reaches that offset and the claim is about the language rather than about the
|
itself never reaches that offset and the claim is about the language rather than about the
|
||||||
example.
|
example.
|
||||||
|
|
||||||
|
> **Note, 2026-09-14.** The walk this describes is gone — §A.1 above closed, and `step-back`
|
||||||
|
> is now one call to `GetCodepointPrevious`. The finding stands and the observation about
|
||||||
|
> `and` is still true; what went with the walk is the corpus's only exercise of it over an
|
||||||
|
> out-of-bounds index. The `back at start 0` row still runs and now pins the `(<= offset 0)`
|
||||||
|
> guard instead, which is the right thing for it to pin. A language claim wants a language
|
||||||
|
> test rather than a raylib example, and there is not one.
|
||||||
|
|
||||||
**Fixed arrays were the right shape for both.** A codepoint table with a count, a
|
**Fixed arrays were the right shape for both.** A codepoint table with a count, a
|
||||||
`[9 Rectangle]` of toggle buttons, a `[9 string]` of labels. The §3 finding from the
|
`[9 Rectangle]` of toggle buttons, a `[9 str]` of labels. The §3 finding from the
|
||||||
siam-farmer report — a global cannot hold a `Vec`, and fixed arrays with counts are usually
|
siam-farmer report — a global cannot hold a `Vec`, and fixed arrays with counts are usually
|
||||||
the better answer anyway — held again, in two more programs, with no friction at all.
|
the better answer anyway — held again, in two more programs, with no friction at all.
|
||||||
|
|
||||||
@@ -860,14 +912,16 @@ load a file out of `resources/` and neither file is in this tree.
|
|||||||
- `DotGothic16-Regular.ttf` is SIL OFL 1.1 and therefore redistributable, but it is 2 MB,
|
- `DotGothic16-Regular.ttf` is SIL OFL 1.1 and therefore redistributable, but it is 2 MB,
|
||||||
and whether a compiler repository whose only binary asset is a 1 KB PNG should grow a 2 MB
|
and whether a compiler repository whose only binary asset is a 1 KB PNG should grow a 2 MB
|
||||||
font is a call about the repository rather than about this port. Left to the author;
|
font is a call about the repository rather than about this port. Left to the author;
|
||||||
`HANDOFF-raylib-ports.md` carries it as the open question. The example looks for it under
|
`handoffs/HANDOFF-raylib-ports.md` carries it as the open question. The example looks for it under
|
||||||
`examples/resources/`, says on screen when it is not there, and runs either way — raylib
|
`examples/resources/`, says on screen when it is not there, and runs either way — raylib
|
||||||
answers a missing path with the default font, whose glyphs are ASCII, so the kana draw as
|
answers a missing path with the default font, whose glyphs are ASCII, so the kana draw as
|
||||||
boxes and the program explains itself rather than looking broken.
|
boxes and the program explains itself rather than looking broken.
|
||||||
|
|
||||||
**Neither example needed a language feature.** Nothing below the two refused bindings in §A
|
**Neither example needed a language feature.** Nothing below the two refused bindings in §A
|
||||||
was blocked at all, and both of those are one arm in `lib/cimport.ml`'s `agrees` away from
|
was blocked at all, and both of those were one arm in `lib/cimport.ml`'s `agrees` away from
|
||||||
being ordinary binding work.
|
being ordinary binding work. That arm was written on 2026-09-14 and §A.1 is now ordinary
|
||||||
|
binding work; §A.2 turned out to have a second, better reason behind the first, and the
|
||||||
|
boxes at the head of each section say what happened.
|
||||||
|
|
||||||
## E. Testing
|
## E. Testing
|
||||||
|
|
||||||
@@ -0,0 +1,92 @@
|
|||||||
|
# What is in here, and what is still true
|
||||||
|
|
||||||
|
These are the documents that are written once and read occasionally: the reasons behind the code, the
|
||||||
|
reports from finished investigations, and the record of individual work sessions. The documents that are
|
||||||
|
edited every day stay at the repository root, because source comments cite them by bare filename from
|
||||||
|
dozens of places and a path that moves is a path that rots. So `TODO.org`, `plan.org`, `spec-memory.md`
|
||||||
|
and `spec-conditions.md` are one directory up, and everything here points back at them.
|
||||||
|
|
||||||
|
A note on how to read the citations below: a document in this directory that says `plan.org` means the
|
||||||
|
one at the repository root. Nothing in `docs/` is named for a file at the root, so there is no ambiguity,
|
||||||
|
and rewriting a hundred prose mentions into `../plan.org` would have cost more in readability than it
|
||||||
|
bought in precision.
|
||||||
|
|
||||||
|
## If you have thirty seconds
|
||||||
|
|
||||||
|
Read **`BUILT.md`**. It is by far the largest document here and it is the one that pays: it holds the
|
||||||
|
reason behind every part of the compiler that exists, from why nothing is ever `dlclose`d to why the
|
||||||
|
printer is a compile-time walk over a type rather than a runtime function. It is current, it is
|
||||||
|
maintained, and deleting it would mean deriving all of it again. If you want to know why a thing is the
|
||||||
|
shape it is, the answer is in here.
|
||||||
|
|
||||||
|
After that, **`../TODO.org`** at the root for every decision, open question and known gap — one heading
|
||||||
|
each, with a keyword saying where it stands — and **`REFERENCES.md`** here for
|
||||||
|
where the evidence comes from — the reference clones on this machine, what each one answers, and the
|
||||||
|
standing rule that a claim in these notes was read out of a clone rather than recalled.
|
||||||
|
|
||||||
|
## The current documents
|
||||||
|
|
||||||
|
| File | What it is |
|
||||||
|
|---|---|
|
||||||
|
| `BUILT.md` | Why the parts that exist are shaped the way they are. The longest and the most load-bearing document in the repository. **Current.** |
|
||||||
|
| `PORTING.md` | What the author's game, `siam-farmer`, needs from Flan that Flan does not have yet, measured against the code that exists rather than against a plan. It is the requirements document the language is actually steering by. **Current.** |
|
||||||
|
| `REFERENCES.md` | The reference clones under `~/Repositories`, what each one is consulted for, and the specific files and lines already cited from them. **Current.** |
|
||||||
|
|
||||||
|
## The reports
|
||||||
|
|
||||||
|
Each of these was written once, from a reading or a measurement, and is not
|
||||||
|
maintained afterwards. They are kept because the reasoning in them is the
|
||||||
|
reason the code looks the way it does, and deriving it again would cost more
|
||||||
|
than reading it.
|
||||||
|
|
||||||
|
| File | What it is |
|
||||||
|
|---|---|
|
||||||
|
| `SPIKE-GENERICS.md` | Milestone 5's parametric polymorphism, run early and out of order as a spike. The spike succeeded and generics landed, so this is the report of finished work rather than a live plan — but its findings about where the cost falls are still the reason the implementation looks the way it does. **Historical, findings still stand.** |
|
||||||
|
| `SPIKE-INFERENCE.md` | Whether the checker should infer more than it does. A reading rather than a branch: nothing was built. |
|
||||||
|
| `SPIKE-DYNAMIC.md` | The dynamic-value runtime — NaN-boxed values over a mark-sweep heap. The design the `dyn` type and `runtime/flan_dyn.c` were built from. |
|
||||||
|
| `SPIKE-DUPLICITY.md` | Where the dyn side and the native side meet, and where one of them repeats the other. The source of the rule that a capability is written once per side and never twice on the same side. |
|
||||||
|
| `SBCL-REDEFINITION-NOTES.md` | What SBCL does when a struct is redefined under a running image, read out of the clone. Written for the open question of whether Flan's hard refusal should become a warning and a kept old layout. The question is still open. |
|
||||||
|
| `BUGS-2026-09-18.md` | A five-agent sweep of the runtime, checker, backends, dev loop and Emacs client. The bugs are fixed; the file is kept because `spec-memory.md` cites one of its findings as evidence. |
|
||||||
|
|
||||||
|
`DISCUSS.md` used to be here and is gone. Its open questions are entries in
|
||||||
|
`../TODO.org` now, one heading each; the four long reports it carried — the
|
||||||
|
embedding spike and the three that built the hand-written x86 backend — are in
|
||||||
|
`BUILT.md`, under "One process" and "The hand-written x86 backend, and the four
|
||||||
|
measurements behind it", because they were reasoning rather than decisions and
|
||||||
|
a few lines could not hold them.
|
||||||
|
|
||||||
|
Three more files that used to be here are gone, and `git log` is where they
|
||||||
|
live now: `overview.md`, the first brainstorm from before the language had
|
||||||
|
S-expressions, which had said in its own first line that it was superseded;
|
||||||
|
`DIAGNOSTICS-AUDIT.md`, the worklist the diagnostics rewrite was done from,
|
||||||
|
which the rewrite closed; and `REVIEW-production-readiness.md`, a review of a
|
||||||
|
tree a thousand commits behind this one.
|
||||||
|
|
||||||
|
## `handoffs/`
|
||||||
|
|
||||||
|
One report per work session, each written by whoever held the branch at the time. They are the
|
||||||
|
operational record: what was attempted, what was measured, what was decided without being able to ask,
|
||||||
|
and what was left open for the next lane. They are all historical the moment they are written — a handoff
|
||||||
|
describes a session that has ended — but they are cited by name from source comments and from `../TODO.org`,
|
||||||
|
because the reasoning behind a guard or a calling convention is often only written down once and this is
|
||||||
|
where it was written.
|
||||||
|
|
||||||
|
Nine of them are the hand-written x86-64 backend, read in the order the work happened:
|
||||||
|
`HANDOFF-x86-rt.md` set the remaining-items list the others close, `HANDOFF-x86-redef.md`
|
||||||
|
built the redefinition emitter, `HANDOFF-x86-aggregates.md` took that across the struct boundary,
|
||||||
|
`HANDOFF-x86-guards.md` settled the two guards nothing reaches, `HANDOFF-x86-debug.md` added debug
|
||||||
|
information, and `HANDOFF-x86-cost.md` measured what the backend costs and set the survey running on its
|
||||||
|
own so a refusal cannot sit unnoticed again. Then `HANDOFF-x86-devloop.md` for making it the dev loop's
|
||||||
|
default, `HANDOFF-x86-abi-marker.md` and `HANDOFF-x86-annotate.md`, and
|
||||||
|
`HANDOFF-x86-macro-visibility.md` for why a macro module's symbols are hidden.
|
||||||
|
|
||||||
|
The rest are unrelated to each other. `HANDOFF-arith.md` is why a divide by zero is a condition
|
||||||
|
rather than a `SIGFPE`. `HANDOFF-raylib-ports.md` is the running record of the last two raylib example
|
||||||
|
ports, whose lasting findings were folded into `PORTING.md`, and `HANDOFF-cimport-ptr.md` is the arm
|
||||||
|
`cimport.ml`'s header check had been promising in a comment and not implementing — which is what those two ports
|
||||||
|
found, worked around and wrote up. `HANDOFF-devtest-noise.md` is the linker
|
||||||
|
error `dune test` used to print on every run. `HANDOFF-emacs-flake.md` is the `test_emacs` flake that
|
||||||
|
turned out to be `SIGPIPE` killing the daemon mid-reply, and it is worth reading for the two mechanisms it
|
||||||
|
rules out as much as for the one it found. `HANDOFF-dyn-m1.md` is the first milestone of the dynamic
|
||||||
|
runtime, `HANDOFF-lowering-buffer.md` the buffer that shows what a form lowered to, `HANDOFF-rot.md` a
|
||||||
|
sweep for prose that had stopped being true, and `HANDOFF-tidy.md` is this reorganisation.
|
||||||
@@ -2,7 +2,7 @@
|
|||||||
|
|
||||||
Read the source, do not recall it. Every claim in this repository's notes that came from one of these
|
Read the source, do not recall it. Every claim in this repository's notes that came from one of these
|
||||||
was read out of the clone, and the ones that were recalled instead have been wrong before — see
|
was read out of the clone, and the ones that were recalled instead have been wrong before — see
|
||||||
`NEXT.md`'s corrections. When a note cites a file and line, it is because someone opened it.
|
the corrections `TODO.org` records. When a note cites a file and line, it is because someone opened it.
|
||||||
|
|
||||||
All paths are under `~/Repositories`. Dates are the last commit in the clone at the time this file was
|
All paths are under `~/Repositories`. Dates are the last commit in the clone at the time this file was
|
||||||
written (2026-09-13); a stale clone is still the right source for how a thing works, just not for what
|
written (2026-09-13); a stale clone is still the right source for how a thing works, just not for what
|
||||||
@@ -36,6 +36,15 @@ Most of what this repository copies. Places already cited in the notes:
|
|||||||
the machinery the generics spike copied.
|
the machinery the generics spike copied.
|
||||||
- `src/check_type.cpp:173-200` — `FieldFlag_using` and `FieldFlag_subtype`. Odin's answer to
|
- `src/check_type.cpp:173-200` — `FieldFlag_using` and `FieldFlag_subtype`. Odin's answer to
|
||||||
"a function over anything with these fields": nominal embedding, not row polymorphism.
|
"a function over anything with these fields": nominal embedding, not row polymorphism.
|
||||||
|
- `core/encoding/json/` — what `vendor/json` is written against. Three facts were read out of it
|
||||||
|
rather than recalled. `tokenizer.odin` allocates nothing and hands back the raw literal including
|
||||||
|
its quotes, while `parser.odin:320` `unquote_string` does the copy against an allocator — which is
|
||||||
|
the split `vendor/json` copies, and the reason its `string-of` is the only function in the package
|
||||||
|
that allocates. `parser.odin:388` clones even when the literal holds no escape at all, and
|
||||||
|
`types.odin:96` `destroy_value` frees every `String` it walks — together those settle that a
|
||||||
|
`Value` owns its strings unconditionally, which is what lets one `free-all` take a whole document.
|
||||||
|
And `types.odin:49` sets `DEFAULT_SPECIFICATION` to JSON5, not JSON: `vendor/json` deliberately
|
||||||
|
does not follow that one, and every refusal in it that names a dialect names this difference.
|
||||||
|
|
||||||
Two Odin facts worth keeping together, because conflating them has already caused one wrong note:
|
Two Odin facts worth keeping together, because conflating them has already caused one wrong note:
|
||||||
**`$T` procs are monomorphised, containers are type-erased.** Odin uses both and picks per case.
|
**`$T` procs are monomorphised, containers are type-erased.** Odin uses both and picks per case.
|
||||||
@@ -52,7 +61,7 @@ one borrows its memory model from.
|
|||||||
|---|---|---|
|
|---|---|---|
|
||||||
| `farolero` | 2023-05-05 | Common Lisp conditions and restarts, portably — a smaller read than SBCL's for *semantics*. |
|
| `farolero` | 2023-05-05 | Common Lisp conditions and restarts, portably — a smaller read than SBCL's for *semantics*. |
|
||||||
| `lem` | 2025-08-29 | An editor written in CL. Its own REPL and process model. |
|
| `lem` | 2025-08-29 | An editor written in CL. Its own REPL and process model. |
|
||||||
| `cider` | 2026-09-10 | The Clojure editor protocol this repo's `flan-dev.el` is shaped after. |
|
| `cider` | 2026-09-10 | The Clojure editor protocol this repo's `flan.el` is shaped after. |
|
||||||
| `emacs` | 2026-04-18 | Overlays, faces, `pre-command-hook` — the C and Lisp behind the editor half. |
|
| `emacs` | 2026-04-18 | Overlays, faces, `pre-command-hook` — the C and Lisp behind the editor half. |
|
||||||
| `fennel-ls` | 2026-05-06 | A Lisp language server. |
|
| `fennel-ls` | 2026-05-06 | A Lisp language server. |
|
||||||
| `Carp` | 2026-08-24 | A statically typed Lisp with no GC. **The closest thing to this language's premise.** |
|
| `Carp` | 2026-08-24 | A statically typed Lisp with no GC. **The closest thing to this language's premise.** |
|
||||||
@@ -62,6 +71,20 @@ one borrows its memory model from.
|
|||||||
`Carp` deserves the note it has: statically typed, no GC, Lisp syntax, borrow-checked. Whatever it
|
`Carp` deserves the note it has: statically typed, no GC, Lisp syntax, borrow-checked. Whatever it
|
||||||
got right or wrong is the nearest prior art to what is being built here.
|
got right or wrong is the nearest prior art to what is being built here.
|
||||||
|
|
||||||
|
## Compiling to JavaScript
|
||||||
|
|
||||||
|
Cloned 2026-09-17, for the JS backend (TODO.org, "A JS backend is a dialect, not a second machine").
|
||||||
|
|
||||||
|
| Clone | What it answers |
|
||||||
|
|---|---|
|
||||||
|
| `Fable` | **The best semantic match**: statically typed F# to readable JS, value-semantics structs, real i64/u64. `src/fable-library-ts/Long.ts`, `Int32.ts`, `BigInt.ts` for how .NET integer semantics live on JS numbers; `src/Fable.Transforms/` for how a typed AST lowers, including where structs get cloned at assignment and call sites. Large — read it for specific answers, not through. |
|
||||||
|
| `squint` | A small Clojure-syntax-to-JS compiler. `src/squint/compiler.cljc` is the emitter to read for output style and structure. |
|
||||||
|
| `clojurescript` | The full-size version of the same problem, including host interop. Consult, don't read through. |
|
||||||
|
|
||||||
|
The Lisp-to-JS pair never faces the two hard questions here — integer width and struct copy
|
||||||
|
semantics — because they are dynamic. Fable does, which is why it is on this list despite being
|
||||||
|
neither a Lisp nor small.
|
||||||
|
|
||||||
## Graphics and the C boundary
|
## Graphics and the C boundary
|
||||||
|
|
||||||
`raylib`, `raygui`, `glfw`, `SDL`, `freetype-gl`, `TIC-80`, `aseprite`, `macroquad`, `godot`, `bevy`.
|
`raylib`, `raygui`, `glfw`, `SDL`, `freetype-gl`, `TIC-80`, `aseprite`, `macroquad`, `godot`, `bevy`.
|
||||||
@@ -0,0 +1,454 @@
|
|||||||
|
# SBCL's redefinition model, as a reference point for Flan
|
||||||
|
|
||||||
|
Research notes, 2026-09-20. Untracked. Written to answer "investigate SBCL's
|
||||||
|
redefinition model — warn + keep old value until callers update", the question
|
||||||
|
behind TODO.org, "A struct version word, so a redefined layout keeps working".
|
||||||
|
Nothing here is a decision; the last section lists candidates and stops.
|
||||||
|
|
||||||
|
The question behind it: Flan's dev session hard-refuses a struct layout change
|
||||||
|
and a global type change (`lib/session.ml:304-338`, `docs/BUILT.md:1213-1219`),
|
||||||
|
and plan.org's dev/release table (~671-682) lists "Structs: version word" for dev
|
||||||
|
builds with nothing behind it. SBCL is the system the author half-remembered as
|
||||||
|
"warn, keep the old layout, complain at the stale reader". It does do something
|
||||||
|
close to that — but the shape of it is not quite what the note says, and the
|
||||||
|
difference matters for what Flan could copy.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 1. `defstruct` redefinition
|
||||||
|
|
||||||
|
### It is an error, not a warning
|
||||||
|
|
||||||
|
This is the one place that half-remembered summary is wrong, and it is worth stating
|
||||||
|
first because it inverts the precedent. The note says SBCL "warns rather than
|
||||||
|
refusing". SBCL signals a **continuable error** — the default behaviour of an
|
||||||
|
incompatible `defstruct` redefinition at a REPL with no handler is to drop you
|
||||||
|
into the debugger, and in a non-interactive build it aborts. It proceeds only
|
||||||
|
because a human (or a handler) picks a restart.
|
||||||
|
|
||||||
|
From `src/code/defstruct.lisp`, `%redefine-defstruct`:
|
||||||
|
|
||||||
|
> "attempt to redefine the ~S class ~S incompatibly with the current definition"
|
||||||
|
|
||||||
|
with two restarts:
|
||||||
|
|
||||||
|
- `continue` — "Use the new definition of ~S, invalidating already-loaded code
|
||||||
|
and instances."
|
||||||
|
- `recklessly-continue` — "Use the new definition of ~S as if it were
|
||||||
|
compatible, allowing old accessors to use new instances and allowing new
|
||||||
|
accessors to use old instances." Offered only when `mutable-layout-p` holds,
|
||||||
|
i.e. when the new layout can be overwritten in place onto the old one
|
||||||
|
(compatible sizes/rawness), so it is not offered for arbitrary changes.
|
||||||
|
|
||||||
|
There is a separate genuine warning for the compatible-ish case,
|
||||||
|
`redefine-structure-warning`:
|
||||||
|
|
||||||
|
> "incompatibly redefining slots of structure class ~S~@Make sure any uses of
|
||||||
|
> affected accessors are recompiled"
|
||||||
|
|
||||||
|
The comparison that drives all of this is `compare-slots`, which returns three
|
||||||
|
lists: slots that **moved**, slots that were **retyped**, slots that were
|
||||||
|
**deleted**. So SBCL's notion of "incompatible" is finer than Flan's
|
||||||
|
`compatible_structs` all-or-nothing name+type list equality — a pure append of
|
||||||
|
trailing slots is a different case from a reorder, and SBCL distinguishes them.
|
||||||
|
|
||||||
|
Note also that ANSI leaves structure redefinition **undefined**
|
||||||
|
(CLHS `defstruct`); everything above is an SBCL extension, not a standard
|
||||||
|
protocol. SBCL is not implementing a spec here, it invented a policy.
|
||||||
|
|
||||||
|
### What happens to the live instances
|
||||||
|
|
||||||
|
Picking `continue` calls `register-layout` with `:invalidate t`, which reaches
|
||||||
|
`%invalidate-layout` in `src/code/class.lisp`:
|
||||||
|
|
||||||
|
> "Mark LAYOUT as invalid. This is called only on CONDITION and STRUCTURE
|
||||||
|
> subtypes when redefining incompatibly."
|
||||||
|
|
||||||
|
It sets the layout's `invalid` slot, zeroes `layout-clos-hash`, and unhooks the
|
||||||
|
classoid from every superclass's subclass table. **The instances themselves are
|
||||||
|
not touched, not walked, not found.** There is no heap scan. Each instance keeps
|
||||||
|
pointing at the same layout object it always pointed at; that object is now
|
||||||
|
flagged invalid.
|
||||||
|
|
||||||
|
This is the crucial mechanism, and it is the one Flan cannot have: **an SBCL
|
||||||
|
structure instance carries a pointer to its layout in its header word.** The
|
||||||
|
invalidation is one store into a shared object, and every instance in the heap
|
||||||
|
learns about it for free, because they all reach it through that pointer.
|
||||||
|
|
||||||
|
### When the error surfaces
|
||||||
|
|
||||||
|
At the next access, not at redefinition time. Two paths, and they give different
|
||||||
|
conditions, which is worth being precise about:
|
||||||
|
|
||||||
|
- **The typed-accessor path.** A `defstruct` accessor in safe code checks the
|
||||||
|
instance's layout against the expected one. With the layout invalidated the
|
||||||
|
check fails and you get an ordinary `type-error` — the value is no longer
|
||||||
|
`typep` the struct type it used to be. (I did not read the exact accessor
|
||||||
|
emission path in `src/compiler/`; treat "it is specifically a `type-error`
|
||||||
|
rather than some dedicated condition" as **unverified**.)
|
||||||
|
- **The PCL path.** When a structure-object with an invalid wrapper goes through
|
||||||
|
PCL (generic function dispatch, `slot-value`), `%obsolete-instance-trap`
|
||||||
|
fires. For a structure it signals `sb-pcl::obsolete-structure`, defined in
|
||||||
|
`src/pcl/std-class.lisp`, reported as:
|
||||||
|
|
||||||
|
> "obsolete structure error for a structure of type ~S"
|
||||||
|
|
||||||
|
This is the condition people quote when they say "SBCL tells you your instance
|
||||||
|
is stale". There is no restart on it that repairs the instance. There is no
|
||||||
|
update protocol for structures.
|
||||||
|
|
||||||
|
So the honest one-line summary of the struct story: **SBCL refuses by default,
|
||||||
|
proceeds only on an explicit human restart, and then converts your old instances
|
||||||
|
into landmines that raise at first touch.** It never silently reads at the wrong
|
||||||
|
offsets — except under `recklessly-continue`, which is exactly the "silent
|
||||||
|
argument mismatch" outcome `docs/BUILT.md:1223-1230` says Flan refuses to ship,
|
||||||
|
and SBCL offers it only behind a name chosen to shame you.
|
||||||
|
|
||||||
|
## 2. `defclass` redefinition — the part with a real protocol
|
||||||
|
|
||||||
|
This is where CL earns the reputation, and it is a standard protocol (CLHS
|
||||||
|
4.3.6, `update-instance-for-redefined-class`), not an SBCL extension.
|
||||||
|
|
||||||
|
Redefining a class does **not** error. The sequence:
|
||||||
|
|
||||||
|
1. The new class definition is installed. `make-instances-obsolete` runs —
|
||||||
|
in SBCL, the `std-class` method calls `%update-lisp-class-layout` and
|
||||||
|
`%invalidate-wrapper` with the `:obsolete` flag. Again: a flag on the shared
|
||||||
|
wrapper, no heap walk. `layout-invalid` can hold `nil`, `t`,
|
||||||
|
`(:flush <wrapper>)` or `(:obsolete <wrapper>)`; `invalid-wrapper-p` is the
|
||||||
|
predicate on the access path.
|
||||||
|
2. Nothing else happens until someone touches an instance. CLHS 4.3.6: the
|
||||||
|
update occurs "at an implementation-dependent time, but no later than the
|
||||||
|
next time a slot of that instance is read or written", and the instance's
|
||||||
|
`eq` identity is preserved across it.
|
||||||
|
3. On that first touch, `%obsolete-instance-trap` runs. It computes the
|
||||||
|
**added** slots and the **discarded** slots by name, builds a property list
|
||||||
|
of the discarded slots' values, swaps the instance's storage for the new
|
||||||
|
shape, and calls:
|
||||||
|
|
||||||
|
```lisp
|
||||||
|
(sb-sys:nlx-protect (update-instance-for-redefined-class
|
||||||
|
instance added discarded plist)
|
||||||
|
(replace-wrapper-and-slots instance owrapper oslots))
|
||||||
|
```
|
||||||
|
|
||||||
|
The `nlx-protect` is a detail worth noting: if the user's
|
||||||
|
`update-instance-for-redefined-class` method signals and the stack unwinds,
|
||||||
|
the instance is rolled back to its old wrapper and slots rather than left
|
||||||
|
half-migrated.
|
||||||
|
|
||||||
|
What the protocol guarantees:
|
||||||
|
|
||||||
|
- **Slots present in both definitions keep their values, matched by name.**
|
||||||
|
This is the whole reason it works, and it is only possible because a CLOS
|
||||||
|
instance's slots are addressed through a name→index map held in the class, not
|
||||||
|
baked into compiled call sites.
|
||||||
|
- **Added slots are initialized from their `:initform`s** — the system-supplied
|
||||||
|
primary method calls `shared-initialize` on exactly the added-slot names,
|
||||||
|
passing along the initargs it received.
|
||||||
|
- **Discarded slots' values are not lost, they are handed to you** in the
|
||||||
|
property list, so a user method can do `(getf plist 'old-name)` and derive the
|
||||||
|
new slots from the old ones (the canonical CLHS example is a cartesian→polar
|
||||||
|
coordinate change).
|
||||||
|
- **Initargs are validated**; the default method signals on an initarg not
|
||||||
|
declared valid for the class.
|
||||||
|
- The return value is ignored.
|
||||||
|
|
||||||
|
The pattern to take away: **the automatic part is name-matching, and the
|
||||||
|
interesting part is a user hook that gets the old values.** CLOS does not try to
|
||||||
|
guess what a renamed slot meant; it hands you the corpse and lets you decide.
|
||||||
|
|
||||||
|
## 3. Global variables
|
||||||
|
|
||||||
|
Trivial, as expected, and the interesting bit is that CL already draws Flan's
|
||||||
|
distinction.
|
||||||
|
|
||||||
|
- `defparameter` re-evaluated "unconditionally assigns the initial-value to the
|
||||||
|
dynamic variable named name".
|
||||||
|
- `defvar` "assigns initial-value (if supplied) to the dynamic variable named
|
||||||
|
name **only if name is not already bound**".
|
||||||
|
|
||||||
|
That is precisely `docs/BUILT.md`'s rule that a `defvar`'s *initial value* is
|
||||||
|
deliberately not in the refusal table — "edit the code, keep the sand". CL's
|
||||||
|
`defvar` is the same policy, reached by the same reasoning, thirty years earlier.
|
||||||
|
Flan's `defvar` and CL's behave the same way here: both accept a changed
|
||||||
|
initialiser and ignore it while the variable is bound. The divergence is only in
|
||||||
|
the const twin — Flan's `defconst` refuses a changed value (when the checker
|
||||||
|
consumed it), whereas CL's `defparameter` simply overwrites.
|
||||||
|
|
||||||
|
There is **no** type-change problem to speak of, because a CL special variable
|
||||||
|
has no compile-time type and no fixed-shape storage — it is one boxed word. The
|
||||||
|
entire class of failure that `lib/session.ml:304-311` is protecting against
|
||||||
|
(storage laid out to a type, reused for another) does not exist in CL. So CL
|
||||||
|
offers no precedent for Flan's typed-global refusal; it sidesteps it by being
|
||||||
|
dynamically typed. Worth saying plainly rather than pretending there is guidance
|
||||||
|
here.
|
||||||
|
|
||||||
|
`defconstant` is the exception and is famously annoying: redefining one to a
|
||||||
|
non-`eql` value is an error in SBCL, which is the same shape as Flan's
|
||||||
|
compile-time-consumed `defconst` refusal, for a related reason (the old value
|
||||||
|
may already have been folded into compiled code).
|
||||||
|
|
||||||
|
## 4. Function redefinition
|
||||||
|
|
||||||
|
Trivially supported, and the reason is the reason Flan's cell design already
|
||||||
|
works: **a global function call goes through the `fdefinition`**, a name→function
|
||||||
|
indirection, not to a body address. Redefining `foo` stores a new function
|
||||||
|
object into the symbol's function cell, and every call site compiled against
|
||||||
|
`foo` picks it up on its next call with no recompilation and no stale caller.
|
||||||
|
This is exactly plan.org's "every cross-function call goes through an
|
||||||
|
indirection cell; body redefinition is one atomic pointer store". Flan already
|
||||||
|
matches SBCL here for the body-only case.
|
||||||
|
|
||||||
|
Two nuances worth carrying over:
|
||||||
|
|
||||||
|
- **Stale callers do exist in SBCL, in one place: block compilation.** Under
|
||||||
|
`(declaim (start-block ...))` / `:block-compile`, calls within the block become
|
||||||
|
local calls resolved at compile time. Redefining a function in a block-compiled
|
||||||
|
unit leaves its in-block callers calling the old body — they were never going
|
||||||
|
through the fdefinition. SBCL's answer is not a warning or a trampoline; it is
|
||||||
|
"block compilation prevents redefinition, that is the trade you made", and the
|
||||||
|
feature is off by default. Self-recursive calls are the same story in
|
||||||
|
miniature: SBCL deliberately compiles a self-call as a full call precisely so
|
||||||
|
that a function can be redefined while running.
|
||||||
|
- **SBCL does not version signatures.** A function whose lambda list changes is
|
||||||
|
just a redefinition; there is no new version, no trampoline, no per-caller
|
||||||
|
warning. Callers compiled against the old arglist get a normal
|
||||||
|
wrong-number-of-arguments error at runtime (or a compile-time style-warning if
|
||||||
|
SBCL still has the old ftype recorded and sees the call again). plan.org's
|
||||||
|
versioned-function design with tracked caller sites is **more** than SBCL does,
|
||||||
|
not a port of it. If the author was remembering SBCL as the source of that
|
||||||
|
design, the memory is of something else — the nearest real relatives are
|
||||||
|
Erlang's two-version code loading (old code + current code, a process running
|
||||||
|
old code is killed on the third load) and Smalltalk's `become:`.
|
||||||
|
|
||||||
|
## 5. What maps to Flan and what cannot
|
||||||
|
|
||||||
|
### The structural obstacle, stated once
|
||||||
|
|
||||||
|
Every SBCL mechanism above — struct layout invalidation, CLOS wrapper
|
||||||
|
obsolescence, the lazy trap — rests on a single fact: **an instance carries a
|
||||||
|
pointer to its shape descriptor in its header.** That is what makes "invalidate
|
||||||
|
the shape" an O(1) operation that reaches every live instance, and what makes
|
||||||
|
"detect staleness at next access" a load-and-compare on a word the instance
|
||||||
|
already has.
|
||||||
|
|
||||||
|
Flan's typed side has none of that. A `defstruct` value is flat and unboxed; it
|
||||||
|
lives inline in a global, inline in an array element, in registers, spilled on a
|
||||||
|
stack frame. There is no header word, no per-instance shape pointer, and no way
|
||||||
|
to enumerate the live instances of a type. So:
|
||||||
|
|
||||||
|
- Layout invalidation as SBCL does it: **structurally unavailable.** There is
|
||||||
|
nothing to invalidate that instances reach.
|
||||||
|
- Detecting an obsolete instance at access time: **unavailable in release
|
||||||
|
shape,** because detection requires a per-instance word. It is available only
|
||||||
|
if you *add* that word, which is exactly what plan.org's "Structs: version
|
||||||
|
word, dev only" line means.
|
||||||
|
- `update-instance-for-redefined-class`-style migration: **doubly unavailable**,
|
||||||
|
because it needs both the per-instance shape tag *and* the ability to change
|
||||||
|
an instance's size in place. A flat struct embedded in an array cannot grow.
|
||||||
|
|
||||||
|
### The dev-build version word is SBCL's generation counter
|
||||||
|
|
||||||
|
The connection plan.org's table implies but does not spell out: a version word
|
||||||
|
in the dev build is the degenerate form of SBCL's layout. SBCL's instance points
|
||||||
|
at a layout object whose `invalid` flag can be flipped; a Flan dev-build struct
|
||||||
|
would carry an integer stamped at construction, compared against the type's
|
||||||
|
current generation on access. Flip the generation on redefinition, and the next
|
||||||
|
field access on an old-generation value traps. That is `layout-invalid` with the
|
||||||
|
indirection collapsed into an immediate, which is the only form that survives
|
||||||
|
"instances have no headers, but dev builds may pay for one extra word".
|
||||||
|
|
||||||
|
What it buys, honestly: **not** the ability to keep using old values. It buys a
|
||||||
|
*diagnosis* instead of a refusal — the reload is accepted, the program keeps
|
||||||
|
running, and the first read of a stale value says "this `Cursor` was built
|
||||||
|
before you changed `Cursor`" with a location, instead of the session saying
|
||||||
|
"restart" before anything runs. That is genuinely SBCL's bargain (`continue`
|
||||||
|
then trap), and it is the honest framing: the version word converts a
|
||||||
|
compile-time refusal into a runtime trap. Whether that is an improvement is a
|
||||||
|
judgement about which failure the author would rather debug.
|
||||||
|
|
||||||
|
What it costs, all of which is real:
|
||||||
|
|
||||||
|
- A word per struct instance in dev builds, so dev and release layouts differ —
|
||||||
|
which means array strides, FFI structs, and anything crossing to C differ too,
|
||||||
|
or need to be excluded. The dev/release divergence plan.org already accepts
|
||||||
|
for frames and cells gets bigger and more observable.
|
||||||
|
- A check on every field access in dev builds.
|
||||||
|
- Structs embedded in other structs, in arrays, and in `Vec`s each need a story;
|
||||||
|
an array of 4096 cells would need every element stamped and every element
|
||||||
|
checked.
|
||||||
|
- Globals are not covered by it at all. A global's storage is a fixed slot with
|
||||||
|
a shape; a version word on the *global* could detect a stale read, but there
|
||||||
|
is nothing to read — the point of the refusal is that the old bytes mean
|
||||||
|
something else now. SBCL has no precedent to offer, per section 3.
|
||||||
|
|
||||||
|
### The dyn side is where CLOS-style update is actually available
|
||||||
|
|
||||||
|
Grounding the claim in the code as landed (TODO.org, "defclass is a named dyn
|
||||||
|
map with a shape tag"; commits `8d2bf2a`,
|
||||||
|
`5af990e`, `6c6024e`; `runtime/flan_dyn.c`):
|
||||||
|
|
||||||
|
- A `defclass` instance is an ordinary dyn map with a `klass` field in the
|
||||||
|
`flan_obj` header (`flan_dyn.c:255`), set by `flan_dyn_map_new_class`
|
||||||
|
(`:1088`), read by `flan_dyn_class_of` (`:1100`). It is deliberately in the
|
||||||
|
header and not an entry, so `len`, `render` and `dyn_equal` do not see it.
|
||||||
|
- **Slots are keys.** `lib/classes.ml:150-175`: `(defclass point [x y])`
|
||||||
|
desugars to `(defn point [x dyn y dyn] dyn #point{:x x :y y})` and nothing
|
||||||
|
else. Access is `get`/`put` by keyword.
|
||||||
|
|
||||||
|
Two consequences, and the second is the one that surprised me:
|
||||||
|
|
||||||
|
1. **Name-based slot carrying — the hard half of
|
||||||
|
`update-instance-for-redefined-class` — is free here.** A dyn instance already
|
||||||
|
stores its slots by name. Any migration is a map operation.
|
||||||
|
2. **There is no class object at runtime to invalidate, because there is no class
|
||||||
|
registry at all.** The `klass` field holds an interned keyword, not a pointer
|
||||||
|
to a class descriptor. Redefining a `defclass` today is just redefining its
|
||||||
|
constructor `defn` — which the session already permits as an ordinary body
|
||||||
|
change. Old instances keep their old keys and keep working; new ones get the
|
||||||
|
new keys; `class-of` answers the same keyword for both. So the dyn side
|
||||||
|
currently has neither the refusal *nor* the protocol: it has silence.
|
||||||
|
|
||||||
|
Whether that silence is a bug depends on what the author wants. It is the
|
||||||
|
Clojure answer (a map is a map; a "class" is a tag) rather than the CLOS answer.
|
||||||
|
The CLOS answer would need, concretely:
|
||||||
|
|
||||||
|
- A runtime class registry: keyword → (slot-name list, generation counter).
|
||||||
|
Nothing like this exists today; `lib/classes.ml` is compile-time only and
|
||||||
|
emits a plain `defn`.
|
||||||
|
- A generation stamp per instance, or a cheaper trick: compare the instance's
|
||||||
|
key set against the registry's current slot list lazily on `get`/`put`. With
|
||||||
|
a generation word in the `flan_obj` header — there is room, and unlike the
|
||||||
|
typed side these objects *have* headers — the check is a compare.
|
||||||
|
- A migration step at first access after a bump: add missing slots as nil,
|
||||||
|
collect removed slots into a property list, and call a user hook. The obvious
|
||||||
|
Flan spelling of that hook is a generic function, e.g.
|
||||||
|
`(defmethod update-for-redefined point [p added discarded] ...)`, which fits
|
||||||
|
the dispatch mechanism that already exists.
|
||||||
|
- A decision on whether `put` of an unknown slot stays legal. Decided
|
||||||
|
2026-09-26: it does not; `get`, `put` and `set` refuse an unknown slot on an
|
||||||
|
instance at run time, so the registry's slot list is enforced.
|
||||||
|
|
||||||
|
This is a real, SBCL/CLOS-precedented design that Flan's runtime can actually
|
||||||
|
support. It is also a feature with no user yet, since redefinition on the dyn
|
||||||
|
side currently fails silently rather than loudly.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 6. Candidate designs
|
||||||
|
|
||||||
|
Three, none recommended over the others. Cost estimates are rough.
|
||||||
|
|
||||||
|
### A. Keep the refusal for typed structs and globals; fix the message
|
||||||
|
|
||||||
|
Leave `lib/session.ml` refusing, but rewrite both messages to say what SBCL's
|
||||||
|
restarts say: name which fields moved, were retyped, or were deleted (SBCL's
|
||||||
|
`compare-slots` split — Flan compares whole field lists and can cheaply do the
|
||||||
|
same split), and state the two things the author can do instead (restart, or
|
||||||
|
rename the type and migrate by hand). Optionally accept the case SBCL's
|
||||||
|
`mutable-layout-p` accepts and Flan currently refuses: **appending** fields to a
|
||||||
|
struct no array/FFI type depends on is layout-compatible for every existing
|
||||||
|
instance, so it need not be refused at all.
|
||||||
|
|
||||||
|
- Cost: small, days. Frontend only, no runtime change, no dev/release divergence.
|
||||||
|
- Behaviour: unchanged except the append case starts working and the diagnostic
|
||||||
|
names the offending field.
|
||||||
|
- Precedent: SBCL refuses by default too — this is the `%redefine-defstruct`
|
||||||
|
error with no restart taken, plus `compare-slots`' finer classification. The
|
||||||
|
"SBCL warns instead of refusing" premise these notes were written to check
|
||||||
|
does not survive
|
||||||
|
contact with the source, so "keep refusing" is the SBCL-consistent option, not
|
||||||
|
the timid one.
|
||||||
|
|
||||||
|
### B. Dev-build struct version word — SBCL's layout generation, collapsed
|
||||||
|
|
||||||
|
Stamp every dev-build struct instance with the type's generation at
|
||||||
|
construction; bump the generation on an incompatible redefinition; check the
|
||||||
|
stamp on field access in dev builds and trap with "this value was built before
|
||||||
|
`Cursor` changed shape" instead of refusing the reload. Release builds carry
|
||||||
|
neither word nor check, which is plan.org's dev/release table as written.
|
||||||
|
|
||||||
|
- Cost: large. Touches layout, both backends, arrays and `Vec`s of structs, FFI
|
||||||
|
boundary exclusions, and every field-access site; the dev/release layout
|
||||||
|
divergence becomes observable wherever a struct crosses to C. This is the one
|
||||||
|
that wants a written design before any code.
|
||||||
|
- Behaviour: the reload is accepted and the program keeps running; stale values
|
||||||
|
trap loudly at first touch rather than reading wrong offsets. It does **not**
|
||||||
|
let old values keep working — no migration is possible for a flat unboxed
|
||||||
|
struct — so it converts a pre-run refusal into a mid-run trap. Globals are not
|
||||||
|
covered and still need option A's refusal.
|
||||||
|
- Precedent: SBCL's `%invalidate-layout` plus the obsolete-instance trap, with
|
||||||
|
the layout pointer replaced by an immediate because Flan instances have no
|
||||||
|
headers. Note that SBCL, having the same choice, still puts the error in the
|
||||||
|
redefinition path *as well* and requires a restart to reach the trap state.
|
||||||
|
|
||||||
|
### C. CLOS-style update for dyn `defclass` instances only
|
||||||
|
|
||||||
|
Give `defclass` a runtime registry (keyword → slots + generation), stamp a
|
||||||
|
generation into the `flan_obj` header beside `klass`, and on the first `get`/`put`
|
||||||
|
after a bump, migrate the instance: add new slots as nil, gather removed slots
|
||||||
|
into a list, and dispatch a user-overridable generic `update-for-redefined`
|
||||||
|
before returning. Typed structs and globals are untouched and keep option A's
|
||||||
|
refusal.
|
||||||
|
|
||||||
|
- Cost: medium and well-contained — `runtime/flan_dyn.c` header field plus a
|
||||||
|
registry, `lib/classes.ml` emitting the registration, one lazy check on the map
|
||||||
|
access path. It rides on machinery that already exists: headers, interned
|
||||||
|
keyword tags, generic dispatch, and slots that are already addressed by name.
|
||||||
|
- Behaviour: redefining a class stops being silent. Instances survive
|
||||||
|
redefinition with their shared slots intact, new slots appear as nil, and the
|
||||||
|
author can write the coordinate-change-style migration by hand. The risk is
|
||||||
|
that it is a ceremony on top of maps that are already open — if `put` of an
|
||||||
|
arbitrary key stays legal, the registry describes an intention rather than a
|
||||||
|
constraint.
|
||||||
|
- Precedent: this *is* CLHS 4.3.6 and `update-instance-for-redefined-class`, the
|
||||||
|
only part of CL's story that is a standard protocol rather than an
|
||||||
|
implementation's policy, and the only part whose prerequisites Flan already
|
||||||
|
satisfies.
|
||||||
|
|
||||||
|
B and C are independent and could both happen, or neither. A is close to free
|
||||||
|
and is compatible with both.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## Sources
|
||||||
|
|
||||||
|
- SBCL source, `src/code/defstruct.lisp` (`%redefine-defstruct`, `compare-slots`,
|
||||||
|
`redefine-structure-warning`, `mutable-layout-p`, restart texts) —
|
||||||
|
<https://github.com/sbcl/sbcl/blob/master/src/code/defstruct.lisp>
|
||||||
|
- SBCL source, `src/code/class.lisp` (`%invalidate-layout`, `register-layout`,
|
||||||
|
`layout-invalid`) — <https://github.com/sbcl/sbcl/blob/master/src/code/class.lisp>
|
||||||
|
- SBCL source, `src/pcl/std-class.lisp` (`obsolete-structure` condition,
|
||||||
|
`%obsolete-instance-trap`, `make-instances-obsolete`, `invalid-wrapper-p`,
|
||||||
|
`replace-wrapper-and-slots`) —
|
||||||
|
<https://github.com/sbcl/sbcl/blob/master/src/pcl/std-class.lisp>
|
||||||
|
- CLHS 4.3.6 Redefining Classes —
|
||||||
|
<https://www.lispworks.com/documentation/HyperSpec/Body/04_cf.htm>
|
||||||
|
- CLHS `update-instance-for-redefined-class` —
|
||||||
|
<https://www.lispworks.com/documentation/HyperSpec/Body/f_upda_1.htm>
|
||||||
|
- CLHS `defparameter`/`defvar` —
|
||||||
|
<https://www.lispworks.com/documentation/HyperSpec/Body/m_defpar.htm>
|
||||||
|
- SBCL Internals, Local Calls — <http://www.sbcl.org/sbcl-internals/Local-Calls.html>
|
||||||
|
- Block compilation in SBCL 2.0.2 —
|
||||||
|
<https://mstmetent.blogspot.com/2020/02/block-compilation-fresh-in-sbcl-202.html>
|
||||||
|
- Lisp journey, "Structures: lightweight records" (the user-visible restart menu)
|
||||||
|
— <https://lisp-journey.gitlab.io/blog/data-structures-structs/>
|
||||||
|
|
||||||
|
The SBCL *manual* (<https://www.sbcl.org/manual/>) does not document structure
|
||||||
|
redefinition, obsolete instances or layout invalidation at all — checked, and it
|
||||||
|
is silent. Everything in sections 1 and 4 above comes from source and mailing
|
||||||
|
list/blog material, not from the manual.
|
||||||
|
|
||||||
|
### Marked unverified
|
||||||
|
|
||||||
|
- The exact condition signalled when a *compiled typed accessor* (as opposed to
|
||||||
|
the PCL path) is applied to an instance with an invalidated layout. Stated
|
||||||
|
above as "an ordinary `type-error`"; I did not read the accessor emission in
|
||||||
|
`src/compiler/`, so treat the specific condition name as unverified. The
|
||||||
|
`sb-pcl::obsolete-structure` text is verified from `src/pcl/std-class.lisp`.
|
||||||
|
- Whether SBCL's `compare-slots` classification ever *avoids* the error for a
|
||||||
|
pure append (i.e. whether appending slots is accepted silently). The
|
||||||
|
`mutable-layout-p` gate on `recklessly-continue` strongly implies a
|
||||||
|
compatible-layout notion exists, but I did not confirm the append case is
|
||||||
|
error-free.
|
||||||
@@ -0,0 +1,604 @@
|
|||||||
|
# The duplicity audit: where the two sides meet, and where one side repeats itself
|
||||||
|
|
||||||
|
> **Nothing was built.** This is a reading of `lib/check.ml`, `lib/types.ml`, `lib/emit.ml`,
|
||||||
|
> `runtime/flan_dyn.c`, `lib/prelude.ml`, `vendor/edn/read.flan`, `plan.org` and `spec-memory.md`, with
|
||||||
|
> twenty-odd probe programs run through `_build/default/bin/main.exe check|emit|run` where a probe settles
|
||||||
|
> something a reading cannot. Every claim below is either cited to a line or reproduced from a probe whose
|
||||||
|
> output is quoted. Read against `dev-loop` at `5bd25b6`. A sibling lane is implementing dyn on the x86
|
||||||
|
> backend; nothing here turns on it.
|
||||||
|
|
||||||
|
The doctrine being audited: **every capability has two sides, and the rule is never to repeat yourself on
|
||||||
|
the same one.** The dyn side is tagged, GC-heap, heterogeneous, unannotated, and wrong at run time. The
|
||||||
|
native side is untagged, allocator-managed, annotated, and wrong at compile time. A dyn vec and a `(Vec T)`
|
||||||
|
are two implementations of one idea and that is correct; two implementations on the *same* side is the
|
||||||
|
smell. SBCL is the named model for the error half: derive what is derivable at compile time, be dynamic
|
||||||
|
where it is not.
|
||||||
|
|
||||||
|
The audit found **one memory-safety hole**, **three silent acceptances that should be refusals**, **two
|
||||||
|
capabilities the typed side lacks and the runtime already implements**, and **two same-side duplications
|
||||||
|
ready to retire**. Ranked questions are in §B; the duplications are in §C.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 0. The first correction: the doctrine's "no annotations" is not what shipped
|
||||||
|
|
||||||
|
The doctrine says the dyn side takes no annotations. The implementation takes no *parameter* annotations.
|
||||||
|
The return slot is mandatory and always was — `HANDOFF-dyn-m1.md:9-19` records the decision and its reason,
|
||||||
|
which is structural rather than a TODO: an optional return slot has no syntactic resolution, because
|
||||||
|
`(defn f [] (Rune {.code 65}) (bar))` is both a type application and a struct literal in the same position,
|
||||||
|
and that misparse is what removed the old optional slot.
|
||||||
|
|
||||||
|
The probe confirms it. `(defn f [x] (print x))`:
|
||||||
|
|
||||||
|
```
|
||||||
|
e4.flan:1:13: print takes no type arguments — generics are milestone 5
|
||||||
|
```
|
||||||
|
|
||||||
|
`(print x)` was read as the return *type*. Every dyn function in this document is spelled
|
||||||
|
`(defn f [x] dyn ...)`, with `dyn` written out.
|
||||||
|
|
||||||
|
**Verdict: doctrine-vs-implementation mismatch, benign but load-bearing.** It means the author's sketching
|
||||||
|
case — `(defn settle [row col] ...)` — is still not writable, which is `SPIKE-INFERENCE.md`'s answer
|
||||||
|
arrived at from the other direction (`docs/SPIKE-INFERENCE.md:17-20`: that spelling "provably cannot be
|
||||||
|
given the meaning they want"). It also flattens item 3 below: neither `[x $t]` nor `[x]` frees anybody from
|
||||||
|
writing a return type, so the choice between them is never about annotation volume.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 1. Absence — Option on one side, nil on the other
|
||||||
|
|
||||||
|
**There is no nil.** Not "two absence systems"; one, plus a documented value with no producer.
|
||||||
|
|
||||||
|
```
|
||||||
|
$ flan check a1.flan # (defn f [] dyn nil)
|
||||||
|
a1.flan:1:16: unknown name nil
|
||||||
|
```
|
||||||
|
|
||||||
|
`flan_dyn_nil` is defined in the runtime (`runtime/flan_dyn.c:696`), in the stub
|
||||||
|
(`runtime/flan_dyn_stub.c:80`), declared in the ABI (`runtime/flan_dyn.h:35`), declared to LLVM
|
||||||
|
(`lib/emit.ml:3001`), and exercised eleven times in `test/dyn_ops.c`. **No path in `lib/check.ml`
|
||||||
|
constructs one.** The dyn side's absence value is reachable from C and from nothing a Flan program can
|
||||||
|
write.
|
||||||
|
|
||||||
|
The sharpest thing in the audit is what stands in its place. `box` refuses `Unit` with this
|
||||||
|
(`lib/check.ml:1436-1439`):
|
||||||
|
|
||||||
|
> `()` does not box into dyn — a value of the zero-sized type carries nothing a dyn could hold. The absent
|
||||||
|
> dyn value is **nil, which is what an `if` with no else branch answers here**.
|
||||||
|
|
||||||
|
The message describes behaviour the compiler does not implement. `(defn f [x] dyn (if x 1))` does not
|
||||||
|
answer nil; it is refused, by that very message:
|
||||||
|
|
||||||
|
```
|
||||||
|
a2.flan:1:17: () does not box into dyn — ... The absent dyn value is nil, which is what an if
|
||||||
|
with no else branch answers here
|
||||||
|
```
|
||||||
|
|
||||||
|
The sentence is a design note that reads as a description. A user following it writes the form it names and
|
||||||
|
gets the refusal that names it.
|
||||||
|
|
||||||
|
`(Option dyn)` checks clean (probe `a3`) and is coherent: `Option` is a two-case data type decided
|
||||||
|
structurally in the checker (`lib/check.ml:3025-3033`) and never desugared, so its payload type is
|
||||||
|
unconstrained; `owning` walks `Option e` into `e` (`lib/check.ml:451`) and `Dyn` owns nothing, so no region
|
||||||
|
rule fires.
|
||||||
|
|
||||||
|
**Verdict: undecided-needs-author, but simpler than the brief assumes.** There is one reachable absence
|
||||||
|
system today, not two. The conflict is prospective, and the decision is not "reconcile two systems" but
|
||||||
|
"what may produce a nil, and what does one do at a typed boundary". The three coherent answers:
|
||||||
|
|
||||||
|
1. **`nil` is never produced.** Delete the sentence at `check.ml:1436-1439`, keep the `Unit` refusal, and
|
||||||
|
let `(Option dyn)` be the dyn side's absence too. Cheapest, and loses the Clojure feel.
|
||||||
|
2. **`nil` is produced and unboxes to a trap.** Symmetrical with every other `need_*`: `flan_dyn_need_i64`
|
||||||
|
of a nil traps exactly as it traps on a text.
|
||||||
|
3. **`nil` is produced and unboxes to `None` at an `(Option T)` want.** The only answer that makes the two
|
||||||
|
absence systems one, and the only one that puts an implicit conversion at the boundary
|
||||||
|
`check.ml:1367-1380` exists to keep sharp — "nowhere else does the compiler decide a dyn is an i64 on its
|
||||||
|
own", and this would be the compiler deciding a dyn is a `None`.
|
||||||
|
|
||||||
|
Related, and not in the brief's ten: **truthiness**. `(defn f [x] dyn (if x 1 2))` checks and runs, and the
|
||||||
|
condition goes through `flan_dyn_need_bool` (`lib/check.ml:1455-1459`), so a dyn `if` is strict-bool — a nil
|
||||||
|
or an int in the condition traps. `plan.org:908-910` declares the CL-vs-Clojure truthiness question "moot
|
||||||
|
under static typing". **It is not moot on the dyn side**, and the strict-bool answer is currently the one
|
||||||
|
that fell out rather than the one that was chosen.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 2. Equality and ordering — not two meanings, one side missing a case
|
||||||
|
|
||||||
|
**Landed in `daed039`** (M2 queue item 5): typed `=` and `!=` now grow the `string` case this section argues
|
||||||
|
for, bytewise, with the fast paths `runtime/flan_rt.c`'s `flan_str_eq` carries. `is_equatable` is no longer a
|
||||||
|
bare alias for `is_comparable` — `lib/types.ml` now reads `let is_equatable = function String -> true | t ->
|
||||||
|
is_comparable t` — and the transcript below, quoted as this section found it, now accepts `(= "hi" "hi")`.
|
||||||
|
Ordering was deliberately left alone: `<` and friends still refuse a string, on the same "no collation this
|
||||||
|
language has picked" grounds §2 raises, and that half of the verdict did not land. What follows is kept as
|
||||||
|
the historical argument that got the equality half moving; read the two paragraphs above as its outcome, not
|
||||||
|
as a correction of anything past this point.
|
||||||
|
|
||||||
|
Typed `=` is numbers and enums and nothing else, as this was written. `lib/types.ml:166-168` then read:
|
||||||
|
|
||||||
|
```ocaml
|
||||||
|
let is_comparable = function Enum _ -> true | t -> is_numeric t
|
||||||
|
let is_equatable = is_comparable
|
||||||
|
```
|
||||||
|
|
||||||
|
`is_equatable` is a bare alias for `is_comparable`. The dyn `=` is structural over everything and is the one
|
||||||
|
dyn operation that never traps (`SPIKE-DYNAMIC.md:285-287`), and dyn `<` orders text bytewise by `memcmp`
|
||||||
|
(`SPIKE-DYNAMIC.md:273-275`).
|
||||||
|
|
||||||
|
One probe, both operators, one line apart — as run before `daed039`; the second `print` now accepts too:
|
||||||
|
|
||||||
|
```
|
||||||
|
$ flan check b3.flan
|
||||||
|
(defn f [x] dyn x)
|
||||||
|
(defn main [] i32 (do (print (= (f "hi") (f "hi"))) ; accepted
|
||||||
|
(print (= "hi" "hi")) ; refused, at the time
|
||||||
|
0))
|
||||||
|
b3.flan:2:64: = compares machine numbers; string has no built-in comparison (plan.org, Types)
|
||||||
|
```
|
||||||
|
|
||||||
|
And the generic side inverts the same way (`d1`):
|
||||||
|
|
||||||
|
```
|
||||||
|
d1.flan:2:32: this call instantiates biggest at $t = string, and string does not answer is-ordered
|
||||||
|
```
|
||||||
|
|
||||||
|
while `(defn biggest-d [a b] dyn (if (> a b) a b))` at `"a"` and `"b"` checks clean (`c2`).
|
||||||
|
|
||||||
|
The reflex reading is "same operator, two meanings — trap". It is the wrong reading, because it treats the
|
||||||
|
dyn answer as the anomaly. The dyn answer is *right*, it is cheap, and **the code that implements it already
|
||||||
|
exists on the typed side too**: `flan_hash_str` and the map's string equality
|
||||||
|
(`runtime/flan_rt.c:1939`, and `Types.keyable` says `String -> true` at `lib/types.ml:156`). So the typed
|
||||||
|
side already has a string equality good enough to key a `(Map string V)` — and refuses to let a program call
|
||||||
|
`=` on two strings.
|
||||||
|
|
||||||
|
That is **same-side duplication in the making, on the typed side**: `keyable` and `is_equatable` are two
|
||||||
|
answers to "does this type have an equality", they disagree about `string`, and one of them is a `Map`
|
||||||
|
implementation detail rather than a language rule.
|
||||||
|
|
||||||
|
The four-predicate ceiling is where it shows. `predicate_names` is exactly `[ "is-ordered"; "is-equal";
|
||||||
|
"is-hashable"; "is-numeric" ]` (`lib/check.ml:412`), and `pred_entails` (`lib/check.ml:490-497`) admits its
|
||||||
|
table is "only sound while" ordered ⊆ equatable holds — which is only true *because* the set is so small.
|
||||||
|
`lib/prelude.ml:247-248` says the quiet part: `sort-bytes` exists as a hand-written `sort-by` because "a
|
||||||
|
`[[u8]]` is not `[is-ordered]` **and cannot be**".
|
||||||
|
|
||||||
|
**Verdict: same-side gap on the typed side, not a boundary conflict.** The author's question is not "which
|
||||||
|
meaning wins" — it is whether typed `=` and `is-ordered` grow the `string` case the runtime already implements
|
||||||
|
with `memcmp`. Growing them retires `sort-bytes`, unifies `keyable` with `is_equatable`, and makes the two
|
||||||
|
sides agree on strings at no representational cost.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 3. Generics and dyn — two ways to take "any type", and they are not the same way
|
||||||
|
|
||||||
|
Both `[x $t]` and `[x]` take a value whose type is not written. The difference is *where the operations on
|
||||||
|
it are checked*, and it is total:
|
||||||
|
|
||||||
|
- A generic is checked **at the definition**. An operator over a type variable with no predicate asserting
|
||||||
|
it is refused there, at the `defn`, before any call exists (`lib/check.ml:976-990`, and
|
||||||
|
`SPIKE-INFERENCE.md:26-29` quotes the refusal: "`+` over the type variable `t` is refused"). The call site
|
||||||
|
then re-checks the predicate against the concrete type (`d1` above, and `pred_holds` at
|
||||||
|
`lib/check.ml:471-483`).
|
||||||
|
- A dyn parameter is checked **nowhere**. `(defn f [x] dyn (+ x "a"))` checks clean; it traps at run time
|
||||||
|
(probe `a6`): `dyn +: int and text, and it takes two numbers — (+ 1 "a")`.
|
||||||
|
|
||||||
|
So they overlap on exactly one function — `id` — and diverge on every function with an operator in it. The
|
||||||
|
generic is monomorphised and costs nothing; the dyn is tagged, heap-allocating and rooted
|
||||||
|
(`emit.ml:705`: a rooted alloca escapes through `flan_dyn_root_push`, so mem2reg cannot promote it, at every
|
||||||
|
optimisation level).
|
||||||
|
|
||||||
|
The user's rule falls out and needs no new machinery to state: **write `[x $t]` when the operation is the
|
||||||
|
same for every type and the caller knows which; write `[x]` when the operation *depends* on the type and
|
||||||
|
nobody knows it until the value arrives.** `sort` is the first; a config reader is the second.
|
||||||
|
|
||||||
|
**Verdict: clean.** Genuine duplicity, correctly placed. With the caveat that the four-predicate ceiling of
|
||||||
|
§2 is what makes the generic side look weaker than it is: a generic can only express the four questions the
|
||||||
|
compiler has builtins for, so every capability outside that set reads as "use dyn" when the honest answer is
|
||||||
|
"the predicate does not exist yet".
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 4. Conditions — the refusal is right, and its absence everywhere else is the hole
|
||||||
|
|
||||||
|
`signal` refuses a dyn condition and a condition with a dyn *field*, each by name
|
||||||
|
(`lib/check.ml:1976-2005`). Probe `f1`:
|
||||||
|
|
||||||
|
```
|
||||||
|
f1.flan:2:31: dyn does not cross into a written type yet — the field payload of the condition Oops
|
||||||
|
is one, and a payload has to stay rooted across a handler transfer, which is milestone 2
|
||||||
|
```
|
||||||
|
|
||||||
|
The reason given is exact and correct: a payload crosses a handler boundary as a pointer to a frame that is
|
||||||
|
still alive, and a dyn in it has to stay rooted across a transfer the root stack knows nothing about.
|
||||||
|
|
||||||
|
**But an ordinary `defstruct` with a dyn field is accepted, and nothing roots it.** Probes `e2`, `e5`, `e7`,
|
||||||
|
`f3` all check clean:
|
||||||
|
|
||||||
|
```lisp
|
||||||
|
(defstruct S [x dyn])
|
||||||
|
(defonce boxes (Vec S))
|
||||||
|
(defn stash [] () (push boxes (S {.x (vec-new dyn)})))
|
||||||
|
```
|
||||||
|
|
||||||
|
`flan emit f3.flan` shows what happens:
|
||||||
|
|
||||||
|
```llvm
|
||||||
|
%dr0 = alloca i64
|
||||||
|
call void @flan_dyn_root_push(ptr %dr0)
|
||||||
|
%t1 = call i64 @flan_dyn_vec_new()
|
||||||
|
```
|
||||||
|
|
||||||
|
One root — the *temporary*, for the duration of `stash`'s frame. It is popped at the `ret`. After that the
|
||||||
|
dyn vec's only reference is `S.x`, inside a `(Vec S)` whose storage belongs to an allocator the collector
|
||||||
|
never traces. The next allocation collects a live object.
|
||||||
|
|
||||||
|
Nothing in the tree refuses this. `box` has no arm for it — a `Named` type is refused only when it is being
|
||||||
|
*boxed into* dyn (`lib/check.ml:1450-1452`), not when it *contains* one. `dyn_roots`
|
||||||
|
(`lib/emit.ml:710`) counts nodes, not fields. `dyn_sites`, the `--no-gc` pass, walks globals' types,
|
||||||
|
parameters, the return type and `flan_dyn*` call nodes (`lib/check.ml:7104-7136`) — **not struct fields**, so
|
||||||
|
`(defstruct S [x dyn])` passes `--no-gc` (probe `e6`, clean). That last one is vacuous today, since filling
|
||||||
|
the field needs a `flan_dyn*` call which the pass does catch; it will stop being vacuous the moment a typed
|
||||||
|
container boxes into dyn.
|
||||||
|
|
||||||
|
`SPIKE-DYNAMIC.md:402-406` names the machinery that is missing: "a handle to a typed `(Vec Enemy)` would
|
||||||
|
need the collector to know which fields of `Enemy` are dyn, and a per-type descriptor emitted by the
|
||||||
|
compiler is how that arrives." The descriptor is M2. The *field* is M1 and is already writable.
|
||||||
|
|
||||||
|
**Verdict: conflict, and the most urgent one in this document.** Not a design conflict — an implementation
|
||||||
|
hole the design already knows how to close, protected in exactly one place and open everywhere else. Whether
|
||||||
|
the dyn side needs its own signal story is the *second* question and the easy one: typed payloads serve both
|
||||||
|
sides fine, because the answer to "I want a dyn in my condition" is the same as the answer to "I want a dyn
|
||||||
|
in my struct", and both wait on the same descriptor.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 5. Collections — the dyn side is one third built, and `edn/Value` is the other two thirds
|
||||||
|
|
||||||
|
What the dyn runtime has: a vec, mutable, GC-owned (`runtime/flan_dyn.c`, `OBJ_VEC`). What it does not have:
|
||||||
|
a **map**, a **set**, and **keywords**. There are three object kinds — `OBJ_TEXT | OBJ_VEC | OBJ_INT`
|
||||||
|
(`SPIKE-DYNAMIC.md:108`) — and four spare box tags (`SPIKE-DYNAMIC.md:57`).
|
||||||
|
|
||||||
|
Keywords are not absent by oversight; they are *typed-side only, at compile time*. `plan.org:920-923`:
|
||||||
|
"`:space` resolves at compile time against the parameter's enum type... **No runtime cost.**" That is a
|
||||||
|
different thing from EDN's `Key`, which is a value that exists at run time and can be a map key nobody
|
||||||
|
declared.
|
||||||
|
|
||||||
|
Meanwhile `vendor/edn/read.flan:71-80` is a complete tagged dynamic value, hand-written in typed Flan:
|
||||||
|
|
||||||
|
```lisp
|
||||||
|
(defdata Value
|
||||||
|
[(Nil []) (Bool [b bool]) (Int [n i64]) (Float [x f64]) (Text [s string])
|
||||||
|
(Key [s string]) (List [items (Vec Value)]) (Set [items (Vec Value)])
|
||||||
|
(Table [entries (Map string Value)])])
|
||||||
|
```
|
||||||
|
|
||||||
|
with its own structural equality, `value=?` (`read.flan:99`), its own list equality (`:116`), its own set
|
||||||
|
equality (`:128`), its own table equality (`:145`). Every one of those is an operation `flan_dyn_eq`
|
||||||
|
implements (`SPIKE-DYNAMIC.md:283-300`).
|
||||||
|
|
||||||
|
Counted by *capability* rather than by implementation language, this is unambiguous: `Value` and the dyn
|
||||||
|
runtime both answer "a heterogeneous value that carries its type at run time". **One capability, two
|
||||||
|
implementations, same side.** The author's lean is right.
|
||||||
|
|
||||||
|
The price is worth stating precisely, because it is the whole of the decision:
|
||||||
|
|
||||||
|
| `Value` has | dyn has | what closing the gap costs |
|
||||||
|
|---|---|---|
|
||||||
|
| `Nil` | `flan_dyn_nil`, unreachable from source (§1) | a producer and a boundary rule |
|
||||||
|
| `Bool`/`Int`/`Float`/`Text` | all four | nothing |
|
||||||
|
| `List` | vec | nothing |
|
||||||
|
| `Key` | — | a fifth object kind or a spare tag; interning if `=` is to stay O(1) |
|
||||||
|
| `Table` | — | a fourth object kind, a structural hash over tags, ordering for iteration |
|
||||||
|
| `Set` | — | **hardest**: `keyable` refuses `Value`-shaped keys (`read.flan:57-62`), so a dyn set cannot just be a dyn map either; `Value.Set` is an O(n) vec for exactly that reason and says so (`read.flan:64-69`) |
|
||||||
|
|
||||||
|
The M2 shape that falls out: **`OBJ_MAP` on tag 3 as a fourth kind, keywords as a fifth, and a dyn set as a
|
||||||
|
dyn map to a unit** — which works on the dyn side precisely because `flan_dyn_eq` has no `keyable`
|
||||||
|
restriction to run into. The thing `Value` cannot do, dyn can, and that is the argument for the retirement
|
||||||
|
rather than against it.
|
||||||
|
|
||||||
|
Note the counterpart landed on the *other* side while this audit was being written: **the type-provider lane
|
||||||
|
has merged to `dev-loop`** — `(edn/defedn Tileset "assets/tileset.edn")` derives a struct from the file at
|
||||||
|
expansion time (`lib/parse.ml:1321`, `lib/check.ml:4702`, `lib/macro.ml:302`, `docs/BUILT.md:5810-5830`),
|
||||||
|
`defjson` is the same over a different grammar and shares "the design and not the code"
|
||||||
|
(`docs/BUILT.md:5944-5960`), and `macro-slurp` is the prelude half (`lib/prelude.ml:1822-1830`).
|
||||||
|
`docs/PORTING.md:633-637` marks `read-edn` built under that name. So the data-file capability now has both
|
||||||
|
its sides in the tree at once: `defedn` is the perf side (a struct, at compile time), and a dyn map with no
|
||||||
|
struct given is the dynamic side. **`Value` is neither.** It is the dynamic side, written before the dynamic
|
||||||
|
side existed.
|
||||||
|
|
||||||
|
**Verdict: same-side duplication, retire — sequenced behind a dyn map and dyn keywords.** Retiring it before
|
||||||
|
those land would delete the only thing in the tree that can read a config file whose keys are unknown.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 6. Strings — a one-way door
|
||||||
|
|
||||||
|
Typed `string` is a builtin ptr+len, non-owning, the same shape as a slice (`lib/types.ml:22`, and the
|
||||||
|
`Allocator` comment at `:35` calls it "a builtin ptr+len"). It appears in no arm of `owning`
|
||||||
|
(`lib/check.ml:449-459`), which is the operational statement that it borrows: a `(Vec string)` is not
|
||||||
|
region-only, because the strings in it own nothing to release.
|
||||||
|
|
||||||
|
Dyn text is the opposite: immutable, length-prefixed, **copied on construction**, owned by the collector
|
||||||
|
(`SPIKE-DYNAMIC.md:118-121`).
|
||||||
|
|
||||||
|
Typed → dyn works and copies, via `flan_dyn_from_bytes` (`lib/check.ml:1430`). The copy is not a wart, it is
|
||||||
|
forced, and `vendor/edn/read.flan:41-47` already wrote the argument for the same case: a view handed back
|
||||||
|
out of the function that owns the buffer is "garbage with nothing to say so" once the caller reads the next
|
||||||
|
file into it. A dyn value can outlive any frame, so a dyn text must own its bytes. Correct.
|
||||||
|
|
||||||
|
Dyn → typed is **refused outright**. Probe `b5`:
|
||||||
|
|
||||||
|
```
|
||||||
|
b5.flan:2:20: string does not cross into a written type yet
|
||||||
|
```
|
||||||
|
|
||||||
|
`unbox` has arms for `i64`, `f64` and `bool` and a catch-all refusal for everything else
|
||||||
|
(`lib/check.ml:1450-1474`). So a program can put a string into dyn and can never get it back as a `string`.
|
||||||
|
It can get the *bytes* — `flan_dyn_at` answers a byte as an int (`SPIKE-DYNAMIC.md:304-305`) — one at a
|
||||||
|
time.
|
||||||
|
|
||||||
|
The refusal is understandable and the reason is not a representation problem: a `string` is ptr+len and the
|
||||||
|
text object's bytes are right there inline after the header. It is a **lifetime** problem, and the same one
|
||||||
|
§4 has. A `string` borrowed out of a GC object is valid until the next collection, and nothing in the
|
||||||
|
language says so.
|
||||||
|
|
||||||
|
**Verdict: conflict.** Dyn text is a one-way door today, which makes every string-shaped dyn program a
|
||||||
|
dead end at the moment it wants a typed function. Three exits: a copying `(string-of d alloc)` into a named
|
||||||
|
allocator (safe, explicit, the arena idiom already in the language); a borrowing one that is valid until the
|
||||||
|
next collection (fast, and needs a rule the language has no vocabulary for); or leave it refused and make
|
||||||
|
the dyn side's own string operations complete enough that nobody wants out. The first is the one that fits
|
||||||
|
`spec-memory.md`.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 7. Allocators vs the GC — the refusal is written for the spelling nobody uses
|
||||||
|
|
||||||
|
`(vec-new dyn alloc)` is refused by name, with a good sentence (`lib/check.ml:4094-4100`):
|
||||||
|
|
||||||
|
> `(vec-new dyn)` takes no allocator — the dyn container's storage is the dyn runtime's, which is what lets
|
||||||
|
> the collector find the values inside it.
|
||||||
|
|
||||||
|
But **`(with-allocator arena (vec-new dyn))` is accepted in silence.** Probes `b4` and `c5` both check
|
||||||
|
clean. The ambient allocator is not consulted, not refused, not mentioned.
|
||||||
|
|
||||||
|
That is the wrong way round, because of what `spec-memory.md` decided. The allocator is in the *calling
|
||||||
|
convention* — `vendor/edn/read.flan:11-18` states the consequence plainly: "`read` takes no allocator and
|
||||||
|
names none. It does not need to: spec-memory.md puts the allocator in the calling convention, so every
|
||||||
|
`(vec-new)` and `(map-new)` below takes the *context*". The explicit allocator argument is the rare
|
||||||
|
spelling; `with-allocator` is the idiom the whole language is written in. The compiler refuses the spelling
|
||||||
|
a user almost never writes and says nothing about the one they always do.
|
||||||
|
|
||||||
|
`check.ml:627` and `:1289` both record that `with-allocator` "rebinds a dynamic variable, so the tier a
|
||||||
|
`(vec-new)` will meet is not a property of where the type is written" — so the checker cannot in general
|
||||||
|
know statically which allocator is ambient. It does not have to: the question here is not *which* allocator,
|
||||||
|
it is whether an enclosing `with-allocator` is a lie when the form under it ignores it.
|
||||||
|
|
||||||
|
**Verdict: conflict — silent acceptance where a refusal or a note is owed.** The user's model of
|
||||||
|
`with-allocator` is "everything allocated in here comes from this"; a dyn construction is the one exception,
|
||||||
|
and the exception is invisible. The author's call: refuse a dyn construction lexically inside a
|
||||||
|
`with-allocator`, warn, or write the exception down and accept it. Refusing is probably too strong —
|
||||||
|
`(with-allocator frame (edn/read bytes))` will want to hold a dyn somewhere — which makes this a
|
||||||
|
documentation-plus-note decision rather than a checker one.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 8. `defstruct` vs `defclass` — the class is dyn with named slots, minus one thing
|
||||||
|
|
||||||
|
`plan.org:132-190` designs `defclass` and it predates dyn entirely. Read its ingredient list against what
|
||||||
|
the dyn runtime now has:
|
||||||
|
|
||||||
|
| `defclass` needs (plan.org) | dyn already is |
|
||||||
|
|---|---|
|
||||||
|
| "runtime class/shape metadata" (`:157`) | the tag, and `flan_dyn_tag_name` |
|
||||||
|
| identity, so a class instance is not a value that copies (`:135`) | a `flan_obj *`; `test_dyn`'s `sharing` mode asserts identity, not just equality (`SPIKE-DYNAMIC.md:561`) |
|
||||||
|
| "a managed allocation strategy" (`:157`) | the mark-sweep heap |
|
||||||
|
| "A small tracing GC confined to class instances remains an option" (`:161`) | built, and confined to exactly dyn values |
|
||||||
|
| live schema change, "existing instances at their old layout until an explicit migration" (`:173-176`) | a heterogeneous object has no layout to be stale |
|
||||||
|
|
||||||
|
Five of five. Building `defclass` as a third memory model — a third answer to identity, a third allocation
|
||||||
|
strategy, a third metadata scheme — would be **same-side duplication on the managed side**, and by the
|
||||||
|
doctrine it is the thing not to do.
|
||||||
|
|
||||||
|
What the dyn side genuinely lacks, and what a `defclass` therefore *adds* rather than duplicates:
|
||||||
|
|
||||||
|
1. **Named slots.** There is no record kind; a dyn vec is positional. This is the same missing `OBJ_MAP` of
|
||||||
|
§5 — a class instance is a map from slot name to value with a declared slot set, which is a map with a
|
||||||
|
shape check.
|
||||||
|
2. **Dispatch.** `(defmethod update ((e Enemy) dt) ...)` — "exact-class, single-argument dispatch" first
|
||||||
|
(`plan.org:168-170`). The tag is already the dispatch key; a class id in the object header is the
|
||||||
|
extension.
|
||||||
|
3. **A declared slot set at all**, which is what makes the compile-time half possible: a `defclass` can
|
||||||
|
report an unknown slot where a dyn map cannot.
|
||||||
|
|
||||||
|
The one thing that does **not** collapse into dyn, and should stay where it is: `plan.org:157-160`'s "but
|
||||||
|
*not necessarily* a tracing GC — a world or session arena, pool allocation behind generational `(Handle T)`
|
||||||
|
values". That is the **typed** side's answer to identity and longevity, and it is a real second side of the
|
||||||
|
same capability, not a duplicate. A pooled `(Handle Enemy)` over a `defstruct` is the perf side; a `defclass`
|
||||||
|
is the managed side. Both should exist.
|
||||||
|
|
||||||
|
**Verdict: undecided-needs-author, with the doctrine's answer close to forced.** `defclass` is dyn plus
|
||||||
|
named slots plus dispatch, sharing one heap and one collector — not a third thing. The corollary, and the
|
||||||
|
part worth deciding early: `plan.org:192-194` says "Do not add classes until ordinary `struct`, `Handle`,
|
||||||
|
and reload semantics are working." Under this reading the gating item changed. Classes are now gated on the
|
||||||
|
**dyn side's map/record kind**, which is M2 and in flight, rather than on `Handle`.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 9. Print, hash, sort — one family already duplicated, two not yet
|
||||||
|
|
||||||
|
**Printing was duplicated three ways on one side, and it is not the dyn/typed split. Two of the three are
|
||||||
|
now one.** This section found three escape tables; the runtime dedupe lane took the two that were on the
|
||||||
|
same side and made them one function with two framings, which is what this section asked for. What is left
|
||||||
|
is the split it argued was correct.
|
||||||
|
|
||||||
|
The table lives once, as `flan_escape_char` (`runtime/flan_rt.c:388`), and both typed-side printers call
|
||||||
|
it: `flan_escape_bytes` (`:422`), which builds a capped slice for `print`, and `put_str`
|
||||||
|
(`runtime/flan_dev.c:302`), which streams into the inspector's fixed buffer so the REPL can parse the
|
||||||
|
printed form back. The framing is each caller's and is the part that is genuinely theirs; the switch is
|
||||||
|
shared, because two printers disagreeing about what a string looks like is two wire formats.
|
||||||
|
|
||||||
|
The dyn copy stays, as `emit_escaped` (`runtime/flan_dyn.c:472`), and says why at `:465-470`:
|
||||||
|
|
||||||
|
> This copy is deliberate, and the argument for it is docs/SPIKE-DUPLICITY.md §9's: the dyn printer lives
|
||||||
|
> inside the runtime that owns the storage it walks, which is why it prints a dyn vec structurally where
|
||||||
|
> the typed printer answers `<vec>`. The whole printer is this side's; the table it shares with the other
|
||||||
|
> side is the part that must not drift. If that table changes, change this one.
|
||||||
|
|
||||||
|
That is the defence `SPIKE-DYNAMIC.md` gives and this section accepted: a typed `Vec` prints as `<vec>`
|
||||||
|
because the typed printer will not walk storage it does not own, while a dyn vec's storage belongs to the
|
||||||
|
collector and the printer is inside the runtime that owns it. One copy per *side*, which is the doctrine.
|
||||||
|
Two tables is the answer; three was not.
|
||||||
|
|
||||||
|
**Hashing is typed-only.** `flan_hash_fn`, `flan_hash_flat`, `flan_hash_str`, `flan_hash_combine`
|
||||||
|
(`runtime/flan_rt.c:1807, 1911, 1939, 1954`), reached through `Types.keyable` and the checker's `key_pair`
|
||||||
|
walk. The dyn side has none, because it has no map. **Verdict: clean today, and the first thing M2 gets
|
||||||
|
wrong if it is careless** — a dyn map needs a structural hash over tags, and that hash must *call*
|
||||||
|
`flan_hash_mem`/`flan_hash_str` rather than re-derive them, or the family duplicates on the dyn side the way
|
||||||
|
printing duplicated on the typed one.
|
||||||
|
|
||||||
|
**Sorting is typed-only** — `sort` (`lib/prelude.ml:277`), `sort-by` (`:304`), `sort-bytes` (`:1399`).
|
||||||
|
Nothing is built on the dyn `lt`/`le`/`gt`/`ge`. `sort-bytes` is already a half-duplicate of `sort` that
|
||||||
|
exists only because `[[u8]]` cannot answer `is-ordered` (`lib/prelude.ml:247-248`) — so it is the §2 gap,
|
||||||
|
appearing in the prelude as an extra function.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 10. The SBCL lesson, concretely
|
||||||
|
|
||||||
|
SBCL's mechanism is a **type lattice plus an IR1 fixpoint**. `ir1-optimize-cast`
|
||||||
|
(`src/compiler/ir1opt.lisp:3765`) intersects the value's *derived* type with the *asserted* one; where the
|
||||||
|
intersection is empty the conflict is unconditional, and the node is rewritten to
|
||||||
|
`%compile-time-type-error` (`ir1opt.lisp:3837`), whose warner is `%compile-time-type-error-warn`
|
||||||
|
(`ir1util.lisp:4351`). That is a full `WARNING` at compile time, and the form is **still emitted**, so the
|
||||||
|
program that was warned about also signals at run time. What cannot be *proved* wrong is not dropped either:
|
||||||
|
`convert-type-check` (`src/compiler/checkgen.lisp:518`), driven by `generate-type-checks` (`:684`), lowers
|
||||||
|
the unprovable assertion to a run-time check.
|
||||||
|
|
||||||
|
Measured, not paraphrased — `sbcl --noinform --non-interactive` on `(defun f () (+ 1 "a"))` then calling it:
|
||||||
|
|
||||||
|
```
|
||||||
|
; caught warning:
|
||||||
|
; Constant "a" conflicts with its asserted type number.
|
||||||
|
; See also:
|
||||||
|
; The SBCL Manual, Node "Handling of Types"
|
||||||
|
;
|
||||||
|
; compilation unit finished
|
||||||
|
; caught 1 WARNING condition
|
||||||
|
|
||||||
|
#<simple-type-error expected-type: number datum: "a">
|
||||||
|
```
|
||||||
|
|
||||||
|
Both halves in one run: a compile-time `WARNING` naming the constant and the asserted type, **and** a
|
||||||
|
function that still exists and still signals. The warning changed the diagnostics and nothing else.
|
||||||
|
|
||||||
|
Two things carry over and one does not.
|
||||||
|
|
||||||
|
**Does not carry over: the derivation.** Flan has `Types.equal` and `fits` (`lib/types.ml:173`), and `fits`
|
||||||
|
is `equal` with one exception for `Never`. No lattice, no unions, no intersection, no fixpoint. "Derive the
|
||||||
|
type of every expression and intersect it with what is wanted" is not a change to `check.ml`; it is a
|
||||||
|
different `check.ml`. Anyone reading "be like SBCL" as "add type derivation" is reading a year of work into
|
||||||
|
a sentence.
|
||||||
|
|
||||||
|
**Carries over, and is nearly free: refuse at the site where the pre-box type is still in hand.** This is
|
||||||
|
the part worth doing. `box` (`lib/check.ml:1418`) and `dyn_fold` (`lib/check.ml:3414`) both receive the
|
||||||
|
*typed* expression before it is boxed — `dyn_fold`'s own comment says "the typed side of a mixed pair is
|
||||||
|
boxed on the way in". So at `(+ dyn-x "a")` the second operand's type is `Types.String`, sitting in a
|
||||||
|
variable, at the moment the compiler decides to emit `flan_dyn_add`. Today that compiles (probe `a6`) and
|
||||||
|
traps:
|
||||||
|
|
||||||
|
```
|
||||||
|
dyn +: int and text, and it takes two numbers — (+ 1 "a")
|
||||||
|
```
|
||||||
|
|
||||||
|
The trap message is written from information the *checker* had. One match in `dyn_fold` — if an operand's
|
||||||
|
pre-box type is known and no arm of the dyn operator accepts that tag, refuse — is SBCL's empty-intersection
|
||||||
|
case exactly, with no inference, no lattice and no new pass. It catches every literal and every typed
|
||||||
|
binding flowing into a dyn operator, which is most of what a beginner writes wrong, and it catches nothing
|
||||||
|
that is genuinely dynamic, which is the whole point.
|
||||||
|
|
||||||
|
**Carries over, and is the part to resist skipping: warn, and still emit.** SBCL's discipline is that a
|
||||||
|
compile-time type warning never changes what the program does. If Flan takes the refusal route instead, it
|
||||||
|
should be a refusal only where the conflict is unconditional — a known non-numeric tag into an arithmetic
|
||||||
|
operator — and never a refusal on a heuristic, because the dyn side's contract is that it runs.
|
||||||
|
|
||||||
|
One piece of evidence about how thin the typed side's own derivation is, since it bears on how much of SBCL
|
||||||
|
is even reachable from here. Fully typed `(+ 1 "a")` refuses like this (probe `a5`):
|
||||||
|
|
||||||
|
```
|
||||||
|
a5.flan:1:35: expected string, found the integer literal 1
|
||||||
|
```
|
||||||
|
|
||||||
|
It refused because the literal `1` adopted the type of the *second* operand and failed — not because `+`
|
||||||
|
rejects text. The typed side has no statement anywhere that `+` takes numbers; it has literal adoption and
|
||||||
|
`Types.equal`. That is worth knowing before promising SBCL-shaped diagnostics.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## A. The two sides, as the language stands
|
||||||
|
|
||||||
|
| capability | native side | dyn side | verdict |
|
||||||
|
|---|---|---|---|
|
||||||
|
| parameter types | written | omitted | clean |
|
||||||
|
| **return type** | written | **written** (`HANDOFF-dyn-m1.md:9-19`) | doctrine mismatch (§0) |
|
||||||
|
| integers | `i8`…`i64`, `u8`…`u64` | `i64` only, 48-bit inline + box | clean |
|
||||||
|
| floats | `f32`, `f64` | `f64` only | clean |
|
||||||
|
| absence | `(Option T)`, `Some`/`None` | `nil` — **unreachable from source** (§1) | undecided |
|
||||||
|
| truthiness | n/a | strict bool via `need_bool` | undecided (§1) |
|
||||||
|
| equality | numbers + enums (`types.ml:168`); `string` refused | structural, never traps, text bytewise | typed side missing a case (§2) |
|
||||||
|
| ordering | `is-ordered` = numbers + enums | numbers + text `memcmp` | same (§2) |
|
||||||
|
| map keys | `keyable`: ints, enums, bool, **string**, arrays, structs | — no map — | typed side self-inconsistent (§2, §5) |
|
||||||
|
| "any type" | `$t` + `{:where}`, checked at the `defn` | dyn, checked nowhere | clean (§3) |
|
||||||
|
| conditions | struct payloads | refused, by name (`check.ml:1976-2005`) | clean; the hole is elsewhere (§4) |
|
||||||
|
| struct with a dyn field | **accepted, unrooted** (§4) | — | **conflict** |
|
||||||
|
| vec | `(Vec T)`, allocator-owned, moves | `(vec-new dyn)`, GC-owned | clean |
|
||||||
|
| map | `(Map K V)`, open-addressed | **absent** | gap (§5) |
|
||||||
|
| set | absent (`Value.Set` is an O(n) vec) | absent | gap (§5) |
|
||||||
|
| keywords | compile-time enum resolution (`plan.org:920`) | absent | gap (§5) |
|
||||||
|
| strings | ptr+len view, borrows, owns nothing | GC text, immutable, copies in | one-way door (§6) |
|
||||||
|
| storage | `with-allocator`, in the calling convention | GC; ambient allocator **silently ignored** (§7) | conflict |
|
||||||
|
| identity / long-lived objects | `defstruct` + pooled `(Handle T)` — planned | `flan_obj *` | clean; `defclass` is the dyn side (§8) |
|
||||||
|
| dynamic data value | `defedn`/`defjson` → a struct, at compile time — **landed** | dyn value; **plus `edn/Value`** | same-side duplication (§5) |
|
||||||
|
| printing | `flan_rt.c` + `flan_dev.c` — **two on one side** | `flan_dyn.c` | typed side duplicated (§9) |
|
||||||
|
| hashing | `flan_hash_*` | absent | clean, at risk in M2 (§9) |
|
||||||
|
| sorting | `sort`, `sort-by`, **`sort-bytes`** | absent | typed side half-duplicated (§9) |
|
||||||
|
| compile-time type errors | `Types.equal` + literal adoption | none at all | the SBCL question (§10) |
|
||||||
|
| C interop | `declare`/`declare-c` | refused, by name (`check.ml:6082`) | clean |
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## B. The genuine conflicts, ranked, each as one question
|
||||||
|
|
||||||
|
1. **A `defstruct` may hold a `dyn` field, and nothing roots it once the frame that built it returns — should the field be refused until the per-type descriptor exists, the way a condition's field already is?** (§4; `check.ml:1976-2005` refuses one case, `box`'s `Named` arm at `:1450` permits the rest; `emit f3.flan` shows the single root popped at `ret`.)
|
||||||
|
2. **What produces a `nil`, and what does a `nil` do at a typed boundary — trap, or become `None`?** (§1; `check.ml:1436-1439` describes a producer that does not exist.)
|
||||||
|
3. **Does `with-allocator` around a dyn construction refuse, warn, or stay silent?** (§7; the explicit spelling is refused at `check.ml:4096`, the idiomatic one is accepted at probes `b4`/`c5`.)
|
||||||
|
4. **Should typed `=` and `is-ordered` grow the `string` case, given `keyable` already says `string` has an equality and `flan_hash_str` already implements it?** (§2; `types.ml:156` vs `types.ml:168`.)
|
||||||
|
5. **Can a dyn text become a typed `string` — by copy into a named allocator, by borrow until the next collection, or not at all?** (§6; `check.ml:1450-1474` has no arm.)
|
||||||
|
6. **Is `defclass` the dyn side with named slots and dispatch, sharing one heap — or a third memory model?** (§8; if the former, classes are gated on the dyn map, not on `Handle` as `plan.org:192` says.)
|
||||||
|
7. **Is a dyn `if` strict-bool because that was chosen, or because `need_bool` was the arm that existed?** (§1; `plan.org:908-910` calls the question moot and it is not.)
|
||||||
|
8. **Does `dyn_fold` refuse an operand whose pre-box type no arm of the operator accepts — SBCL's empty-intersection case, with no inference added?** (§10; the type is in hand at `check.ml:3414`.)
|
||||||
|
9. **What is M2's object-kind budget: `OBJ_MAP`, a keyword kind, both — and does a dyn set become a dyn map to unit?** (§5; four spare tags, `SPIKE-DYNAMIC.md:57`.)
|
||||||
|
10. **Does the doctrine's "no annotations" concede the mandatory return slot permanently, or is `SPIKE-INFERENCE.md`'s return-type inference the way back?** (§0.)
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## C. Same-side duplications to retire
|
||||||
|
|
||||||
|
1. **`vendor/edn/read.flan`'s `Value`** — a tagged dynamic value hand-written on the typed side, with its
|
||||||
|
own structural `value=?` (`:99`), `items=?` (`:116`), `sets=?` (`:128`), `tables=?` (`:145`). One
|
||||||
|
capability, two implementations. **Retire — sequenced behind a dyn map and dyn keywords (§5), not
|
||||||
|
before.** `defedn`/`defjson` landing on the perf side is what makes the pair complete once dyn's half
|
||||||
|
is; `Value` is the leftover middle.
|
||||||
|
2. **The three escape tables and their number formatters** — `flan_rt.c:383`, `flan_dev.c:237` and `:551`,
|
||||||
|
`flan_dyn.c:314`, with three files each instructing the reader to change the others. The dyn copy has a
|
||||||
|
defence (§9). **The `flan_rt.c`/`flan_dev.c` pair does not, predates dyn, and should collapse to one
|
||||||
|
exported entry point the other two call.**
|
||||||
|
3. **`Types.keyable` vs `Types.is_equatable`** (`types.ml:156` vs `:168`) — two answers to "does this type
|
||||||
|
have an equality", disagreeing about `string`, one of them a `Map` implementation detail wearing a
|
||||||
|
language rule's name. **Unify** (this is question B4 by another route).
|
||||||
|
4. **`sort-bytes`** (`prelude.ml:1399`) — a hand-written `sort-by` that exists only because `[[u8]]` cannot
|
||||||
|
answer `is-ordered`. **Falls out** the moment B4 is answered; not worth touching on its own.
|
||||||
|
|
||||||
|
Not duplication, and listed so nobody retires it by mistake: a typed `Vec` printing as `<vec>` while a dyn
|
||||||
|
vec prints its elements (`SPIKE-DYNAMIC.md:334-338`); the dyn operators promoting `(+ 1 2.5)` while the
|
||||||
|
typed language has no implicit widening (`SPIKE-DYNAMIC.md:258-262`); and `flan_dyn.c` being its own
|
||||||
|
translation unit with a strictly one-way dependency on `flan_rt.c` (`SPIKE-DYNAMIC.md:427-434`), which is
|
||||||
|
what makes `--no-gc` a file-selection change rather than a dead-code-elimination wish.
|
||||||
@@ -0,0 +1,572 @@
|
|||||||
|
# The dynamic-value runtime: NaN-boxed values over a mark-sweep heap
|
||||||
|
|
||||||
|
Milestone 1 of dynamic-by-default. Unannotated code computes with values that carry their type at run
|
||||||
|
time; fully annotated code compiles to exactly what it compiled to before; and a build that wants
|
||||||
|
neither a tag nor a collector can be given one that has neither. This document is the runtime half —
|
||||||
|
`runtime/flan_dyn.h`, `runtime/flan_dyn.c`, and the C tests in `test/dyn_ops.c` driven by
|
||||||
|
`test/test_dyn.ml`. The compiler half — deciding which locals are dyn, emitting the root pushes,
|
||||||
|
enforcing `--no-gc` — is a parallel lane and is built against the ABI in the header, which is fixed.
|
||||||
|
|
||||||
|
Everything here is implemented and green. `dune test --force` includes `test_dyn`, which is 29 processes
|
||||||
|
and 0.42 seconds; `dune build @sanitize` covers the same C under ASan and UBSan.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 1. Value representation: NaN-boxing
|
||||||
|
|
||||||
|
`flan_dyn` is `uint64_t`, one machine word, so a dyn local is a register or a stack slot and never a
|
||||||
|
struct whose return convention two backends would have to agree about. That much was fixed by the ABI.
|
||||||
|
What was open was the tagging scheme, and the two candidates are the usual pair.
|
||||||
|
|
||||||
|
**Low-bit tagging** puts the tag in the bottom three bits of a word and requires every payload to be
|
||||||
|
either a pointer to something aligned or an integer with three bits to spare. Its cost lands on floats:
|
||||||
|
an `f64` uses all 64 of its bits, so a low-bit scheme either boxes every float on the heap or steals the
|
||||||
|
mantissa's low bits and computes with a shortened double.
|
||||||
|
|
||||||
|
**NaN-boxing** does the opposite. A double is *itself* — the bit pattern is returned unchanged — and
|
||||||
|
everything else hides inside the quiet-NaN space, which IEEE 754 leaves as 2^52 unused encodings.
|
||||||
|
|
||||||
|
This codebase decides it. `f64` is a first-class type here, not a library afterthought: `sand.flan` runs
|
||||||
|
a physics loop, `calc-me.flan` is a float calculator, the prelude carries a hand-written `format-f64`
|
||||||
|
because `%g` was not enough, and `flan_rt.c` has three paragraphs on how to print a NaN. A representation
|
||||||
|
whose float path is the expensive one is the wrong representation for this language. Under NaN-boxing
|
||||||
|
`flan_dyn_from_f64` is a `memcpy` of 8 bytes and `flan_dyn_need_f64` is the same in reverse; neither
|
||||||
|
allocates, neither branches except on the NaN canonicalisation below.
|
||||||
|
|
||||||
|
The layout:
|
||||||
|
|
||||||
|
```
|
||||||
|
63 62..52 51 50..48 47..0
|
||||||
|
1 1...1 1 tag payload
|
||||||
|
^ sign ^ quiet
|
||||||
|
```
|
||||||
|
|
||||||
|
A word is *boxed* when `(v & 0xFFF8000000000000) == 0xFFF8000000000000` — sign bit set, exponent all
|
||||||
|
ones, quiet bit set. Bits 50..48 are three tag bits; bits 47..0 are the payload, which is exactly the
|
||||||
|
width of an x86-64 user-space pointer (48-bit canonical form, top 16 bits zero for user addresses).
|
||||||
|
Anything else is a double, read straight back.
|
||||||
|
|
||||||
|
Four box tags are used and four are free:
|
||||||
|
|
||||||
|
| tag | meaning | payload |
|
||||||
|
|-----|---------|---------|
|
||||||
|
| 0 | nil | 0 |
|
||||||
|
| 1 | bool | 0 or 1 |
|
||||||
|
| 2 | int | 48-bit two's complement, sign-extended on read |
|
||||||
|
| 3 | object | pointer to a `flan_obj` (text, vec, or a wide int) |
|
||||||
|
| 4–7 | unassigned | reserved for interop; see §7 |
|
||||||
|
|
||||||
|
### The negative-NaN collision, and why canonicalising is free here
|
||||||
|
|
||||||
|
Every NaN-boxing scheme has to answer for the doubles that are already negative quiet NaNs: their bits
|
||||||
|
are indistinguishable from a box. `flan_dyn_from_f64` answers it by mapping *every* NaN to the one
|
||||||
|
positive quiet NaN on the way in.
|
||||||
|
|
||||||
|
That is not a new rule invented for this file. `flan_rt.c`'s `flan_f64_to_bytes` already renders every
|
||||||
|
NaN as `nan` with no sign, and carries the argument at length: IEEE 754 does not specify the sign of a
|
||||||
|
NaN any operation produces, LLVM's constant folder and `divsd` disagree about `(/ 0.0 0.0)`, and the same
|
||||||
|
two-line program printed `nan` through one backend and `-nan` through the other. The runtime already
|
||||||
|
decided that a NaN's sign is not a fact about the arithmetic. This takes the same line one step further
|
||||||
|
and declines to *store* it. Nothing observable is lost: NaN is not equal to itself, so no comparison can
|
||||||
|
see which NaN it is, and the printer was already refusing to say. `-0.0` is untouched and keeps its sign,
|
||||||
|
which is tested.
|
||||||
|
|
||||||
|
### Integers: 48 bits inline, the rest on the heap
|
||||||
|
|
||||||
|
`i64` is first class here and 48 bits is not 64. The two honest options were a 48-bit integer with a
|
||||||
|
64-bit name, or a box for the overflow. This takes the box.
|
||||||
|
|
||||||
|
An `i64` in ±2^47 — that is ±140,737,488,355,327 — is inline: every array index, every byte count, every
|
||||||
|
timestamp in milliseconds until the year 6429, every value any program in the corpus computes. Outside
|
||||||
|
that range `flan_dyn_from_i64` allocates a `flan_obj` of kind `OBJ_INT` holding the full 64 bits. Both
|
||||||
|
shapes report `int` from `flan_dyn_tag`, compare and print identically, and round-trip through
|
||||||
|
`flan_dyn_need_i64`; nothing above the ABI can tell them apart. The cost is one range test on the
|
||||||
|
constructor and one branch in `dyn_int_value`, and the benefit is that a dyn `i64` is an `i64`.
|
||||||
|
|
||||||
|
`u64` has no constructor in this ABI, deliberately. Typed Flan distinguishes `u64` from `i64` — that is
|
||||||
|
why `flan_u64_to_bytes` exists beside `flan_i64_to_bytes` — and a `u64` above 2^63 has no dyn spelling in
|
||||||
|
milestone 1. It is an interop question (§7), not a representation one: the box already holds 64 bits and
|
||||||
|
a seventh tag would distinguish the signedness.
|
||||||
|
|
||||||
|
### Why not a two-word value
|
||||||
|
|
||||||
|
It would have made all of the above go away: a tag word and a payload word, no NaN games, no integer
|
||||||
|
boxing. It was not available — `typedef uint64_t flan_dyn` is in the fixed ABI — and it would have been
|
||||||
|
the wrong call anyway, for the reason `flan_rt.c`'s header gives about returning structs by value: the
|
||||||
|
emitted `.ll` would then have to agree with the platform's struct-return convention, which works on
|
||||||
|
x86-64 and silently does not on wasm32, and this project has two backends and a third target.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 2. Heap objects
|
||||||
|
|
||||||
|
One header, three kinds, one singly-linked list of everything allocated.
|
||||||
|
|
||||||
|
```c
|
||||||
|
typedef struct flan_obj {
|
||||||
|
struct flan_obj *next; /* every object ever allocated, newest first */
|
||||||
|
uint8_t kind; /* OBJ_TEXT | OBJ_VEC | OBJ_INT */
|
||||||
|
uint8_t mark;
|
||||||
|
int64_t len; /* bytes of a text, elements of a vec */
|
||||||
|
union {
|
||||||
|
int64_t i; /* OBJ_INT */
|
||||||
|
struct { flan_dyn *items; int64_t cap; } v; /* OBJ_VEC */
|
||||||
|
} u; /* OBJ_TEXT's bytes trail */
|
||||||
|
} flan_obj;
|
||||||
|
```
|
||||||
|
|
||||||
|
- **Text** is immutable and length-prefixed, with the bytes inline after the header — one allocation per
|
||||||
|
string, and a length that is a count and not a NUL scan. `flan_dyn_from_bytes` copies, so a literal in
|
||||||
|
`.rodata`, a frame slot, or a slice about to be dropped are all legitimate sources. Nothing in the ABI
|
||||||
|
writes into a text; `flan_dyn_set_at` on one refuses by name rather than copying on write.
|
||||||
|
- **Vec** is mutable, with its elements in a plain `malloc` block hanging off the header rather than in a
|
||||||
|
GC object of their own. Growth is then a `realloc` rather than a copy this file writes, and the
|
||||||
|
elements are never reachable except through their vec, so giving them an identity would buy nothing
|
||||||
|
and cost a header. Their bytes are counted in the live figure and freed when the vec is swept.
|
||||||
|
- **Int** is the overflow case above.
|
||||||
|
|
||||||
|
`mark` is a byte in the header and not a bit in a side table. A side table is the right answer when the
|
||||||
|
sweep is the cost, and the sweep is never going to be the cost here — see §3.
|
||||||
|
|
||||||
|
There is no free list, no size class, and no interning. Two texts built from the same bytes are two
|
||||||
|
objects, which `test_dyn` asserts directly: equality is bytewise (§5) and a test that only compared
|
||||||
|
structurally would pass against an implementation that had quietly shared.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 3. The collector
|
||||||
|
|
||||||
|
**Mark-sweep, precise, non-moving, stop-the-world, in about 120 lines.**
|
||||||
|
|
||||||
|
The author's constraint was explicit — *"the answer to 'I need more performance' will never be a faster
|
||||||
|
GC, it will be to type the whole program"* — so there is no generation, no card table, no write barrier,
|
||||||
|
no incremental phase and no reference counting. The design goal is that somebody can read the whole
|
||||||
|
collector in one sitting and believe it.
|
||||||
|
|
||||||
|
### Trigger
|
||||||
|
|
||||||
|
Collection happens inside `gc_alloc` and nowhere else. The policy is the plainest one that bounds the
|
||||||
|
heap:
|
||||||
|
|
||||||
|
```
|
||||||
|
if (gc_bytes + need > gc_next) collect();
|
||||||
|
...
|
||||||
|
gc_next = gc_bytes * 2; if (gc_next < gc_floor) gc_next = gc_floor;
|
||||||
|
```
|
||||||
|
|
||||||
|
Collect when this allocation would carry the heap past a limit; afterwards set the limit to twice what
|
||||||
|
survived, with a floor (1 MiB by default) so a program with a tiny live set does not collect every other
|
||||||
|
allocation. That gives amortised O(1) collection work per byte allocated, and a heap bounded at roughly
|
||||||
|
twice the live set plus the floor — which is the property `test_dyn`'s million-allocation case asserts,
|
||||||
|
as a bound rather than as an exact figure, because pinning the high-water mark would make a tuning change
|
||||||
|
a test failure.
|
||||||
|
|
||||||
|
`flan_gc_set_floor` is an ABI extension and exists for the tests: a megabyte of floor would make the
|
||||||
|
million-allocation case a megabyte of arithmetic before it proved anything. It recomputes the trigger
|
||||||
|
from the new floor rather than only raising it to meet it — raising alone left a heap that had been given
|
||||||
|
a *lower* floor still running to the old one, which is a bug this document's first draft had.
|
||||||
|
|
||||||
|
A vec's element array growing is a `realloc` and not a collection point, deliberately: the value being
|
||||||
|
pushed may not be rooted yet. The bytes are charged to the heap immediately so the trigger sees them at
|
||||||
|
the next real allocation, but nothing is swept in the middle of a push.
|
||||||
|
|
||||||
|
### Mark
|
||||||
|
|
||||||
|
An explicit worklist, not recursion. A vec of a vec of a vec is an ordinary dyn value and its depth is
|
||||||
|
the program's, not the runtime's; a recursive marker would put the heap's depth on the C stack and a long
|
||||||
|
enough chain would overflow it *during a collection*, which is the worst available moment. The mark stack
|
||||||
|
is grown on demand and kept between collections, so a steady program stops paying for it after the first.
|
||||||
|
`test_dyn`'s `nested` mode is a chain 64 deep and would notice a marker that stopped being iterative.
|
||||||
|
|
||||||
|
Only a vec has anything to trace; a text and a boxed int are leaves and marking them is the whole visit.
|
||||||
|
|
||||||
|
### Sweep
|
||||||
|
|
||||||
|
Walk the all-objects list, unlink and free anything unmarked, clear the mark on anything else, and
|
||||||
|
subtract the freed bytes. A vec's element array is freed with its header.
|
||||||
|
|
||||||
|
### What "precise" buys
|
||||||
|
|
||||||
|
The collector never guesses whether a word is a pointer, which matters more here than usual. NaN-boxing
|
||||||
|
makes conservative scanning wrong *in both directions*: a live double is bit-identical to a boxed pointer
|
||||||
|
often enough to retain garbage indefinitely, and a payload with the box stripped is not the pointer a
|
||||||
|
scanner would recognise. Precision is cheaper than the arguments about it.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 4. Roots
|
||||||
|
|
||||||
|
No conservative stack scanning. The compiler emits `flan_dyn_root_push` per dyn local on entry and one
|
||||||
|
`flan_dyn_root_pop(n)` for the lot on the way out — shadow-stack style, exactly as `flan_dev.c`'s frame
|
||||||
|
chain works and for the same reasons its header gives: a pushed record needs no agreement with the
|
||||||
|
optimiser about what a frame looks like, is the same on wasm32 as on x86-64, and needs no `.eh_frame`
|
||||||
|
walk to borrow (this language lowers every non-local exit explicitly and has none).
|
||||||
|
|
||||||
|
The root stack holds *addresses*, not values, so a local that is reassigned needs no second push. It
|
||||||
|
grows on demand, because a deep recursion over dyn locals is an ordinary program and a fixed table would
|
||||||
|
be a limit nobody could predict. Dyn globals go through the same pair, pushed once at startup and never
|
||||||
|
popped.
|
||||||
|
|
||||||
|
**The one contract the compiler lane must honour: a slot must hold a valid `flan_dyn` before it is
|
||||||
|
pushed.** The collector reads every registered address on every mark, and an uninitialised slot is a word
|
||||||
|
of stack garbage that will be decoded. Storing `flan_dyn_nil()` at the declaration is the whole of it.
|
||||||
|
|
||||||
|
`flan_dyn_root_pop` clamps at empty rather than refusing. A pop that outruns its pushes means the frame
|
||||||
|
machinery is already out of step, and the useful thing at that point is a heap that still collects.
|
||||||
|
|
||||||
|
`flan_dyn_root_reset` is an ABI extension with one caller: the merged dev build's `main`, which is
|
||||||
|
re-entered by `longjmp` and therefore pops no frame, so every root the finished run pushed still points
|
||||||
|
into stack the next run is about to write over. It is the exact counterpart of `flan_dev_frames_reset`
|
||||||
|
and `flan_condition_stacks_reset`, which exist for the same `longjmp`.
|
||||||
|
|
||||||
|
### The temporaries ring, and the hazard it closes
|
||||||
|
|
||||||
|
"Collection triggers only inside `flan_gc_alloc`, so between pushes nothing moves" protects against
|
||||||
|
*relocation*. It does not protect against *freeing*, and mark-sweep frees whatever is unreachable — which
|
||||||
|
includes an object allocated a moment ago and not yet stored anywhere the collector looks. Concretely:
|
||||||
|
|
||||||
|
```c
|
||||||
|
flan_dyn_push(v, flan_dyn_add(flan_dyn_from_bytes(p, n), other));
|
||||||
|
```
|
||||||
|
|
||||||
|
Two allocating calls in one expression. C leaves argument evaluation order unspecified, so this is not
|
||||||
|
even a window a careful emitter could close by ordering its calls.
|
||||||
|
|
||||||
|
The answer is the smallest one that does not depend on another agent having read this document: **every
|
||||||
|
object `flan_dyn.c` allocates is written into a fixed 64-slot ring, and the marker roots the whole ring
|
||||||
|
unconditionally.** Any expression making at most 64 allocations before rooting its result is safe. The
|
||||||
|
cost is one store and a masked increment per allocation, plus up to 64 objects of float in the heap,
|
||||||
|
which the trigger absorbs because the trigger is a fraction of live bytes and not a count. There is no
|
||||||
|
ABI change and no contract for the compiler lane to get wrong.
|
||||||
|
|
||||||
|
The visible consequence, and the only one: after a full collection up to 64 unreachable objects are still
|
||||||
|
alive. `test_dyn`'s `unrooted` mode asserts exactly that — "reclaimed all but the ring" — rather than
|
||||||
|
pretending the figure is zero.
|
||||||
|
|
||||||
|
An expression with 65 allocating calls and no intervening root would be a single Flan form with 65
|
||||||
|
constructors in it. If that ever exists, the compiler will have rooted its intermediates and the ring is
|
||||||
|
belt on top of braces.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 5. The operations, as implemented
|
||||||
|
|
||||||
|
### Arithmetic — `+ - * / %`
|
||||||
|
|
||||||
|
Two ints answer an int; a float anywhere answers a float; anything non-numeric traps.
|
||||||
|
|
||||||
|
**The promotion is the one place dyn is more permissive than the typed language, and it is deliberate.**
|
||||||
|
Typed Flan has no implicit widening anywhere — `(print-i64 x)` used to force an explicit `(i64 x)` at
|
||||||
|
every site, and the prelude's history is full of that. But `(+ 1 2.5)` has exactly one sensible answer,
|
||||||
|
and a dynamic language that refuses it is not dynamic in any useful sense. A program that wants the
|
||||||
|
refusal annotates, which is the whole bargain of dynamic-by-default.
|
||||||
|
|
||||||
|
Integer division and remainder by zero trap, matching typed Flan, which signals `ArithError` and dies
|
||||||
|
with "divide by zero" if nothing handles it. `INT64_MIN / -1` gets its own sentence for the reason
|
||||||
|
`flan_rt.c` gives it one. The float cases are left to IEEE: `1.0/0.0` is `inf` and that is an answer.
|
||||||
|
Float `%` is computed by truncated division rather than by calling `fmod`, which would pull `math.h` into
|
||||||
|
this translation unit for one operator; the quotient is range-checked first, because casting a double
|
||||||
|
past 2^63 to an integer is undefined rather than merely wrong.
|
||||||
|
|
||||||
|
### Ordering — `< <= > >=`
|
||||||
|
|
||||||
|
Numbers against numbers (promoting across the two tags), text against text bytewise, and nothing else.
|
||||||
|
Bytewise means `memcmp` with the shorter operand first on a tie — the order a sort of `(Vec string)`
|
||||||
|
wants, and the only one needing no locale and no collation table.
|
||||||
|
|
||||||
|
A number against a text traps. The temptation is to order by tag so that everything is comparable and
|
||||||
|
sorting never fails; the reason not to is that the resulting order is an artefact of this file's tag
|
||||||
|
numbering, and a program sorting a mixed vec would get a stable answer that means nothing.
|
||||||
|
|
||||||
|
NaN is unordered in all four directions, which is what IEEE says and what `test_dyn` asserts.
|
||||||
|
|
||||||
|
### Equality — `=`
|
||||||
|
|
||||||
|
Structural, and **the only operation here that never traps**: two values of unrelated tags are unequal,
|
||||||
|
which is an answer. Making it an error would mean a dyn program could not ask "is this the string I
|
||||||
|
expected" without first checking that it is a string at all.
|
||||||
|
|
||||||
|
- Numbers compare by value across the two tags: `(= 1 1.0)` is true.
|
||||||
|
- Text is **bytewise, not by identity**. `flan_dyn_from_bytes` copies and does not intern, so two texts
|
||||||
|
built from the same bytes are two objects; the only defensible equality for an immutable byte string is
|
||||||
|
its bytes. Embedded NULs are compared like any other byte — the length is a count, not a `strlen`.
|
||||||
|
- A vec is equal element by element, with an identity shortcut first.
|
||||||
|
- NaN is not equal to itself.
|
||||||
|
|
||||||
|
Cycles: `flan_dyn_set_at` lets a vec contain itself, so the recursion is capped at 64. Past the cap two
|
||||||
|
vecs are equal only if they are the same vec, which terminates and answers correctly for the case that
|
||||||
|
actually arises — a cycle compared against itself. Two *distinct* cyclic vecs of the same shape answer
|
||||||
|
false, which is a wrong answer to a question nobody has asked yet; the honest fix is a visited set and it
|
||||||
|
can be added the day somebody needs it.
|
||||||
|
|
||||||
|
### `length`, `at`, `set-at`, `push`
|
||||||
|
|
||||||
|
`length` is bytes of a text or elements of a vec. `at` is an element of a vec or a byte of a text as an int
|
||||||
|
— which is what `(at s i)` on a `(Slice u8)` does in the typed language; codepoints are `utf8`'s job and
|
||||||
|
stay there. `set-at` and `push` are vec-only, and a `set-at` on a text says *"a text is immutable — build
|
||||||
|
another one"* rather than quietly copying.
|
||||||
|
|
||||||
|
An index that is not an int is a different sentence from a container that is not indexable, because
|
||||||
|
`(at v "1")` and `(at 3 1)` are different mistakes and one message naming both would name neither.
|
||||||
|
|
||||||
|
### `prin`
|
||||||
|
|
||||||
|
Structural, and per tag it renders what typed `prin` renders. The reference forms were **captured from a
|
||||||
|
running program**, not read off `lib/render.ml` — that file is the REPL's inspector and not necessarily
|
||||||
|
`print`'s expansion:
|
||||||
|
|
||||||
|
| tag | rendering | example |
|
||||||
|
|-----|-----------|---------|
|
||||||
|
| int | `%lld` | `42` |
|
||||||
|
| float | `%g`, NaN unsigned | `3.5`, `1`, `nan` |
|
||||||
|
| bool | the word | `true` |
|
||||||
|
| text | bare at the top level | `hi` |
|
||||||
|
| text | quoted and escaped inside a structure | `"a b"`, `"q\"\n"` |
|
||||||
|
| vec | a slice's spelling | `[ 1 2 3]` |
|
||||||
|
| nil | — | `nil` |
|
||||||
|
|
||||||
|
The leading space before every element is what `lib/render.ml`'s slice loop emits and what a Flan program
|
||||||
|
prints today; a tidier answer would diverge from an acceptance test. The escape table is the dyn side's
|
||||||
|
own copy of the typed side's. The typed side used to have two and now has one — `flan_escape_char`
|
||||||
|
(`runtime/flan_rt.c:388`), which `flan_escape_bytes` calls for `print` and `flan_dev.c`'s `put_str`
|
||||||
|
calls for the inspector, each framing the result its own way — so there are two tables in the tree, not
|
||||||
|
three, and the split that is left is the dyn/typed one argued just below. If that table changes, change
|
||||||
|
this one too.
|
||||||
|
|
||||||
|
**A typed `Vec` prints as `<vec>` and a dyn vec does not.** That looks like a mismatch and is not. The
|
||||||
|
typed printer's refusal is about walking storage it does not own — `render.ml` says so, and directs you to
|
||||||
|
`(prin (slice v))`, which borrows explicitly at the call site. A dyn vec's storage belongs to the
|
||||||
|
collector, the printer is inside the runtime that owns it, and there is nobody to ask permission from. So
|
||||||
|
a dyn vec prints the way a *slice* does, which is also the only rendering that carries any information.
|
||||||
|
|
||||||
|
`prin` has a depth cap of 16. A typed value cannot contain itself, so the typed printer needs no
|
||||||
|
run-time cap; `set-at` makes a dyn vec that can, so this one has one, and past it prints `...`, which is
|
||||||
|
the mark `render.ml` uses for the same idea.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 6. The typed boundary
|
||||||
|
|
||||||
|
`flan_dyn_need_i64`, `_need_f64`, `_need_bool` are what an annotated parameter does with a dyn argument
|
||||||
|
and what a dyn expression does where the checker wants a machine value. **There is no widening and no
|
||||||
|
coercion at the boundary**: `flan_dyn_need_f64` of an int traps.
|
||||||
|
|
||||||
|
That is the asymmetry worth defending, because the operators *do* promote (§5). The two are different
|
||||||
|
questions. An operator has no stated expectation to violate — `(+ 1 2.5)` was written by somebody who
|
||||||
|
wanted a number and there is one obvious number. An annotation *is* a stated expectation, written down by
|
||||||
|
a person, and quietly turning their `i64` into an `f64` would make the boundary the one place in the
|
||||||
|
language where a *value* changed type without anybody writing it. Typed Flan does not widen a value:
|
||||||
|
|
||||||
|
```lisp
|
||||||
|
(defn g [x f64] f64 x)
|
||||||
|
(defn h [y i64] f64 (g y)) ; scratch.flan:2:24: expected f64, found i64
|
||||||
|
```
|
||||||
|
|
||||||
|
### The one divergence the compiler lane has to know about
|
||||||
|
|
||||||
|
Typed Flan does not widen a *value*, but a **literal adopts its expected type**. `(g 1)` compiles and
|
||||||
|
prints `1`, because the checker gives the literal `1` the `f64` the parameter asks for; `(vec-new i64)`
|
||||||
|
followed by `(push v 1)` works the same way.
|
||||||
|
|
||||||
|
A dyn value has no such history. Once `1` has been through `flan_dyn_from_i64` it is tagged `int`, and
|
||||||
|
nothing downstream can recover that it was written as a literal in a position that wanted a float. So:
|
||||||
|
|
||||||
|
```lisp
|
||||||
|
(g 1) ; typed: compiles, prints 1
|
||||||
|
(g some-dyn) ; dyn, where some-dyn came from the literal 1: traps, "a float was wanted"
|
||||||
|
```
|
||||||
|
|
||||||
|
That is a real divergence between the same source read as typed and read as dyn, and it is stated here
|
||||||
|
rather than discovered later. Two ways out, both the compiler's and neither this file's:
|
||||||
|
|
||||||
|
1. **Tag the literal at the constructor.** Where the checker can see that an unannotated literal flows to
|
||||||
|
a float context, emit `flan_dyn_from_f64` instead of `flan_dyn_from_i64`. This is the same inference
|
||||||
|
the checker already performs for typed literals and it keeps the boundary sharp.
|
||||||
|
2. **Emit a conversion at the call**, where both sides are visible, rather than softening
|
||||||
|
`flan_dyn_need_f64` — which sees only a tag and could not tell a literal-derived int from a computed
|
||||||
|
one.
|
||||||
|
|
||||||
|
Softening the boundary itself is the option not to take: it would accept `(g (length xs))` as readily as
|
||||||
|
`(g 1)`, and those are not the same mistake.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 7. Interop, which is out of scope for M1 and not precluded
|
||||||
|
|
||||||
|
A typed `(Vec i64)` crossing into dyn code, without copying, is milestone 2. The layout leaves room for
|
||||||
|
it in three specific ways.
|
||||||
|
|
||||||
|
**Four spare tags.** Bits 50..48 give eight box tags and four are used. Tag 4 is the natural home for a
|
||||||
|
*typed handle*: payload = pointer to a typed object, with the element type recovered from a side table or
|
||||||
|
from a word in the object's own header. Tag 5 can carry `u64` above 2^63, which is the other value typed
|
||||||
|
Flan holds and this ABI currently cannot name.
|
||||||
|
|
||||||
|
**The object header is not the only thing the collector can trace.** `mark_push` dispatches on `kind`,
|
||||||
|
and a fourth kind whose tracer is "call a function pointer in a descriptor" is a local change — a handle
|
||||||
|
to a typed `(Vec Enemy)` would need the collector to know which fields of `Enemy` are dyn, and a
|
||||||
|
per-type descriptor emitted by the compiler is how that arrives. Nothing in the current layout has to
|
||||||
|
move for that: the `union` grows an arm.
|
||||||
|
|
||||||
|
**A typed vec is not a `flan_obj` and does not need to become one.** The interop that matters is the
|
||||||
|
cheap direction — a typed vec is `{ptr, len, cap}` in memory the *arena* owns, and a dyn handle to it
|
||||||
|
should be a borrow, not a copy. That means the collector must be able to trace *into* memory it did not
|
||||||
|
allocate and must never free it. The `kind` byte is what distinguishes "I own these bytes" from "I am a
|
||||||
|
window onto someone else's", and the sweep already branches on it.
|
||||||
|
|
||||||
|
What is genuinely open, and is stated here so the M2 lane does not discover it late: **a typed vec's
|
||||||
|
lifetime is its arena's, and the collector has no say in it.** A dyn value outliving the arena its handle
|
||||||
|
points into is a dangling read that the current design cannot detect. The allocation registry in
|
||||||
|
`flan_dev.c` already answers exactly that question for `Ptr` — `render.ml`'s pointer arm follows a live
|
||||||
|
one and mourns a dead one — so the shape of the answer exists. It is not built here.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 8. Dropping the collector
|
||||||
|
|
||||||
|
`--no-gc` enforcement is the compiler lane's. This lane's contribution is that **it is possible**, which
|
||||||
|
is a property of the build and not a wish:
|
||||||
|
|
||||||
|
- `flan_dyn.c` is its own translation unit and always has been. It is compiled from
|
||||||
|
`Runtime_src.dyn_source` in `lib/build.ml` (both `executable` and `macro_module`) and in `lib/dev.ml`,
|
||||||
|
beside `flan_rt.c` and `flan_dev.c` and never merged with them.
|
||||||
|
- **The dependency runs one way only.** `flan_dyn.c` calls `flan_write_stdout` and `flan_trap` in
|
||||||
|
`flan_rt.c`. Nothing in `flan_rt.c` or `flan_dev.c` names a symbol in `flan_dyn.c`. One
|
||||||
|
back-reference — `flan_rt_init` calling `flan_gc_init`, say, which was the obvious thing to write —
|
||||||
|
would make the collector unconditional and the refusal a lie, so the heap initialises itself lazily on
|
||||||
|
first allocation instead.
|
||||||
|
**The linker does not drop it today, and this document will not claim it does.** `flan_dyn.o` is a named
|
||||||
|
object on the link line, not an archive member, and `ld` includes a named object in full — symbol-driven
|
||||||
|
selection is a `.a` rule. Dead-code elimination *inside* an included object needs
|
||||||
|
`-ffunction-sections -fdata-sections -Wl,--gc-sections`, which the link line does not pass. Measured
|
||||||
|
rather than assumed: build any corpus program and `nm` it, and `flan_dyn_add` and `flan_gc_collect` are
|
||||||
|
both there as defined symbols.
|
||||||
|
|
||||||
|
What the one-way dependency buys is the better mechanism anyway. The object is selected at the **file**
|
||||||
|
level: `--no-gc` is a one-line change at each of the three sites that name `Runtime_src.dyn_source` — the
|
||||||
|
same per-target selection `select_csrcs` already performs for a package's C — and once it is not
|
||||||
|
compiled, nothing has to be dropped. That only works because nothing else in the runtime refers to it;
|
||||||
|
`flan_dev.c` is compiled into every build today precisely because it *is* referred to (a package's C
|
||||||
|
names it, and package sources are collected whatever `main` does), and its own comment says so at length.
|
||||||
|
`flan_dyn.c` has no such entanglement, and keeping it that way is the constraint this section exists to
|
||||||
|
record.
|
||||||
|
|
||||||
|
The residual-dynamism refusal itself — deciding that a program is *not* fully annotated and saying which
|
||||||
|
form is not — is the compiler's, and is not attempted here.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 9. Cost sketch, per operation
|
||||||
|
|
||||||
|
No microbenchmarks; these are counts of what the code does.
|
||||||
|
|
||||||
|
| operation | cost |
|
||||||
|
|-----------|------|
|
||||||
|
| `from_f64`, `need_f64` | one 8-byte copy; one compare for the NaN canonicalisation |
|
||||||
|
| `from_i64` | one range compare, then a mask and an or — or an allocation past ±2^47 |
|
||||||
|
| `need_i64` | tag test, then a shift pair to sign-extend |
|
||||||
|
| `from_bool`, `nil`, `need_bool` | mask and or; tag test |
|
||||||
|
| `tag` | one mask-compare, one shift, and a load for the object case |
|
||||||
|
| `add`/`sub`/`mul` | two tag tests, the arithmetic, one `from_i64` (which may allocate at the extremes) |
|
||||||
|
| `div`/`rem` | the above plus a zero test and an overflow test |
|
||||||
|
| `lt`/`le`/`gt`/`ge` | two tag tests and a compare; text is `memcmp` |
|
||||||
|
| `eq` | word compare first; then tags, then bytes or elements — O(size) at worst |
|
||||||
|
| `length` | tag test and a load |
|
||||||
|
| `at` | two tag tests, a bounds compare, a load |
|
||||||
|
| `set_at` | the same, plus a store; **no write barrier**, because there is no generation to have one for |
|
||||||
|
| `push` | tag test, a capacity test, amortised O(1); the doubling is a `realloc` |
|
||||||
|
| `prin` | O(size), streamed, no allocation |
|
||||||
|
| `root_push` / `root_pop` | a store and an increment; a `realloc` when the stack doubles |
|
||||||
|
| allocation | a trigger compare, a `malloc`, a header init, a ring store |
|
||||||
|
| collection | O(live) to mark, O(all) to sweep; amortised O(1) per byte allocated |
|
||||||
|
|
||||||
|
The shape to take away: **every operation is a handful of instructions plus whatever the arithmetic
|
||||||
|
costs, and the only unbounded ones are `eq`, `prin` and collection itself.** If that is not fast enough,
|
||||||
|
type the program.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 10. ABI extensions
|
||||||
|
|
||||||
|
The header in `runtime/flan_dyn.h` is the agreed ABI with nothing removed and no signature changed.
|
||||||
|
Seven things are added; none is something the compiler lane must emit.
|
||||||
|
|
||||||
|
| addition | why |
|
||||||
|
|----------|-----|
|
||||||
|
| `flan_dyn_root_reset()` | the merged dev build's `longjmp` re-entry, exactly as `flan_dev_frames_reset` |
|
||||||
|
| `flan_dyn_tag()` | the break loop and the inspector; the first question anyone asks a stopped dyn value |
|
||||||
|
| `flan_dyn_tag_name()` | the same table the trap messages are written from, so a message and an inspector cannot disagree |
|
||||||
|
| `FLAN_DYN_TAG_*` | the numbers `flan_dyn_tag` answers with |
|
||||||
|
| `flan_gc_count()` | the tests: a live-bytes figure alone cannot tell a collecting heap from one with small objects |
|
||||||
|
| `flan_gc_set_floor()` | the tests: a 1 MiB floor makes the million-allocation case slow and uninformative |
|
||||||
|
| `flan_trap()` in `flan_rt.c` | a thin exported wrapper over the existing static `rt_trap`, so a dyn type error takes the *same* path as `flan_bounds_fail` and the other six rather than re-implementing the hook, the flush, the socket and `_exit(134)` |
|
||||||
|
|
||||||
|
One more thing the compiler lane should know about, which is a build fact rather than an ABI addition:
|
||||||
|
**`Build.compile_c` now drops `runtime/flan_dyn.h` into the directory it compiles each translation unit
|
||||||
|
in**, so a package's C — or an emitted shim — can `#include "flan_dyn.h"`. `flan_dyn.c` itself does not
|
||||||
|
include it and declares its own prototypes, because the object cache is keyed on source text and a header
|
||||||
|
edit would serve an object compiled against the previous one. The two copies are kept honest
|
||||||
|
mechanically: `test/dyn_ops.c` includes the header and names every function in it, so a divergence is a
|
||||||
|
compile or link error in `dune test`.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 11. Traps
|
||||||
|
|
||||||
|
A dyn type error is a trap and not an abort: it takes `flan_trap`, which calls `flan_trap_hook` if one is
|
||||||
|
installed and then `rt_die`. In a dev session the hook parks the program for inspection; in a standalone
|
||||||
|
build nothing installs it and the program dies where it stands. The sentence is the same either way,
|
||||||
|
which is the point of routing through the hook rather than calling `abort` in the runtime.
|
||||||
|
|
||||||
|
The sentence names the operation, both tags as **words**, and both values:
|
||||||
|
|
||||||
|
```
|
||||||
|
dyn +: int and text, and it takes two numbers — (+ 3 "hi")
|
||||||
|
dyn at: index 9 is out of bounds for text of length 2 — "hi"
|
||||||
|
dyn f64: int, and a float was wanted — (f64 1)
|
||||||
|
```
|
||||||
|
|
||||||
|
Tag names are always words — `int`, `float`, `text`, `vec`, `nil`, `bool` — and never numbers. They come
|
||||||
|
from one table that `flan_dyn_tag_name` also reads. Values are rendered into a bounded stack buffer with
|
||||||
|
a depth cap of 2, truncated rather than allocated: a trap is the one moment when allocating would be a
|
||||||
|
second thing to go wrong.
|
||||||
|
|
||||||
|
Four trap names, because they are four different mistakes and somebody standing in one wants to know
|
||||||
|
which without reading the sentence twice:
|
||||||
|
|
||||||
|
| name | when |
|
||||||
|
|------|------|
|
||||||
|
| `DynType` | a tag that is not what the operation wanted |
|
||||||
|
| `DynRange` | an index outside a vec or a text |
|
||||||
|
| `DynArith` | division by zero, or the one quotient that overflows |
|
||||||
|
| `DynHeap` | an allocation the host refused |
|
||||||
|
|
||||||
|
The bounds case does **not** signal `BoundsError` the way typed indexing does, and that is a limitation
|
||||||
|
rather than a preference: `flan_bounds_error` takes a `loc` and a transfer channel, and a dyn operation
|
||||||
|
has neither in its hands. It is the same reason the six traps in `flan_rt.c` park rather than signal. If
|
||||||
|
the compiler lane threads a `loc` through — it knows one at every call site — the dyn bounds case can
|
||||||
|
join the condition system unchanged, and that is the obvious next increment.
|
||||||
|
|
||||||
|
---
|
||||||
|
|
||||||
|
## 12. What is tested
|
||||||
|
|
||||||
|
`test/dyn_ops.c`, driven by `test/test_dyn.ml` against `test/programs/dyn-host.flan` — a C main linked
|
||||||
|
against a Flan program with no `main`, the arrangement `dev_limits.c` and `reload_host.c` already use,
|
||||||
|
because these are C entry points with no Flan spelling. One binary, 29 runs, 0.42 s.
|
||||||
|
|
||||||
|
| mode | what it establishes |
|
||||||
|
|------|--------------------|
|
||||||
|
| `ops` | every operation's happy path; every tag and its word; f64 round trips at `0`, `-0.0`, `1e308` and NaN; i64 at both inline edges, both boxed edges, `INT64_MIN` and `INT64_MAX`; arithmetic crossing into the box; NaN unordered in all four directions; text identity vs equality; embedded NULs; the empty text; vec growth past its initial capacity; a vec that contains itself, compared and printed; every printed form as an exact string |
|
||||||
|
| `gc` | a million allocations against a hundred rooted values; heap high-water under 512 KiB where a non-collecting heap would hold ~40 MiB; the live set intact afterwards |
|
||||||
|
| `unrooted` | **the positive control** — an object nothing points at is reclaimed. Without it every other case would pass against a collector that never freed |
|
||||||
|
| `nested` | a chain of vecs 64 deep traced through one root, across real collections |
|
||||||
|
| `sharing` | one vec in three slots: identity (not just equality), a write through one path read through another, survival when the direct root goes, and a single sweep when the last reference does |
|
||||||
|
| `refuse:*` | 24 refusals, one process each, asserted on the sentence as well as the exit status — a process that died some other way is not the guard firing, and the code cannot tell them apart |
|
||||||
|
|
||||||
|
`dune build @sanitize` runs the same C under ASan and UBSan. That sweep matters more here than anywhere
|
||||||
|
else in the corpus: every other program in it allocates and never frees, which is a policy ASan can only
|
||||||
|
agree with, and this one frees — a mark-sweep collector is precisely a machine for freeing something that
|
||||||
|
is still reachable. A use-after-free is what a wrong marker looks like from outside, and it is invisible
|
||||||
|
to the assertions above, because the freed bytes are usually still the bytes that were there. Leaks stay
|
||||||
|
off, as they are for the whole file: the temporaries ring holds 64 objects alive at exit on purpose, and
|
||||||
|
every one of them would be reported.
|
||||||
@@ -1,5 +1,17 @@
|
|||||||
# The generics spike, answered: it runs, and the bill lands on the dev loop rather than on the checker
|
# The generics spike, answered: it runs, and the bill lands on the dev loop rather than on the checker
|
||||||
|
|
||||||
|
> **This is the spike report and it stopped being current when generics landed for real, on 2026-09-13.**
|
||||||
|
> It is kept because the measurements and the reasoning behind the design are still the ones that were
|
||||||
|
> acted on, but it describes a branch where `lib/prelude.ml` and the backends were untouched, and they
|
||||||
|
> are not any more: the prelude's per-type families collapsed into one function each. Two things it says
|
||||||
|
> have since been overtaken and would mislead anyone writing code from it. Its account of plan.org is out
|
||||||
|
> of date — plan.org now specifies `$t` itself rather than lowercase-with-no-sigil. And the spelling rule
|
||||||
|
> below is narrower than what shipped: `$t` is written wherever a *type* goes, including in a return type
|
||||||
|
> and nested inside `[$t]` or `(Option $t)`, and bare `t` only where a type's *name* is an argument in
|
||||||
|
> expression position, as in `(vec-new t)` and the cast `(t x)`. `(Option t)` does not compile.
|
||||||
|
> plan.org's Types section and spec-memory.md's Generics section are the current account.
|
||||||
|
> `spike/`, which held every file this report names, was deleted on 2026-09-25; the files are in git history.
|
||||||
|
|
||||||
Milestone 5's parametric polymorphism, run early and deliberately out of order, as a spike rather than as a
|
Milestone 5's parametric polymorphism, run early and deliberately out of order, as a spike rather than as a
|
||||||
decision. **Feasible, and smaller than expected.** A generic function written in Flan goes through the ordinary
|
decision. **Feasible, and smaller than expected.** A generic function written in Flan goes through the ordinary
|
||||||
frontend, is instantiated at each concrete type its call sites ask for, is emitted as real functions and runs,
|
frontend, is instantiated at each concrete type its call sites ask for, is emitted as real functions and runs,
|
||||||
@@ -53,7 +65,7 @@ Yes, at four shapes, all of them run and checked against their output.
|
|||||||
```lisp
|
```lisp
|
||||||
(defn id [x $t] t x)
|
(defn id [x $t] t x)
|
||||||
(defn main [] ()
|
(defn main [] ()
|
||||||
(println (id 3)) (println (id 4.5)) (println (id 7)) (println (id true)))
|
(print (id 3)) (print (id 4.5)) (print (id 7)) (print (id true)))
|
||||||
```
|
```
|
||||||
|
|
||||||
prints `3 / 4.5 / 7 / true`, and emits exactly three bodies — `flan.id-i32`, `flan.id-f64`, `flan.id-bool`. Four
|
prints `3 / 4.5 / 7 / true`, and emits exactly three bodies — `flan.id-i32`, `flan.id-f64`, `flan.id-bool`. Four
|
||||||
@@ -68,11 +80,11 @@ is the `is_polymorphic_type_assignable` walk rather than a name match.
|
|||||||
```lisp
|
```lisp
|
||||||
(defn swap! [xs [$t] i i32 j i32] () ...)
|
(defn swap! [xs [$t] i i32 j i32] () ...)
|
||||||
|
|
||||||
(defn sort-by! [s [$t] before? (Fn [$t $t] bool)] ()
|
(defn sort-by! [s [$t] is-before (Fn [$t $t] bool)] ()
|
||||||
(let [i 1]
|
(let [i 1]
|
||||||
(while (< i (len s))
|
(while (< i (length s))
|
||||||
(let [j i]
|
(let [j i]
|
||||||
(while (and (> j 0) (before? (at s j) (at s (- j 1))))
|
(while (and (> j 0) (is-before (at s j) (at s (- j 1))))
|
||||||
(swap! s (- j 1) j)
|
(swap! s (- j 1) j)
|
||||||
(set j (- j 1))))
|
(set j (- j 1))))
|
||||||
(set i (+ i 1)))))
|
(set i (+ i 1)))))
|
||||||
@@ -211,15 +223,16 @@ calling them — dead, not stale.
|
|||||||
|
|
||||||
## Question 4 — what the whole feature would have to lower
|
## Question 4 — what the whole feature would have to lower
|
||||||
|
|
||||||
Against what a generic function has to survive, in DISCUSS.md item 15's buckets:
|
Against what a generic function has to survive under TODO.org, "Generics by monomorphisation, checked abstractly,
|
||||||
|
with where predicates", in buckets:
|
||||||
|
|
||||||
| | |
|
| | |
|
||||||
|---|---|
|
|---|---|
|
||||||
| **Done in the spike** | one or more type variables in a signature; binding through `[t]`, `(Ptr t)`, `(Option t)`, `(Fn [t] t)` and nesting; return types mentioning a variable; left-to-right binding with substitution into later parameters so an `fn` literal gets its types; the Odin-keyed instantiation cache; generic calling generic, transitively; `(vec-new t)`; the abstract refusal pass for `+`, `-`, `*`, `/`, `%`, `=`, `!=`, `<`, `<=`, `>`, `>=`, the bitwise operators and the shifts; instantiations as ordinary `Tast.fn`s with dev cells and `Reach` edges for free; a depth cap so runaway instantiation refuses instead of hanging |
|
| **Done in the spike** | one or more type variables in a signature; binding through `[t]`, `(Ptr t)`, `(Option t)`, `(Fn [t] t)` and nesting; return types mentioning a variable; left-to-right binding with substitution into later parameters so an `fn` literal gets its types; the Odin-keyed instantiation cache; generic calling generic, transitively; `(vec-new t)`; the abstract refusal pass for `+`, `-`, `*`, `/`, `%`, `=`, `!=`, `<`, `<=`, `>`, `>=`, the bitwise operators and the shifts; instantiations as ordinary `Tast.fn`s with dev cells and `Reach` edges for free; a depth cap so runaway instantiation refuses instead of hanging |
|
||||||
| **Mechanical** | the remaining builtins that take a *type name* as an argument — `pool-new`, `map-new`, `zeroed`, `uninit`, the casts — each of which reaches `type_named`/`resolve_name` by its own path, exactly as `vec-new` did (one line there fixed `vec-new`; the others are one line each); `hash` and the map key-pair path, which must refuse a `Var` rather than assume; the `fns` expansion in `session.ml` described above |
|
| **Mechanical** (all three have since landed, and `test/programs/generics.flan` exercises the first two; `pool-new` was removed with the pool) | the remaining builtins that take a *type name* as an argument — `pool-new`, `map-new`, `zeroed`, `uninit`, the casts — each of which reaches `type_named`/`resolve_name` by its own path, exactly as `vec-new` did (one line there fixed `vec-new`; the others are one line each); `hash` and the map key-pair path, which must refuse a `Var` rather than assume; the `fns` expansion in `session.ml` described above |
|
||||||
| **Bulky, not hard** | error messages that say *where* an instantiation came from — Odin's "in instantiation of" note. Today a refusal inside an instantiated body points at the generic's source with no indication which call site asked for that type, and with three or four instantiations that is the difference between a readable refusal and a puzzle. It is a context stack in `ctx` and a `Loc.note` per frame, and it touches every `fail` under an instantiation |
|
| **Bulky, not hard** | error messages that say *where* an instantiation came from — Odin's "in instantiation of" note. Today a refusal inside an instantiated body points at the generic's source with no indication which call site asked for that type, and with three or four instantiations that is the difference between a readable refusal and a puzzle. It is a context stack in `ctx` and a `Loc.note` per frame, and it touches every `fail` under an instantiation |
|
||||||
| **Fiddly** | move-only and ownership. `Types.is_move_only (Var _)` is false, but the same variable at `(Vec i32)` is move-only — so the abstract pass **cannot decide ownership at all**, and the dead-set analysis is only sound per instantiation. Today that means a generic body that moves its parameter type-checks abstractly and is caught, if at all, at one instantiation and not another. The rule has to be stated: either ownership is checked only per copy (and the abstract pass skips it, so a generic may be accepted and its instantiation refused), or type variables carry a move-only constraint, which is a constraint system and plan.org says not yet. One smaller thing in the same bucket, found and left alone: the abstract pass over a generic body that calls *another* generic at a concrete type generates that copy and keeps it, so plain `flan emit` can carry a body no call site asked for. It is a valid instantiation and `Reach.link` drops it, so `flan build` and `flan run` are unaffected — but the abstract pass is meant to leave nothing behind and this is the one thing it does |
|
| **Fiddly** | move-only and ownership. `Types.is_move_only (Var _)` is false, but the same variable at `(Vec i32)` is move-only — so the abstract pass **cannot decide ownership at all**, and the dead-set analysis is only sound per instantiation. Today that means a generic body that moves its parameter type-checks abstractly and is caught, if at all, at one instantiation and not another. The rule has to be stated: either ownership is checked only per copy (and the abstract pass skips it, so a generic may be accepted and its instantiation refused), or type variables carry a move-only constraint, which is a constraint system and plan.org says not yet. One smaller thing in the same bucket, found and left alone: the abstract pass over a generic body that calls *another* generic at a concrete type generates that copy and keeps it, so plain `flan emit` can carry a body no call site asked for. It is a valid instantiation and `Reach.link` drops it, so `flan build` and `flan run` are unaffected — but the abstract pass is meant to leave nothing behind and this is the one thing it does |
|
||||||
| **No plan** | (1) **Unbounded instantiation.** `(defn grow [x $t] () (grow [x x]))` asks for a copy at `[2 t]`, which asks for one at `[2 [2 t]]`, forever. Before the cap it did not fail, it *hung* — and since `Session.eval` runs this same code, the thing that hangs is `C-c C-c`, with the dev daemon wedged behind it and no error to show. That is the project's stated priority hanging on three lines of ordinary-looking Flan, so the spike stops it: a depth counter in `env`, refusing past 32 and naming the type it had reached (`spike/generics/runaway.flan`). **The number is arbitrary and the designed refusal — one that names the chain of instantiations rather than the depth it gave up at — is still open.** **Odin has no cap of its own**, so there is no implementation to copy. (2) **Generic structs and containers.** `Types.Named` is a bare string with no parameters, so `(defstruct Pair [a $t b $t])` cannot be spelled at all — a parameterised named type is a change to `Types.t` and therefore to every backend, `Render`, DWARF and the layout calculator. (3) **`println` over a type variable.** plan.org's one compiler-provided exception; the abstract pass rejects it (`no printer for t`), see question 6. (4) **Generics across packages.** `Load` flattens imports into one namespace before checking, so it happens to work here, but a package boundary that is ever a real compilation-unit boundary would need the generic's *body* to cross it — the thing separate compilation cannot do and the reason C++ puts templates in headers |
|
| **No plan** | (1) **Unbounded instantiation.** `(defn grow [x $t] () (grow [x x]))` asks for a copy at `[2 t]`, which asks for one at `[2 [2 t]]`, forever. Before the cap it did not fail, it *hung* — and since `Session.eval` runs this same code, the thing that hangs is `C-c C-c`, with the dev daemon wedged behind it and no error to show. That is the project's stated priority hanging on three lines of ordinary-looking Flan, so the spike stops it: a depth counter in `env`, refusing past 32 and naming the type it had reached (`spike/generics/runaway.flan`). **The number is arbitrary and the designed refusal — one that names the chain of instantiations rather than the depth it gave up at — is still open.** **Odin has no cap of its own**, so there is no implementation to copy. (2) **Generic structs and containers.** `Types.Named` is a bare string with no parameters, so `(defstruct Pair [a $t b $t])` cannot be spelled at all — a parameterised named type is a change to `Types.t` and therefore to every backend, `Render`, DWARF and the layout calculator. (3) **`print` over a type variable.** plan.org's one compiler-provided exception; the abstract pass rejects it (`no printer for t`), see question 6. (4) **Generics across packages.** `Load` flattens imports into one namespace before checking, so it happens to work here, but a package boundary that is ever a real compilation-unit boundary would need the generic's *body* to cross it — the thing separate compilation cannot do and the reason C++ puts templates in headers |
|
||||||
|
|
||||||
The "no plan" row's first entry is the one to take seriously: it is not a missing feature, it is a hang, and it is
|
The "no plan" row's first entry is the one to take seriously: it is not a missing feature, it is a hang, and it is
|
||||||
reachable from three lines of ordinary-looking Flan.
|
reachable from three lines of ordinary-looking Flan.
|
||||||
@@ -261,7 +274,7 @@ Counted by name, the 27 of the family I could account for split **13 / 9 / 5**:
|
|||||||
`map-i32!` `map-f32!`, `reduce-i32` `reduce-f32`, `filter-i32` `filter-f32`, `sort-i32-by!` `sort-f32-by!`.
|
`map-i32!` `map-f32!`, `reduce-i32` `reduce-f32`, `filter-i32` `filter-f32`, `sort-i32-by!` `sort-f32-by!`.
|
||||||
- 9 collapse into 4 but change their signatures and every call site — `sort-i32!` `sort-f32!` `sort-bytes!`,
|
- 9 collapse into 4 but change their signatures and every call site — `sort-i32!` `sort-f32!` `sort-bytes!`,
|
||||||
`index-of-i32` `index-of-byte`, `min-i32` `min-f32` `max-i32` `max-f32`.
|
`index-of-i32` `index-of-byte`, `min-i32` `min-f32` `max-i32` `max-f32`.
|
||||||
- 5 do not collapse — `sum-i32` `sum-f32`, `append!` `append-i64!` `append-f64!` — because they are not one
|
- 5 do not collapse — `sum-i32` `sum-f32`, `small-append` `append-i64!` `append-f64!` — because they are not one
|
||||||
function written twice; they are functions that happen to rhyme.
|
function written twice; they are functions that happen to rhyme.
|
||||||
|
|
||||||
So the net is on the order of **27 → 15**, not 27 → 6, and the prelude keeps a per-type layer for the numeric
|
So the net is on the order of **27 → 15**, not 27 → 6, and the prelude keeps a per-type layer for the numeric
|
||||||
@@ -277,12 +290,12 @@ a type without `+`. Getting plan.org's rule instead requires a second pass that
|
|||||||
substituted, which is `check_generic` in this spike: one extra whole-body check per generic `defn`, discarded.
|
substituted, which is `check_generic` in this spike: one extra whole-body check per generic `defn`, discarded.
|
||||||
It is cheap and it is worth it, but it is *not* Odin's model and the plan should stop saying it is.
|
It is cheap and it is worth it, but it is *not* Odin's model and the plan should stop saying it is.
|
||||||
|
|
||||||
**2. The abstract pass rejects `println` over a type variable**, and plan.org names `println` as "the one
|
**2. The abstract pass rejects `print` over a type variable**, and plan.org names `print` as "the one
|
||||||
compiler-provided exception: it selects a structural printer at each concrete instantiation". Those two statements
|
compiler-provided exception: it selects a structural printer at each concrete instantiation". Those two statements
|
||||||
cannot both hold as written: a pass that decides an operator's legality without substituting cannot make an
|
cannot both hold as written: a pass that decides an operator's legality without substituting cannot make an
|
||||||
exception for the one operator whose legality is only decidable after substituting. `(defn show [x $t] () (println
|
exception for the one operator whose legality is only decidable after substituting. `(defn show [x $t] () (print
|
||||||
x))` gets `no printer for t` today. The resolution is small but it is a decision, not an oversight: the abstract
|
x))` gets `no printer for t` today. The resolution is small but it is a decision, not an oversight: the abstract
|
||||||
pass needs an explicit allow-list of forms it defers to instantiation, `println` being the first member. Every
|
pass needs an explicit allow-list of forms it defers to instantiation, `print` being the first member. Every
|
||||||
member of that list is a place where a refusal moves from the definition to a call site, which is exactly what
|
member of that list is a place where a refusal moves from the definition to a call site, which is exactly what
|
||||||
plan.org's rule was trying to avoid — so the list should stay short and be written down.
|
plan.org's rule was trying to avoid — so the list should stay short and be written down.
|
||||||
|
|
||||||
@@ -0,0 +1,500 @@
|
|||||||
|
# The inference spike, answered: the concern was right, and not for the reason it was given
|
||||||
|
|
||||||
|
> **Nothing was built.** SPIKE-GENERICS.md is measurement-heavy because a branch existed to measure; this is a
|
||||||
|
> reading of `lib/check.ml`, `lib/session.ml`, `lib/parse.ml` and the specs, with small probe programs where a
|
||||||
|
> probe settles something a reading cannot. The one number quoted below — 1.8 ms for a whole-program check — is
|
||||||
|
> SPIKE-GENERICS.md's, and the delta an inference fixpoint would add to it **was not measured**. Every other
|
||||||
|
> claim is cited to a line.
|
||||||
|
|
||||||
|
The question: can a `defn`'s type annotations become optional, inferred from the body and its uses, without
|
||||||
|
breaking the live dev loop. The author wants `(defn settle [row col] ...)` to check while sketching.
|
||||||
|
|
||||||
|
**The answer is: don't, in that form — and the obstacle is not the dev loop.** The live loop handles a changed
|
||||||
|
inferred signature correctly the moment inference is body-local; `Session.compatible` catches it by construction
|
||||||
|
and says so in the right words. What stops `(defn settle [row col] ...)` is three things that were each decided
|
||||||
|
on purpose, for reasons written down at the time, and every one of them predates this question:
|
||||||
|
|
||||||
|
1. **The grammar.** `(defn settle [row col] ...)` is not a syntax error today. It **parses**, as one parameter
|
||||||
|
`row` of type `col`. The spelling the author wants is the one spelling that provably cannot be given the
|
||||||
|
meaning they want.
|
||||||
|
2. **Literal defaulting.** `(+ x 1)` does not say what `x` is. It says `1` is an `i32` unless something above it
|
||||||
|
says otherwise, and under inference the "something above it" is gone. Inferring `x := i32` from that is not
|
||||||
|
inference; it is a default wearing inference's clothes, and it moves its error to a call site.
|
||||||
|
3. **The generic reading is refused at the definition.** `(defn settle [row col] (+ row col))` read as generic
|
||||||
|
gets plan.org's rule applied to it, which is the refusal SPIKE-GENERICS.md quotes verbatim: *`+` over the type
|
||||||
|
variable `t` is refused*. Reusing `check_generic` does not buy inference; `check_generic` is the thing that
|
||||||
|
rejects the example.
|
||||||
|
|
||||||
|
What *is* available, cheaply, with a precedent already in the file, is **return-type inference only**. That is
|
||||||
|
the scoped recommendation and its boundary is drawn at the end.
|
||||||
|
|
||||||
|
## What the previously-voiced concern got right, and what it got wrong
|
||||||
|
|
||||||
|
The concern, paraphrased: live re-evaluation of functions makes inference difficult.
|
||||||
|
|
||||||
|
**Wrong about the mechanism.** `Session.eval` re-checks the *whole* program on every `C-c C-c` —
|
||||||
|
|
||||||
|
```ocaml
|
||||||
|
(* session.ml:586 *)
|
||||||
|
let program, env = Check.program_with_env decls in
|
||||||
|
compatible ~origin:(Check.instantiation_origin env) ~loc t.program program;
|
||||||
|
```
|
||||||
|
|
||||||
|
— and `compatible` (session.ml:181) compares the new `Tast.program` against the installed one over
|
||||||
|
`Tast.fn`'s `params` and `ret`, which are types and not source text:
|
||||||
|
|
||||||
|
```ocaml
|
||||||
|
(* session.ml:191 *)
|
||||||
|
let same =
|
||||||
|
List.length f.Tast.params = List.length g.Tast.params
|
||||||
|
&& List.for_all2 Types.equal f.Tast.params g.Tast.params
|
||||||
|
&& Types.equal f.Tast.ret g.Tast.ret
|
||||||
|
in
|
||||||
|
```
|
||||||
|
|
||||||
|
It does not know or care where a type came from. An inferred signature that changes is caught exactly as a
|
||||||
|
written one is, and the refusal already prints both tuples (session.ml:239): *"%s changes signature, from
|
||||||
|
(Fn [...] ...) to (Fn [...] ...); the calls already compiled into the running program pass the old one. Restart
|
||||||
|
to change it."* There is no lock to build and no "inferred at first definition, frozen thereafter" state to
|
||||||
|
keep: the whole-program re-check means the signature is recomputed from the current text every time, so it is a
|
||||||
|
pure function of what is in the buffer, and `compatible` is the diff. **The dev loop's machinery is already
|
||||||
|
sufficient.**
|
||||||
|
|
||||||
|
**Right about the conclusion, via a mechanism that has a name.** The soundness above holds *only while the
|
||||||
|
inferred signature depends on nothing but the edited function's own body.* The moment inference reads call
|
||||||
|
sites, the whole-program re-check turns from an asset into the hazard:
|
||||||
|
|
||||||
|
- Editing function `A` changes the types `A` passes to `B`.
|
||||||
|
- `B`'s signature is inferred from its uses, so `B`'s signature changes.
|
||||||
|
- `compatible` refuses, naming `B` — a function that appears nowhere in the form the author just evaluated —
|
||||||
|
with two type tuples they never wrote, for a reason not visible at the line they edited.
|
||||||
|
|
||||||
|
That is not a hypothetical failure mode; it is the failure mode `session.ml`'s `?origin` parameter already
|
||||||
|
exists to soften for generics, and the comment there describes it in exactly these terms:
|
||||||
|
|
||||||
|
```ocaml
|
||||||
|
(* session.ml:200 *)
|
||||||
|
The refusal then arrives about [sort!-i32], which appears
|
||||||
|
nowhere in the file being edited, for a reason invisible at the
|
||||||
|
edited line.
|
||||||
|
```
|
||||||
|
|
||||||
|
For a generic there is at least an answer to give — *this is the copy of the generic `sort!` at `i32`*. For a
|
||||||
|
use-directed inferred signature there is no such sentence. The honest one is "something else you edited changed
|
||||||
|
what this function's parameters are", and the set of things that could have done it is the program.
|
||||||
|
|
||||||
|
**So the discriminating constraint for the whole design is: inference may read the function's own body and
|
||||||
|
nothing else.** Everything below is downstream of that.
|
||||||
|
|
||||||
|
## Question 2 — direction and scope, and the two features that poison it
|
||||||
|
|
||||||
|
Full Hindley–Milner is out before the language's features are considered, because it is out by the constraint
|
||||||
|
above: HM's whole point is that a use constrains a definition. Constraining `defn` inference to the body makes
|
||||||
|
it **local/bidirectional**, which is what the checker already is.
|
||||||
|
|
||||||
|
### The checker is already bidirectional, and there is a worked precedent
|
||||||
|
|
||||||
|
`check` threads a `?want` — an expected type — through every expression, and the elaborate one-directional
|
||||||
|
inference the language already has is the `fn` literal:
|
||||||
|
|
||||||
|
```ocaml
|
||||||
|
(* check.ml:1980 *)
|
||||||
|
and check_fn ctx ~want loc (params : string list) body =
|
||||||
|
let pts, ret =
|
||||||
|
match want with
|
||||||
|
| Some (Types.Fn (ps, r)) when List.length ps = List.length params -> ps, r
|
||||||
|
```
|
||||||
|
|
||||||
|
An `fn`'s parameters carry no types at all, and they get them from position. That is the feature the author is
|
||||||
|
asking for, already in the language, at a different binding form. And the refusal for when it is unavailable is
|
||||||
|
written, in the voice a `defn` version would have to borrow:
|
||||||
|
|
||||||
|
```ocaml
|
||||||
|
(* check.ml:1993 *)
|
||||||
|
fail loc
|
||||||
|
"nothing here says what this fn's parameters are — an fn takes its \
|
||||||
|
types from the position it is written in, so it goes in an argument \
|
||||||
|
whose parameter is a (Fn [T ...] R), and a name already written as a \
|
||||||
|
defn goes anywhere"
|
||||||
|
```
|
||||||
|
|
||||||
|
Note the last clause. The `fn` literal's inference works *because* a `defn` is annotated. It is checking mode
|
||||||
|
all the way down, and `defn` is where the types enter the system.
|
||||||
|
|
||||||
|
### What a `defn` body can actually tell you about a parameter
|
||||||
|
|
||||||
|
Bidirectional inference has no synthesis rule for a variable. It can only propagate: `x` appears as the first
|
||||||
|
argument of `g`, `g`'s first parameter is `i64`, therefore `x : i64`. That is a use *inside the body*, which the
|
||||||
|
constraint permits, and it is genuinely enough for a large class of Flan functions — a body that calls the
|
||||||
|
prelude or the user's own annotated functions pins its parameters immediately.
|
||||||
|
|
||||||
|
It is not enough for the author's example, and the reason is the second poison.
|
||||||
|
|
||||||
|
### Literal defaulting: `(+ x 1)` — what is `x`?
|
||||||
|
|
||||||
|
`i32`, and not because anything inferred it.
|
||||||
|
|
||||||
|
```ocaml
|
||||||
|
(* check.ml:1803 *)
|
||||||
|
and int_literal loc ~want ?(default = Types.I32) n =
|
||||||
|
match want with
|
||||||
|
| Some (Types.Int k) -> mk loc (Types.Int k) (Tast.Int (in_range loc k n, k))
|
||||||
|
...
|
||||||
|
| _ -> mk loc (Types.Int default) (Tast.Int (in_range loc default n, default))
|
||||||
|
```
|
||||||
|
|
||||||
|
Today the annotation supplies `want` and the literal takes the parameter's type. Probed
|
||||||
|
(`scratchpad/p2.flan`): `(defn f [x i64] i64 (+ x 1))`, `(defn g [x u8] u8 (+ x 1))` and
|
||||||
|
`(defn h [x f32] f32 (+ x 1))` all check, and the same literal `1` is an `i64`, a `u8` and an `f32` in the three
|
||||||
|
bodies. The arithmetic is overloaded over sized ints and floats, and the annotation is what selects the
|
||||||
|
overload.
|
||||||
|
|
||||||
|
Remove the annotation and there is nothing to select with. `(+ x 1)` would have to make `x` an `i32` by
|
||||||
|
*default*, which is a silent monomorphisation nobody wrote — and the error it produces lands at a call site,
|
||||||
|
not at the definition. That failure is already observable in the one place the language does infer a binding
|
||||||
|
with no annotation, the `let` (probe `p6.flan`):
|
||||||
|
|
||||||
|
```
|
||||||
|
(defn f [x i64] i64 (+ x 1))
|
||||||
|
(defn main [] ()
|
||||||
|
(let [n 3]
|
||||||
|
(print (f n))))
|
||||||
|
|
||||||
|
p6.flan:4:17: expected i64, found i32
|
||||||
|
4 | (print (f n))))
|
||||||
|
| ^
|
||||||
|
```
|
||||||
|
|
||||||
|
The mistake is at line 3 — `n` defaulted — and the caret is at line 4. The same program with `f` taking `i32`
|
||||||
|
checks. TODO.org, "A let binding takes no type annotation", records this hazard already in the wild: *"a `let` has no annotation, so `[3.5 -1.0]` is an
|
||||||
|
`[f64]` and every element in `programs/algorithms.flan` is…"*.
|
||||||
|
|
||||||
|
For a `let` this is contained: the binding, the default and the use are all inside one function, usually within
|
||||||
|
a few lines, and the annotation that would fix it is an argument away. For a `defn` parameter it is not
|
||||||
|
contained at all. The default would be baked into a *signature*, published to every call site in the program and
|
||||||
|
into the running process, and the first thing it does under `C-c C-c` is make `compatible` refuse when the
|
||||||
|
author later adds the annotation they meant.
|
||||||
|
|
||||||
|
**This is the concrete answer to the question as posed.** `(+ x 1)` cannot make `x` anything. The three
|
||||||
|
principled options are all worse than an annotation:
|
||||||
|
|
||||||
|
- **Default it to `i32`.** Silent, and wrong for a body about to be called with an `i64`.
|
||||||
|
- **Refuse it** — "nothing here says what `row` is." Correct, and it refuses the author's example, which is the
|
||||||
|
one they asked for.
|
||||||
|
- **Generalise it** — make `row` a type variable. That is question 3, and it is refused at the definition.
|
||||||
|
|
||||||
|
No implicit widening (`sum-i32` returns `i64` by explicit cast, SPIKE-GENERICS.md question 5) closes the escape
|
||||||
|
where a default could be "widened later". Fixed arrays, value semantics and where-predicates are neutral —
|
||||||
|
none of them is harder to infer than to check, because none of them is inferred *from*; they are all checked
|
||||||
|
*against*. The poison is entirely in the two overloaded-by-expectation forms: the integer literal and the
|
||||||
|
arithmetic over it.
|
||||||
|
|
||||||
|
## Question 1, concluded — redefinition
|
||||||
|
|
||||||
|
Restating against the above, since it is the question the spike exists for.
|
||||||
|
|
||||||
|
**Under body-local inference, redefinition is a solved problem and needs no new machinery.** The inferred
|
||||||
|
signature is a function of the edited text; `compatible` compares it to the installed one; the refusal already
|
||||||
|
names both tuples and tells the author to restart. The only thing worth adding is one clause to the message:
|
||||||
|
that the types were inferred and from where, so the author is not hunting a signature they never wrote. That is
|
||||||
|
a `?origin`-shaped change, one call site, and `?origin` is the proof it fits.
|
||||||
|
|
||||||
|
**Under use-directed inference, it creates a new class of refusal with no good message**, for the reasons in the
|
||||||
|
section above. This is where "annotations required only for what the session already holds" would come in as a
|
||||||
|
mitigation — and it is worth saying plainly that **it is a mitigation for a problem the body-local design does
|
||||||
|
not have.** There is nowhere natural to keep the lock, either: `Check.program_with_env` builds a fresh `env`
|
||||||
|
each evaluation (SPIKE-GENERICS.md makes the same observation about the instantiation cache — *"there is no
|
||||||
|
persistent cache to invalidate and therefore no staleness to get wrong"*), so a lock would have to live in
|
||||||
|
`Session.t` as a new table of frozen signatures, with its own invalidation story, its own refusal, and its own
|
||||||
|
answer to "what does a fresh `flan check` of the same file do, which has no session." Do not build it. Pick the
|
||||||
|
design that does not need it.
|
||||||
|
|
||||||
|
## Question 3 — interaction with generics: "unannotated = generic" is refused at the definition
|
||||||
|
|
||||||
|
It is the reading that looks cheapest, because the machinery exists — `check_generic` (check.ml:5947),
|
||||||
|
`generic_call` and `instantiate` (check.ml:4964, 5043), the per-call-site instantiation cache, `bind_ty`
|
||||||
|
substituted left to right. Reading an unannotated `defn` as a generic one with fresh variables, then inferring
|
||||||
|
the `where` clauses from the operators the body uses, is a real design and someone will propose it.
|
||||||
|
|
||||||
|
**It fails on the author's example, by a rule plan.org chose deliberately.** plan.org:928:
|
||||||
|
|
||||||
|
> Generic parameters → inferred at call sites, no explicit instantiation. No type classes. An operator over a
|
||||||
|
> variable with no `where` clause asserting it is rejected at the definition; a `where` predicate is what admits
|
||||||
|
> it.
|
||||||
|
|
||||||
|
`build_program` runs the abstract pass over every generic body (check.ml:6202), and SPIKE-GENERICS.md quotes
|
||||||
|
what it says about exactly this shape:
|
||||||
|
|
||||||
|
```
|
||||||
|
spike/generics/reject.flan:1:26: + over the type variable t is refused: an unconstrained type variable supports
|
||||||
|
only what every type supports, and + is not that (plan.org, Types). Take the operation as a parameter — a
|
||||||
|
(Fn [t t] ...) — and call it here
|
||||||
|
```
|
||||||
|
|
||||||
|
So under the generic reading, `(defn settle [row col] (+ row col))` is refused at its definition. Confirmed
|
||||||
|
empirically — today's message for the author's literal example is a different one, because `col` is read as a
|
||||||
|
type name, but it lands in the same machinery (`scratchpad/p1.flan`):
|
||||||
|
|
||||||
|
```
|
||||||
|
p1.flan:1:19: generic code over the type variable col is not implemented yet — milestone 5 (see plan.org)
|
||||||
|
```
|
||||||
|
|
||||||
|
The "infer the `where` clauses from the operators used" repair is where this gets expensive rather than
|
||||||
|
impossible. Inferring `{:where (is-ordered $t)}` from a `<` in the body is a constraint-collection pass — the
|
||||||
|
predicates are not a fixed lattice (`pred_entails` already has `is-ordered` covering `is-equal`), and the predicate
|
||||||
|
set would have to be closed under the operators, which is a type-class system by another road. plan.org:928 says
|
||||||
|
*no type classes* in the same breath. And it would still not save `(+ row col)`: there is no arithmetic
|
||||||
|
predicate, by design — the language's answer is "take the operation as a parameter", which is a *longer*
|
||||||
|
signature, not a shorter one. SPIKE-GENERICS.md's question 5 already paid this bill in the prelude: *"The
|
||||||
|
functions collapse; the calls get longer."*
|
||||||
|
|
||||||
|
**So unannotated must mean monomorphic**, which hands the whole question back to literal defaulting.
|
||||||
|
|
||||||
|
One thing the generics machinery *does* contribute, and it is the good news in this section: it proves the
|
||||||
|
checker can run a body more than once, with an environment installed and restored around it
|
||||||
|
(`check_generic`'s `saved_vars`/`saved_preds`/`finish`), and that re-checking bodies is cheap — 1.8 ms
|
||||||
|
whole-program, flat, dominated by the 1665-line prelude. An inference fixpoint is the same shape of cost. It was
|
||||||
|
not measured.
|
||||||
|
|
||||||
|
## Question 4 — allocators and ownership: this question closed on 2026-09-18
|
||||||
|
|
||||||
|
It was live, and it is not any more. **Signatures carry types and nothing else.**
|
||||||
|
|
||||||
|
- **Move-only is gone.** spec-memory.md:182: *"**The move-only concept itself is gone.** Everything copies — a
|
||||||
|
container as much as an integer."* `is_move_only` does not appear anywhere in `lib/`. SPIKE-GENERICS.md's
|
||||||
|
"Fiddly" row — ownership not being decidable without the concrete type, the one analysis that did not survive
|
||||||
|
abstraction — was written before the repeal and no longer has a subject.
|
||||||
|
- **The allocator is not in the calling convention as a parameter.** It is a dynamic read: `context/allocator`
|
||||||
|
and `context/temp` resolve to runtime primitives (check.ml:1860-1865), `with-allocator` rebinds a dynamic
|
||||||
|
variable (check.ml:627), and an operation takes at most one explicitly-named allocator as an ordinary argument
|
||||||
|
of type `Alloc` (check.ml:3354). Nothing about it is derived from a signature, so there is nothing for
|
||||||
|
inference to see through.
|
||||||
|
|
||||||
|
Inference would have to infer a parameter of type `Allocator` the same way it infers any other — from a use
|
||||||
|
inside the body — and that is the ordinary case, not a special one.
|
||||||
|
|
||||||
|
## Question 5 — error quality
|
||||||
|
|
||||||
|
The repo's discipline is that a refusal names the thing and points at the line. Inference's structural problem
|
||||||
|
is that the cause and the symptom separate, and the `p6.flan` probe above is the language's own miniature of it:
|
||||||
|
the mistake is the default at line 3, the caret is at line 4.
|
||||||
|
|
||||||
|
The disciplines that keep it acceptable, in the order they matter:
|
||||||
|
|
||||||
|
1. **Body-local inference is the whole of the discipline.** It bounds the distance between cause and symptom to
|
||||||
|
one function. Nothing else on this list would rescue a design without it.
|
||||||
|
2. **Never default in signature position.** A parameter whose type is not pinned by a use in the body is refused
|
||||||
|
by name — *"nothing here says what `row` is; write its type"* — rather than silently becoming an `i32`. This
|
||||||
|
is the `fn`-literal refusal at check.ml:1993, reworded for `defn`, and it is the single most important rule
|
||||||
|
in the design. It is also the rule that refuses the author's example, and the report should not pretend
|
||||||
|
otherwise.
|
||||||
|
3. **The instantiation-origin pattern, borrowed.** `Session.compatible`'s `?origin` shows how a refusal about a
|
||||||
|
name the source does not contain gets an explanation. The inference version is smaller: the signature is
|
||||||
|
inferred, and here is the form that pinned each parameter. One `Loc.note` per parameter.
|
||||||
|
4. **`Loc.failk` keys.** Every refusal in this checker is keyed (`check/unknown-function`,
|
||||||
|
`check/predicate-not-carried`). An inference refusal gets `check/parameter-not-determined` and is testable
|
||||||
|
like every other.
|
||||||
|
|
||||||
|
The annotation ridge that makes this work is not a new idea in the repo: it is plan.org:202 — *"Annotations at
|
||||||
|
function boundaries are unavoidable"* — and the reason given there is prescient about question 3's failure:
|
||||||
|
*"because compile-time overloading is incompatible with full inference."* Overloading is planned, not built
|
||||||
|
(plan.org:387, `defmethod` appears nowhere in `lib/`), so the incompatibility is a future collision rather than a
|
||||||
|
present one; but it is a collision the plan already foresaw, and any inference design that survives today has to
|
||||||
|
be checked against it before multimethods land.
|
||||||
|
|
||||||
|
## Question 6 — the two backends, the daemon, and eldoc
|
||||||
|
|
||||||
|
**Nothing downstream of the checker knows a signature was written.** `emit.ml`, `x86.ml` and `js.ml` read
|
||||||
|
`Tast.fn`'s `params` and `ret`, which are `Types.t` — they have never seen an `Ast.texpr`. The daemon is the
|
||||||
|
same:
|
||||||
|
|
||||||
|
```ocaml
|
||||||
|
(* dev.ml:1015 *)
|
||||||
|
let signature_of_fn (f : Tast.fn) =
|
||||||
|
Printf.sprintf "%s [%s] %s" f.Tast.name
|
||||||
|
(String.concat " " (List.map Types.to_string f.Tast.params))
|
||||||
|
(Types.to_string f.Tast.ret)
|
||||||
|
```
|
||||||
|
|
||||||
|
The `defs` op (dev.ml:1025) and the disassembly header (dev.ml:2671) both go through it, and `flan.el`'s eldoc
|
||||||
|
reads the `defs` cache and nothing else. **So eldoc shows an inferred function's real signature, for free, in
|
||||||
|
the same format.** The comment right above it even removes the one objection someone would raise: *"Parameter
|
||||||
|
*names* are not in the Tast, so a signature shows types only"* (dev.ml:1014) — eldoc is already showing types
|
||||||
|
without names, so an inferred signature is indistinguishable from a written one in the echo area, which is the
|
||||||
|
correct behaviour and cost nothing to get.
|
||||||
|
|
||||||
|
The one thing that *does* read the annotation slot is the frontend, and it has a booby trap:
|
||||||
|
|
||||||
|
- `Ast.fn.ret` is already `Ast.texpr option`, and both `collect` sites read `None` as **`Unit`**
|
||||||
|
(check.ml:5569 and 5706: `match fn.Ast.ret with None -> Types.Unit | Some t -> resolve env t`).
|
||||||
|
- `shim.ml:532` *produces* `ret = None` meaning `Unit`, for the struct-return wrapper. `shim.ml:589` and
|
||||||
|
`cimport.ml:1579` both read `None` as void.
|
||||||
|
- `load.ml` maps over it in three places (314, 323, 354) and walks it for dependencies twice (637, 652).
|
||||||
|
|
||||||
|
So **`None` is taken**. "Infer me" needs a third state — `Ast.ret : Written of texpr | Unit | Infer`, or a
|
||||||
|
separate flag — and that is a small, mechanical edit across `load.ml`, `shim.ml`, `cimport.ml` and two `collect`
|
||||||
|
arms. Small, but it is not free, and anyone who reads `ret option` and concludes the slot is already optional
|
||||||
|
has misread it.
|
||||||
|
|
||||||
|
## Question 7 — cost, and the increments
|
||||||
|
|
||||||
|
### The grammar comes first, and it is not a detail
|
||||||
|
|
||||||
|
```ocaml
|
||||||
|
(* parse.ml:104 *)
|
||||||
|
let rec fields (f : Form.t) (items : Form.t list) : Ast.field list =
|
||||||
|
match items with
|
||||||
|
| [] -> []
|
||||||
|
| name :: ty :: rest ->
|
||||||
|
no_pattern name;
|
||||||
|
{ Ast.fname = sym name; fty = texpr ty; floc = name.loc } :: fields f rest
|
||||||
|
| [ odd ] ->
|
||||||
|
Loc.fail odd.loc "field %s has no type — these come in name/type pairs"
|
||||||
|
(Form.to_string odd)
|
||||||
|
```
|
||||||
|
|
||||||
|
A parameter vector is a flat list of pairs. Probed:
|
||||||
|
|
||||||
|
- `(defn settle [row col] ...)` — **parses**, as `row : col`. Not an error. The error the author sees comes much
|
||||||
|
later, from the type resolver, about a type named `col`.
|
||||||
|
- `(defn settle [row] i32 ...)` — `p4.flan:1:15: field row has no type — these come in name/type pairs`.
|
||||||
|
- `(defn settle [row col x] i32 ...)` — `p3.flan:1:23: field x has no type — these come in name/type pairs`.
|
||||||
|
|
||||||
|
So an odd count is a parse error and an even count is a silently different program. There is no count to
|
||||||
|
disambiguate by, which is precisely the finding TODO.org, "A let binding takes no type annotation", records for `let`: *"`let` is a flat list of
|
||||||
|
pairs, so it cannot disambiguate by count the way `defonce` and `defconst` do — those read `[n t v]` as three
|
||||||
|
arguments to a form, and there is no such boundary between one pair and the next."*
|
||||||
|
|
||||||
|
And the meaning that would have to be given to `[row col]` is exactly the class of change this parser was
|
||||||
|
rewritten to make impossible. The `defn` return slot was made mandatory (parse.ml:904) because the optional
|
||||||
|
version *"was wrong twice in one day, the second time parsing `(defn f [] (Rune {.code 65}) (bar))` as a
|
||||||
|
function returning a Rune with a one-form body, silently, in every file in the language. A silent misparse is
|
||||||
|
the worst failure class available, and macros now generate definitions, which widens it."* `defunion` was
|
||||||
|
refused by name (parse.ml:881) for the identical reason. Making `[row col]` mean two unannotated parameters
|
||||||
|
reintroduces the pattern in the one form both of those decisions were about, and it breaks every existing
|
||||||
|
two-parameter signature in the corpus in silence.
|
||||||
|
|
||||||
|
**So a `defn` with unannotated parameters needs new syntax** — a marker, a separate vector, or a distinct form —
|
||||||
|
and the choice is a language-design decision, not a compiler one. TODO.org, "A let binding takes no type
|
||||||
|
annotation", already sketched the three
|
||||||
|
surfaces for the `let` version of the same problem and preferred the one that avoided new binding-vector syntax.
|
||||||
|
The cheap first step below is the one that needs **no** grammar change at all.
|
||||||
|
|
||||||
|
### What a full implementation touches, honestly
|
||||||
|
|
||||||
|
| | |
|
||||||
|
|---|---|
|
||||||
|
| **Grammar** | new parameter syntax in `parse.ml`'s `fields`/`defn` arms, plus its own refusals; a language decision before it is an edit |
|
||||||
|
| **AST and frontend** | a third state on `Ast.fn.ret` and a way to spell an un-annotated `Ast.field`; mechanical fallout in `load.ml` (5 sites), `shim.ml` (3), `cimport.ml` (2) |
|
||||||
|
| **The checker's two-pass split** | the real work. `collect` (check.ml:5545-5715) builds `env.fns` from annotations *alone*, before any body is looked at; `check_fn` (check.ml:5851) opens with `Hashtbl.find env.fns fn.Ast.name`. Inference breaks the split in both directions: a signature now needs its body, and a body needs its callees' signatures. The fix is a fixpoint, and the precedent is in the same function (check.ml:5725, the untyped-`defconst` loop) — *"Also to a fixpoint, and for the same reason: one untyped constant may be defined in terms of another declared after it. A constant that still does not check once no progress is left has a real error, so the last round is run without swallowing it."* |
|
||||||
|
| **Mutual recursion** | has no fixpoint. Two inferred functions each calling the other pin nothing, and must be refused **by name**, saying which two and that one of them needs an annotation. This is a new refusal with no analogue in the file |
|
||||||
|
| **The session** | one clause on the `compatible` message saying the types were inferred, in the `?origin` shape |
|
||||||
|
| **Backends, daemon, eldoc** | **untouched**, per question 6 |
|
||||||
|
| **Does not work** | "unannotated only for non-exported defns" is not available as a boundary. `Load` flattens every import into one namespace before checking (SPIKE-GENERICS.md's last "no plan" row says the same thing about generics across packages), so there is no export boundary at check time to draw the line at |
|
||||||
|
|
||||||
|
### The cheap first step, and it is a real one
|
||||||
|
|
||||||
|
**Infer the return type only.** Parameters stay annotated. `(defn settle [row i32 col i32] (+ row col))`.
|
||||||
|
|
||||||
|
It is worth taking seriously because everything expensive above evaporates:
|
||||||
|
|
||||||
|
- **One grammar decision instead of two, and it needs a marker.** Omitting the return slot cannot be decided by
|
||||||
|
count, and the temptation to say otherwise should be resisted: `defonce` and `defconst` disambiguate by count
|
||||||
|
because they have a *fixed maximum arity* — `[n t v]` is three slots and there is no fourth. A `defn` body is
|
||||||
|
an unbounded list of forms, so `(defn f [] (a) (b))` is `ret=(a), body=(b)` or `infer-ret, body=(a) (b)` and
|
||||||
|
nothing in the shape decides which. That is the same structural fact TODO.org, "A let binding takes no type
|
||||||
|
annotation", states about `let` — *"there is
|
||||||
|
no such boundary between one pair and the next"* — moved to the boundary between the return slot and the
|
||||||
|
first body form, and it is precisely the case that sank the slot the first time: `(defn f [] (Rune {.code
|
||||||
|
65}) (bar))` is a two-form example, and a count-based rule has no rule to apply to it at all. The
|
||||||
|
one-form case, contrary to appearances, is the safe one: `(defn f [] ())` means the same either way, and
|
||||||
|
`(defn f [] Bar)` with no body is already refused by `check_fn`'s *"%s returns %s but has no body"*.
|
||||||
|
|
||||||
|
So the scoped version requires a **marker** — `(defn f [] :- (foo))`, or whatever spelling wins. That is one
|
||||||
|
new token in one parser arm, refusable by shape rather than by looking a symbol up in a table, which is the
|
||||||
|
property parse.ml:904 says the old design lacked. It is a much smaller ask than the parameter-vector surgery
|
||||||
|
optional parameters need, but it is **not free**, and this report claimed otherwise in an earlier draft.
|
||||||
|
- **No parameter defaulting.** Every parameter still has a type, so `want` still flows down into the body,
|
||||||
|
`(+ x 1)` still means what it means today, and the integer-literal hazard never arises. This is the point: the
|
||||||
|
return type is *synthesised from* a fully checked body, which is the one direction bidirectional checking
|
||||||
|
actually supports.
|
||||||
|
- **The fixpoint is the `defconst` one**, with the same shape and the same stated limit. Two mutually recursive
|
||||||
|
return-inferred functions do not converge and get refused by name in the last round — and the refusal should
|
||||||
|
name the *chain*, not just the pair, because the chain is what an author has to break.
|
||||||
|
- **`compatible` needs no change, but there is a cascade and it is smaller than the use-directed one.** The
|
||||||
|
inferred return is a function of the body, and a body contains calls: if `B`'s last form is `(A x)` then
|
||||||
|
`B`'s return *is* `A`'s return, so editing `A` changes `B`'s signature and `compatible` refuses about `B`,
|
||||||
|
which the author did not touch. This is the same shape as the hazard that rules out use-directed inference —
|
||||||
|
but with one decisive difference: the primary refusal about `A` is present and correct, and every downstream
|
||||||
|
one is *explainable in a sentence the compiler can write* — "B returns what A returns". The use-directed
|
||||||
|
version has no such sentence. Propagation follows call edges out of the body, so it is bounded and nameable;
|
||||||
|
that is the whole distinction.
|
||||||
|
- **eldoc, `defs` and both backends are unchanged**, per question 6.
|
||||||
|
|
||||||
|
It does not give the author `(defn settle [row col] ...)`. It gives them a `defn` that is shorter by one token,
|
||||||
|
and it removes the annotation that is most often mechanical — `()` on every mutating function in the corpus.
|
||||||
|
Whether that is worth a grammar decision is the author's call and this report does not make it.
|
||||||
|
|
||||||
|
## Verdict
|
||||||
|
|
||||||
|
**Do a scoped version, or do nothing. Do not build optional parameter annotations.**
|
||||||
|
|
||||||
|
The concern that was voiced was correct in its conclusion and wrong in its mechanism, and the distinction is the
|
||||||
|
useful part: **live re-evaluation is not what makes this hard.** `Session.compatible` already handles a changed
|
||||||
|
inferred signature correctly, in the right words, with no new machinery, the moment inference reads only the
|
||||||
|
edited function's body. If the dev loop had been the only obstacle, this would be a cheap feature.
|
||||||
|
|
||||||
|
What actually blocks it are three decisions the project already made on purpose:
|
||||||
|
|
||||||
|
- the parameter vector is a flat pair list, so `[row col]` already parses as something else, and giving it the
|
||||||
|
wanted meaning reintroduces the silent-misparse class that mandatory return types and the `defunion` refusal
|
||||||
|
were both introduced to close (parse.ml:881, parse.ml:904, TODO.org, "A let binding takes no type
|
||||||
|
annotation");
|
||||||
|
- integer literals default to `i32` when nothing expects otherwise (check.ml:1803), so an unannotated parameter
|
||||||
|
is either silently monomorphised or refused — and the refusal refuses the motivating example;
|
||||||
|
- an unannotated parameter read as a type variable is rejected at its definition by plan.org's
|
||||||
|
no-type-classes rule, which `check_generic` implements (check.ml:5947, plan.org:928).
|
||||||
|
|
||||||
|
**The scoped version's exact boundary:** parameter types stay mandatory; the return type becomes inferrable,
|
||||||
|
spelled with an explicit marker rather than by omission, from a body checked with every parameter already known;
|
||||||
|
inference reads the function's own body and never a call site; a return-inferred body that calls another
|
||||||
|
return-inferred function propagates along that call edge and no further; a cycle among them is refused by name,
|
||||||
|
naming the chain. Nothing downstream of `check.ml` changes. The grammar cost is one marker in one parser arm —
|
||||||
|
real, and one decision rather than the several optional parameters need.
|
||||||
|
|
||||||
|
**Top three risks**, in order:
|
||||||
|
|
||||||
|
1. **The grammar decision is the project, and it has already bitten twice.** Both times it bit, it bit
|
||||||
|
silently — a program that compiled and meant something else. Any surface for "no annotation here" must be
|
||||||
|
refusable by shape rather than by looking a symbol up in a table, or it will bite a third time. **The scoped
|
||||||
|
version does not escape this** — a `defn` body is an unbounded form list, so an omitted return slot cannot be
|
||||||
|
decided by count, which is why the marker above is a requirement and not a nicety. The difference between the
|
||||||
|
scoped version and the full one is that the scoped version needs *one* such decision.
|
||||||
|
2. **Scope creep from "return only" to "parameters too."** The scoped version is pleasant and will immediately
|
||||||
|
invite the next step, and the next step crosses from synthesis into defaulting. The line to hold is one
|
||||||
|
sentence: *nothing may be defaulted in signature position.* Write it down before building, because
|
||||||
|
the first `i32` that leaks into an inferred parameter will not announce itself — it will show up as a caller
|
||||||
|
mismatch three functions away, as `p6.flan` shows.
|
||||||
|
3. **Compile-time overloading, when it lands.** plan.org:203 already says overloading and full inference are
|
||||||
|
incompatible, and multimethods are still unbuilt. Any inference the language ships now becomes a constraint
|
||||||
|
on how overload resolution can be specified later, and that bill is not payable in this lane.
|
||||||
|
|
||||||
|
## Reproducing
|
||||||
|
|
||||||
|
`dune build` is green; nothing in the tree was changed. The probes are one-liners and are quoted inline:
|
||||||
|
|
||||||
|
```lisp
|
||||||
|
;; p1 — the author's example: "generic code over the type variable col"
|
||||||
|
(defn settle [row col] (+ row col))
|
||||||
|
|
||||||
|
;; p2 — the annotation is what selects the arithmetic overload; all three check
|
||||||
|
(defn f [x i64] i64 (+ x 1)) (defn g [x u8] u8 (+ x 1)) (defn h [x f32] f32 (+ x 1))
|
||||||
|
|
||||||
|
;; p3, p4 — an odd parameter count is the only thing the parser refuses
|
||||||
|
(defn settle [row] i32 (+ row 1)) ; field row has no type
|
||||||
|
(defn settle [row col x] i32 (+ row col)) ; field x has no type
|
||||||
|
|
||||||
|
;; p6 — defaulting moves the error away from the cause
|
||||||
|
(defn f [x i64] i64 (+ x 1))
|
||||||
|
(defn main [] () (let [n 3] (print (f n)))) ; 4:17: expected i64, found i32
|
||||||
|
```
|
||||||
@@ -51,7 +51,7 @@ handler after it, because `SIGFPE` cannot be caught and resumed. Once the zero t
|
|||||||
`INT64_MIN / -1` test is nearly free on the same path.
|
`INT64_MIN / -1` test is nearly free on the same path.
|
||||||
|
|
||||||
Unsigned division gets the zero test only; there is no overflow case. Float division is **not** guarded at all:
|
Unsigned division gets the zero test only; there is no overflow case. Float division is **not** guarded at all:
|
||||||
IEEE `x / 0.0` is `inf`, which is defined and wanted — `rand-f32` in the prelude divides by a float constant.
|
IEEE `x / 0.0` is `inf`, which is defined and wanted — `rand` in the prelude divides by a float constant.
|
||||||
|
|
||||||
## The x86 backend, item 3 of `HANDOFF-x86-rt.md`
|
## The x86 backend, item 3 of `HANDOFF-x86-rt.md`
|
||||||
|
|
||||||
@@ -76,7 +76,7 @@ because `load_loc` has already widened both operands according to their own sign
|
|||||||
backends used to diverge silently rather than both dying: x86 divided in 64 bits and truncated on the store, producing
|
backends used to diverge silently rather than both dying: x86 divided in 64 bits and truncated on the store, producing
|
||||||
`-2147483648` for an `i32`, where LLVM emitted poison. `arith.flan` has an `i32` case for exactly that reason.
|
`-2147483648` for an `i32`, where LLVM emitted poison. `arith.flan` has an `i32` case for exactly that reason.
|
||||||
|
|
||||||
`spike/x86/survey.sh` is 101 MATCH / 0 DIFFER / 0 REFUSED, with the two programs this change adds among them.
|
`test/survey-x86.sh` is 101 MATCH / 0 DIFFER / 0 REFUSED, with the two programs this change adds among them.
|
||||||
|
|
||||||
`arith.flan` carries an `i32` overflow case and an `f32` cast case on purpose, and neither is padding. The `i32`
|
`arith.flan` carries an `i32` overflow case and an `f32` cast case on purpose, and neither is padding. The `i32`
|
||||||
overflow is where the two backends disagreed *silently* rather than both dying, and it is the only thing that
|
overflow is where the two backends disagreed *silently* rather than both dying, and it is the only thing that
|
||||||
@@ -101,7 +101,7 @@ because the reader who reaches `(/ min -1)` has probably never had to think abou
|
|||||||
Three things in those two functions are worth knowing:
|
Three things in those two functions are worth knowing:
|
||||||
|
|
||||||
- **Integer division only.** IEEE `x / 0.0` is an infinity and is a defined answer somebody may want — the prelude's
|
- **Integer division only.** IEEE `x / 0.0` is an infinity and is a defined answer somebody may want — the prelude's
|
||||||
own `rand-f32` divides by a float constant — so guarding a float division would be refusing a result the language
|
own `rand` divides by a float constant — so guarding a float division would be refusing a result the language
|
||||||
already promises.
|
already promises.
|
||||||
- **One branch, not two.** The zero test and the `INT_MIN / -1` test are `or`-ed into a single compare-and-branch, and
|
- **One branch, not two.** The zero test and the `INT_MIN / -1` test are `or`-ed into a single compare-and-branch, and
|
||||||
*which* of them fired is decided by a `select` that is dead on the fall-through path. The guard is also dropped
|
*which* of them fired is decided by a `select` that is dead on the fall-through path. The guard is also dropped
|
||||||
@@ -0,0 +1,138 @@
|
|||||||
|
# Handoff — the pointer arm `agrees` already promised
|
||||||
|
|
||||||
|
`lib/cimport.ml`'s `agrees` decides whether a hand-written `declare-c` and the C header
|
||||||
|
say the same thing. Its comment had always listed three differences that are "expected and
|
||||||
|
are not reported"; the code implemented two of them. The missing one — *a `(Ptr T)` where
|
||||||
|
the header says `T *`* — is what `../PORTING.md` §A.1 and §A.2 ran into, and it is why
|
||||||
|
`GetCodepointPrevious` could not be bound honestly and why `UpdateTexture` had to be handed
|
||||||
|
`(addr (.r (at (slice-from-ptr pixels n) 0)))`.
|
||||||
|
|
||||||
|
The arm is built. This file is the record of what it accepts, what it still refuses, and
|
||||||
|
the one thing that turned out not to be its fault.
|
||||||
|
|
||||||
|
## What the arm is
|
||||||
|
|
||||||
|
`ptr_agrees` and `agrees_c` beside `agrees` in `lib/cimport.ml`, consulted only from the
|
||||||
|
two `declare-c` sites in `diff_bound`. It takes the **C spelling** and not only the
|
||||||
|
rendered Flan type, because by the time a parameter has been rendered the header's word is
|
||||||
|
gone: `param_ty` turns `const char *` into `string` and `value_ty` turns `void *` into
|
||||||
|
`(Ptr u8)`, and neither of those is what the header said. A hand-written line that
|
||||||
|
disagrees with a rendering is not disagreeing with the header, and that distinction is the
|
||||||
|
whole of the arm.
|
||||||
|
|
||||||
|
`agrees` itself is untouched. `check_structs` uses it for field **widths**, and a struct
|
||||||
|
field is about layout — every pointer in a struct is one word whatever it points at — so
|
||||||
|
widening it there would buy nothing and would cost the discipline the field check exists
|
||||||
|
to keep.
|
||||||
|
|
||||||
|
## What it accepts
|
||||||
|
|
||||||
|
- `(Ptr T)` against a C `T *` for the same `T`.
|
||||||
|
- `(Ptr u8)` against `char *` and `const char *`. Inside a pointer, `char` and
|
||||||
|
`unsigned char` are two spellings of one byte and the package uses `(Ptr u8)` for both.
|
||||||
|
The `i8`/`u8` tolerance is the **pointee's** and not the world's; as a scalar or a field
|
||||||
|
the two are still a real disagreement, and there is a test for that.
|
||||||
|
- `(Ptr T)` for **any** `T` against `void *` and `const void *`. This is the judgement
|
||||||
|
call and the reason is sharper than "it is opaque": `value_ty` *invents* the `(Ptr u8)`
|
||||||
|
it renders a `void *` as, so the check without this arm was enforcing cimport's own guess
|
||||||
|
as if the header had said it. What is **not** given up is that it is a pointer at all —
|
||||||
|
the Flan side must still be a `(Ptr _)`, so an `i32` or a `string` declared against a
|
||||||
|
`void *` is still a finding. raylib spells thirty-odd parameters `void *` and none of
|
||||||
|
them is a scalar.
|
||||||
|
- `(Ptr Key)` against a header's `int *`, through the existing enum arm. The same four
|
||||||
|
bytes through a pointer as beside one.
|
||||||
|
|
||||||
|
## What it refuses
|
||||||
|
|
||||||
|
- `(Ptr A)` against `B *` for different named `A` and `B`. Two structs of the same size
|
||||||
|
are still two different structs.
|
||||||
|
- Anything that is not a pointer on the Flan side against a C pointer, `void *` included.
|
||||||
|
- Everything `agrees` already refused, unchanged.
|
||||||
|
|
||||||
|
## What `const` does here: nothing, and the reason is invisible
|
||||||
|
|
||||||
|
Worth writing down because reading the code does not show it. A non-const `char *`
|
||||||
|
parameter makes `param_ty` **refuse**, and `diff_bound`'s `| None -> None` means a
|
||||||
|
parameter the importer cannot render at all is *skipped rather than compared*. So a
|
||||||
|
hand-written `(Ptr u8)` over a `char *` has always passed — unexamined, not approved. Only
|
||||||
|
`const char *` ever reaches the comparison, and that is the case the arm exists for. The
|
||||||
|
rewritten comment at the head of `diff_bound` now says so.
|
||||||
|
|
||||||
|
## The comment at `lib/cimport.ml:1291`
|
||||||
|
|
||||||
|
Rewritten from a promise into a description. The count it carried — "176 `declare-c`
|
||||||
|
lines", twenty short on the day it was read — is gone rather than corrected, and both
|
||||||
|
comments now name the `grep` that answers the question instead of recording an answer that
|
||||||
|
goes stale. `vendor/raylib/headers` carried the same rot, "425 declarations … 172
|
||||||
|
hand-written", and got the same treatment. Neither file states a number any more.
|
||||||
|
|
||||||
|
## Then it was used
|
||||||
|
|
||||||
|
**§A.1 came out entirely, and it is the arm's own case.**
|
||||||
|
`vendor/raylib/raylib.flan` has `get-codepoint-previous-raw` — `(Ptr u8)` over a
|
||||||
|
`const char *`, which is precisely what the arm was missing — and a `get-codepoint-previous`
|
||||||
|
wrapper that takes the bytes and an offset and builds the interior pointer itself.
|
||||||
|
`generated.flan` no longer carries the `string`-faced version: a binding that is wrong for
|
||||||
|
the only direction it reads in is worse than no binding, and the hand-written declaration
|
||||||
|
suppresses the generated one by C symbol. `examples/text-codepoints-loading.flan`'s
|
||||||
|
`step-back` is one call to it; the continuation-byte walk and `continuation?` are deleted.
|
||||||
|
The answer is 12356 and 3, verified by running it.
|
||||||
|
|
||||||
|
`test/programs/raylib-codepoints.flan` would have caught the old answer, verified by
|
||||||
|
perturbation rather than by argument: make `step-back` set `size` to 0 — which is exactly
|
||||||
|
what the broken string call produced — and both rows go red, because the backward walk
|
||||||
|
never reaches offset 0 and runs off the end of its array.
|
||||||
|
|
||||||
|
**§A.2's call site came out; the cast moved rather than vanished.** The header check does
|
||||||
|
accept the `(Ptr Color)` binding now. What the header check was masking is that
|
||||||
|
`lib/shim.ml:651` refuses a second `declare-c` for a C symbol the package already binds,
|
||||||
|
and that rule is right: a shim emits one C prototype per declaration, and two prototypes
|
||||||
|
for `UpdateTexture` that disagree about a parameter type is a C file that does not compile.
|
||||||
|
Its message says what to write instead — "another Flan name for it is a defn" — so
|
||||||
|
`raylib.flan` has `update-texture-colors`, a one-line defn over the generated
|
||||||
|
`update-texture`:
|
||||||
|
|
||||||
|
```flan
|
||||||
|
(defn update-texture-colors [texture Texture2D pixels (Ptr Color)] ()
|
||||||
|
(update-texture texture (addr (.r pixels))))
|
||||||
|
```
|
||||||
|
|
||||||
|
The `(Ptr u8)` face has to stay the declared one, because `(.data im-copy)` is already a
|
||||||
|
`(Ptr u8)` over the same bytes and `(Ptr u8)` → `(Ptr Color)` is the direction the language
|
||||||
|
cannot write. `(addr (.r pixels))` was checked against the bytes rather than reasoned
|
||||||
|
about: a `gen-image-color 2 1 red` through `load-image-colors`, read back through the `u8`
|
||||||
|
pointer, gives 230 41 55 255. So the honest statement is that §A.2 is half closed — the
|
||||||
|
example reads `(rl/update-texture-colors texture pixels)`, the cast exists once with a name
|
||||||
|
and a comment on it instead of once per call site, and the general gap the section is
|
||||||
|
actually about is a **pointer reinterpretation**, which is not a checker arm.
|
||||||
|
|
||||||
|
## Verification
|
||||||
|
|
||||||
|
- `dune build --root .` and `dune test --root .` clean; the dev suite is 232 checks, 0
|
||||||
|
failures, unchanged — the new checks are in `test_flan.ml`, which reports pass/fail
|
||||||
|
rather than a count.
|
||||||
|
- New checks in `test/test_flan.ml` over three new functions in `test/headers/sample.h`
|
||||||
|
(`blit`, `scratch`, `pair_len_p`): six declarations that must agree, five that must
|
||||||
|
still be reported, each asserting on the message and not on a count. All of them were
|
||||||
|
confirmed live by breaking `ptr_agrees` in three different directions and watching the
|
||||||
|
right subset go red — the negatives matter most, and they are why the arm can be widened
|
||||||
|
without the check becoming decoration.
|
||||||
|
- The raylib acceptance cases ran rather than skipped (`ldconfig` finds
|
||||||
|
`libraylib.so.550`); the only "skipping" line in the whole run is the web one, which
|
||||||
|
wants a wasm build of raylib that is not in this tree.
|
||||||
|
- `flan generate-c vendor/raylib` completes, which is itself the check: it compares every
|
||||||
|
`defstruct`, every hand-written `declare-c` and every mapped constant against
|
||||||
|
`raylib-5.5.h` and refuses to write when they disagree.
|
||||||
|
- `bash web/examples/check.sh` green.
|
||||||
|
- `test/survey-x86.sh` on the finished tree: **103 MATCH, 0 DIFFER, 0 REFUSED** (38 skip
|
||||||
|
— 28 that do not compile on purpose, 8 with no main, 2 that run forever). Expected
|
||||||
|
rather than surprising: nothing here is below the IR, and the one surveyed program that
|
||||||
|
changed is `test/programs/raylib-codepoints.flan`. Run it detached — `setsid timeout
|
||||||
|
2400 test/survey-x86.sh > log 2>&1 </dev/null` — because a foreground run takes the
|
||||||
|
signal sent to its process group and returns a spurious 143.
|
||||||
|
|
||||||
|
## Still open
|
||||||
|
|
||||||
|
- A pointer reinterpretation in the language. `(addr (.r p))` works when the first field
|
||||||
|
is the type you want and there is no general form of it. This is §A.2's real subject.
|
||||||
|
- Nothing else. The three differences the comment lists are now all three implemented.
|
||||||
@@ -57,7 +57,7 @@ leak into other builds. The channel was the defect, not the cause.
|
|||||||
`error`, `Error` or `FAIL`, because the reader it is written for is scanning for exactly those words. The reprint
|
`error`, `Error` or `FAIL`, because the reader it is written for is scanning for exactly those words. The reprint
|
||||||
header names that signature rather than a count, because a step that fails *before* either chmod window leaves no
|
header names that signature rather than a count, because a step that fails *before* either chmod window leaves no
|
||||||
deliberate failure in the log at all, and a header promising two of them would be the wrong diagnosis NEXT.md
|
deliberate failure in the log at all, and a header promising two of them would be the wrong diagnosis NEXT.md
|
||||||
warns about.
|
(now `TODO.org`) warns about.
|
||||||
|
|
||||||
`test/dune` was **not** touched, and neither was anything under `lib/`. The whole change is in `test/test_dev.ml`
|
`test/dune` was **not** touched, and neither was anything under `lib/`. The whole change is in `test/test_dev.ml`
|
||||||
and this file.
|
and this file.
|
||||||
@@ -98,9 +98,9 @@ should be reading on a green run.
|
|||||||
Baseline not regressed, all three measured after the change:
|
Baseline not regressed, all three measured after the change:
|
||||||
|
|
||||||
- `dune test --root .` — exit 0.
|
- `dune test --root .` — exit 0.
|
||||||
- `spike/x86/survey.sh` — **101 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86**, 36 skipped (28 does-not-compile, 6 no-main,
|
- `test/survey-x86.sh` — **101 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86**, 36 skipped (28 does-not-compile, 6 no-main,
|
||||||
2 runs-forever).
|
2 runs-forever).
|
||||||
- `spike/x86/cells.sh` — **4/4**, exit 0.
|
- `test/cells.sh` — **4/4**, exit 0.
|
||||||
|
|
||||||
One thing not to re-derive: a first attempt at the survey came back `SURVEY_EXIT=143` with a bare `Terminated`. That
|
One thing not to re-derive: a first attempt at the survey came back `SURVEY_EXIT=143` with a bare `Terminated`. That
|
||||||
was the harness killing the process group of a long background command, not a survey failure and nothing to do with
|
was the harness killing the process group of a long background command, not a survey failure and nothing to do with
|
||||||
@@ -0,0 +1,157 @@
|
|||||||
|
# dyn, milestone 1 — what was decided and what is left
|
||||||
|
|
||||||
|
The compiler half of dynamic-by-default. The runtime half is a sibling's, built
|
||||||
|
in parallel against `runtime/flan_dyn.h`, which is the fixed ABI and the thing
|
||||||
|
the two copies are diffed against.
|
||||||
|
|
||||||
|
## Two decisions that differ from the brief
|
||||||
|
|
||||||
|
**The return slot stays mandatory; `dyn` is written out in it.** The brief
|
||||||
|
expected `ret = None` to grow a third state meaning "unannotated", and listed
|
||||||
|
mechanical fallout in `load.ml`, `shim.ml` and `cimport.ml`. That fallout does
|
||||||
|
not exist, because the change was not made. The reason is in `parse.ml` beside
|
||||||
|
the `defn` case: an optional return slot has *no* syntactic resolution, since a
|
||||||
|
capitalised head in a list is both a type application and a struct literal —
|
||||||
|
`(defn f [] (Rune {.code 65}) (bar))` is the misparse that removed the old
|
||||||
|
optional slot, and it would come straight back. A parameter vector has no such
|
||||||
|
case, because every slot in it is a name or a type and never an expression. So
|
||||||
|
`ret = None` still means Unit and only `declare` and the shim produce it. One
|
||||||
|
token in the return position buys a decision the file paid for twice in one day.
|
||||||
|
|
||||||
|
**The parameter rule is resolved in `Check`, not in `parse.ml`.** The brief
|
||||||
|
asked for "a known type name is a type, anything else is another dyn param",
|
||||||
|
written where `parse.ml` argues its other misparse-closing decisions. That
|
||||||
|
lookup is exactly the one `parse.ml:904` records being removed for being wrong
|
||||||
|
twice in one day, and at parse time the set of type names is incomplete *by
|
||||||
|
construction* — macros generate definitions, packages are loaded later, C
|
||||||
|
headers are imported later. `cimport.ml` decides it: `named env n = tname n`
|
||||||
|
passes C type names through verbatim, so POSIX's `stat` and `timespec` are
|
||||||
|
lowercase Flan type names writable in parameter position, and no syntactic rule
|
||||||
|
("capitalised is a type") can be made sound.
|
||||||
|
|
||||||
|
So the vector is carried undecided as `Ast.pitem`s and paired in
|
||||||
|
`Check.pair_params`, after every file is loaded, every macro expanded and every
|
||||||
|
header imported. The argument is written at `parse.ml`'s `defn` case as asked.
|
||||||
|
|
||||||
|
## The residual the parent owns
|
||||||
|
|
||||||
|
The set of type names is complete at a point in time and **not across time**.
|
||||||
|
`(defn f [x y] ...)` is two dyn parameters until somebody writes
|
||||||
|
`(defstruct y ...)` — or imports a header that declares one — and then it is one
|
||||||
|
parameter of type `y`, with no edit to `f`. The signature changes underneath it,
|
||||||
|
and arity changes with it.
|
||||||
|
|
||||||
|
`Session.compatible` is where that is felt: it compares with `Types.equal` over
|
||||||
|
parameters and return, so a redefinition that changes dyn-ness is refused like
|
||||||
|
any other signature change (this falls out; it is pinned in `test_session.ml`).
|
||||||
|
But the *first* definition after such an edit is the one that changes, and
|
||||||
|
nothing warns.
|
||||||
|
|
||||||
|
## What the feature costs, and what was taken back
|
||||||
|
|
||||||
|
A parameter slot with no type used to be a syntax error. It is now a `dyn`
|
||||||
|
parameter, so **a mistyped type silently becomes an extra parameter** — the
|
||||||
|
arity changes with no diagnostic, which is the failure class `parse.ml` calls
|
||||||
|
the worst available. Two rules take most of it back, in `dyn_param_or_typo`:
|
||||||
|
|
||||||
|
- a name within one edit of a type's name gets the resolver's own "did you
|
||||||
|
mean", and
|
||||||
|
- an unknown **capitalised** name is reported as an unknown type. Not one
|
||||||
|
parameter in the corpus is capitalised, while `Form`, `Cursor` and `Vector2`
|
||||||
|
appear in these vectors constantly.
|
||||||
|
|
||||||
|
What is left uncovered is a lowercase name resembling no type: `(defn f [x
|
||||||
|
widget] ())` is two dyn parameters and nothing in the text says otherwise. That
|
||||||
|
is the feature working as specified.
|
||||||
|
|
||||||
|
**Sharp edge of the near-miss rule.** `near_miss` treats any two single-char
|
||||||
|
names as one edit apart, and it compares against every struct name in scope. So
|
||||||
|
a `(defstruct D ...)` anywhere in the program makes `(defn f [a d] ...)` a
|
||||||
|
refusal rather than two dyn parameters. The message is actionable — write the
|
||||||
|
type, or rename — but it is a refusal a user will meet without having done
|
||||||
|
anything wrong.
|
||||||
|
|
||||||
|
## Open ABI point for the integrator
|
||||||
|
|
||||||
|
**A rooted slot holding 0 is not a value, and the collector must skip it.**
|
||||||
|
This is written into `runtime/flan_dyn.h` beside the root functions, and it is
|
||||||
|
the one thing in that header decided by one side alone. Roots are pushed in the
|
||||||
|
function's entry block, before the code that fills them has run and possibly for
|
||||||
|
a branch that never runs, so the compiler zeroes every root slot and must mean
|
||||||
|
something by it — and 0 is the only pattern it can write without knowing the
|
||||||
|
encoding.
|
||||||
|
|
||||||
|
If the real runtime NaN-boxes and integer zero is the zero word, this is wrong
|
||||||
|
and the two sides need a different sentinel. Do not fix it on one side.
|
||||||
|
|
||||||
|
**Settled, by reading the other side.** The real runtime does NaN-box, and the
|
||||||
|
zero word is *not* the zero integer: an integer is boxed, and boxed means the
|
||||||
|
quiet-NaN prefix is set. `mark_value` in `runtime/flan_dyn.c` follows a value
|
||||||
|
only when `dyn_boxed` holds, which tests `(v & 0xFFF8000000000000) ==
|
||||||
|
0xFFF8000000000000`, and the zero word fails it. So a rooted slot holding 0
|
||||||
|
decodes as the double `0.0` — an ordinary value rather than a marker, and
|
||||||
|
crucially never an address the collector dereferences. Zero is safe, and the
|
||||||
|
header's sentence is true for a reason both sides can check rather than by the
|
||||||
|
two of them having guessed alike. No sentinel is needed and neither side
|
||||||
|
changes.
|
||||||
|
|
||||||
|
## Not in milestone 1, each refused by name with a location
|
||||||
|
|
||||||
|
- a typed container boxing into dyn (`(Vec i64)` → dyn): "not yet"; the
|
||||||
|
heterogeneous container is the runtime's own from `(vec-new dyn)`
|
||||||
|
- a dyn in a condition's payload, or in a field of one: milestone 2 — a payload
|
||||||
|
crosses a handler boundary and must stay rooted across the transfer
|
||||||
|
- a dyn crossing to C through `declare`/`declare-c`: it is one word and would
|
||||||
|
have passed as an integer with nothing on the other side able to ask what it
|
||||||
|
means. This one was **not** in the brief and is the dangerous one, because the
|
||||||
|
general "cannot cross to C" arm would have caught it with advice (`pass (Ptr
|
||||||
|
T)`) that is wrong for dyn.
|
||||||
|
- integer widths other than i64 and floats other than f64 unboxing from dyn:
|
||||||
|
the ABI carries one of each, and a `need_i64` plus a truncation would put an
|
||||||
|
implicit narrowing at the one boundary where the value's type was already
|
||||||
|
uncertain
|
||||||
|
- ~~the x86 dev backend, and~~ the JS dialect, refuse dyn entirely. The x86
|
||||||
|
backend does not any more: a dyn is one machine word in both calling
|
||||||
|
conventions and every operation on one is an ordinary `Tast.Rt` call, so what
|
||||||
|
the lane cost was the root discipline and not the arithmetic — a zeroed frame
|
||||||
|
slot per dyn local and per dyn-producing call, pushed in the body buffer at
|
||||||
|
entry, and one `flan_dyn_root_pop` in the epilogue that every return and
|
||||||
|
every transfer out of the frame already went through. `Emit.dyn_roots` is
|
||||||
|
called by both backends, which is what makes the counts agree rather than
|
||||||
|
merely both being written down
|
||||||
|
|
||||||
|
## Roots: what is and is not verified
|
||||||
|
|
||||||
|
Every dyn slot and every dyn-producing runtime call is rooted, pushed in the
|
||||||
|
entry block and popped at every `ret` — which is the funnel all five exits pass
|
||||||
|
through, the transfer landing block included. Pushes and pops balance **by
|
||||||
|
construction**: `dyn_roots` counts before emission, the slots are minted from
|
||||||
|
that count, and `dyn_tmp` only hands them out.
|
||||||
|
|
||||||
|
**The stub verifies none of this.** `flan_dyn_stub.c` mallocs and never frees,
|
||||||
|
so a program with entirely wrong root discipline passes every test that runs
|
||||||
|
against it. What is checked instead is the IR, and that check earned its keep —
|
||||||
|
it found a real hole. A defer appears twice in the typed IR, spliced into `body`
|
||||||
|
for the normal path and again in `fdefers` for the path a transfer leaves
|
||||||
|
through, so a dyn temporary inside one is emitted twice; `dyn_roots` counted
|
||||||
|
only the body's, and the second copy went into slots the collector had never
|
||||||
|
been told about.
|
||||||
|
|
||||||
|
Nothing failed, which is the point. `dyn_tmp` falls back to a plain unrooted
|
||||||
|
slot rather than unbalancing the stack, so the pushes and the pops still
|
||||||
|
matched, the program ran and printed the right answer, and four dyn values were
|
||||||
|
simply invisible. Under a stub that never collects there is no symptom at all.
|
||||||
|
|
||||||
|
The assertion that caught it is in `test_acceptance.ml`: a rooted slot is
|
||||||
|
spelled `%dr` and the fallback `%dx`, and no dyn program in the corpus may emit
|
||||||
|
the latter. When the real collector lands, that is the check to extend rather
|
||||||
|
than replace — it is the only one that can see a missing root before there is a
|
||||||
|
collector to lose one by.
|
||||||
|
|
||||||
|
Cost: a rooted alloca has its address escape through `flan_dyn_root_push`, so
|
||||||
|
mem2reg cannot promote it. Every dyn local and every dyn temporary is a real
|
||||||
|
stack slot with a real store, at every optimisation level. That is inherent to a
|
||||||
|
precise collector with an address-registration ABI rather than stack maps.
|
||||||
|
|
||||||
|
A function with no dyn emits nothing — no push, no pop, not a `pop(0)` — which
|
||||||
|
is what makes `--no-gc` byte-identity hold.
|
||||||
@@ -0,0 +1,152 @@
|
|||||||
|
# The `test_emacs` flake — SIGPIPE, and a socket that outlived its process
|
||||||
|
|
||||||
|
**Closed.** It was neither of the two mechanisms this repository had seen
|
||||||
|
before. It was a third: `SIGPIPE`.
|
||||||
|
|
||||||
|
## The symptom
|
||||||
|
|
||||||
|
One run of `dune test --root .` exited 1; the next on the same tree exited 0.
|
||||||
|
|
||||||
|
```
|
||||||
|
FAIL the client notices a stop nobody asked about
|
||||||
|
FAIL and the modeline says so, with the condition
|
||||||
|
Error: error ("flan dev: cannot reconnect to /tmp/build_997a01_dune/flan-emacs-dev.sock: make client process failed: Connection refused, ...")
|
||||||
|
```
|
||||||
|
|
||||||
|
## Which mechanism it was
|
||||||
|
|
||||||
|
Neither of the two named in the brief.
|
||||||
|
|
||||||
|
- **Not a listen/connect ordering bug.** `bind` and `listen` are adjacent in
|
||||||
|
both `Dev.two_process` and `Dev.merged_setup`, nothing else creates that
|
||||||
|
path, and the connection that failed was one that had already been working
|
||||||
|
for forty checks.
|
||||||
|
- **Not a timeout too short for a cold build.** That failure mode is now
|
||||||
|
reproducible on demand (see *The tick budget* below) and it produces an
|
||||||
|
entirely different message.
|
||||||
|
- **It was `SIGPIPE`.** The daemon answers an editor by calling `Wire.send`,
|
||||||
|
which is `Unix.write_substring`. Nothing in the OCaml half of the daemon
|
||||||
|
ignored `SIGPIPE`, so a reply written into a socket whose reader had gone
|
||||||
|
killed the process outright. In the merged one-process build that process is
|
||||||
|
the program, the compiler and the listener at once — so the program died
|
||||||
|
without ever reporting a stop (the two `FAIL`s), and the socket file was left
|
||||||
|
on disk with nothing accepting on it (`Connection refused` on a path that
|
||||||
|
plainly exists). One event, all three lines.
|
||||||
|
|
||||||
|
It is not a contrived shape. `flan-dev--live-connection` reopens a dead
|
||||||
|
connection, Emacs tears the old process down when it does, and a reply
|
||||||
|
already on its way out lands in the gap. `flan_agent.c` had reached the same
|
||||||
|
conclusion from the other side years ago and passes `MSG_NOSIGNAL`; the half
|
||||||
|
written in OCaml never got the same treatment.
|
||||||
|
|
||||||
|
## How it was reproduced
|
||||||
|
|
||||||
|
A client that sends one request and closes before the reply arrives:
|
||||||
|
|
||||||
|
```
|
||||||
|
daemon DIED after 1 hit-and-run connections
|
||||||
|
daemon wait status: 141 (128+13=141 is SIGPIPE)
|
||||||
|
socket file left behind: YES
|
||||||
|
and a fresh client gets:
|
||||||
|
[Errno 111] Connection refused
|
||||||
|
```
|
||||||
|
|
||||||
|
That is the reported failure, exactly, in under a second and every time. With
|
||||||
|
the fix, 300 such connections leave the daemon serving.
|
||||||
|
|
||||||
|
The reproduction is now a check in `test_dev.ml`, in the robustness daemon's
|
||||||
|
block: eight hit-and-run connections, then a request proving the session is
|
||||||
|
still there and still knows what it installed. Against the parent of the fix it
|
||||||
|
fails with `killed by SIGPIPE`.
|
||||||
|
|
||||||
|
**Both transports, and only one of them has a test.** `ignore_sigpipe` is
|
||||||
|
called from two places and the suite's daemons are all merged, so the check
|
||||||
|
above covers `merged_setup` and nothing covers `two_process` — which NEXT.md
|
||||||
|
(now `TODO.org`) describes as the escape hatch for a machine that cannot build the compiler
|
||||||
|
object, so it is live code somewhere. Driven by hand: before the fix a
|
||||||
|
`--two-process` daemon dies on the *first* hit-and-run connection with status
|
||||||
|
141 and leaves its socket behind, exactly as the merged one does; after it,
|
||||||
|
a hundred of them leave it serving and answering `describe`. If that call site
|
||||||
|
is ever removed, nothing in `dune test` will say so.
|
||||||
|
|
||||||
|
## The fix
|
||||||
|
|
||||||
|
`lib/dev.ml`, three parts:
|
||||||
|
|
||||||
|
1. `ignore_sigpipe ()` where the listening socket is bound — in both
|
||||||
|
`two_process` and `merged_setup`. Ignored rather than handled, because
|
||||||
|
`serve` already treats a failed write as a closed connection.
|
||||||
|
2. The reply write is guarded. An `exception` case on a `match` covers the
|
||||||
|
*scrutinee*, not the branch body, so the `EPIPE` that ignoring the signal
|
||||||
|
produces went straight past the two handlers below it and out of the accept
|
||||||
|
loop — which ended the session just as surely, only quietly. Without this
|
||||||
|
the first fix converts `SIGPIPE` into `flan dev: Unix.Unix_error(EPIPE)` and
|
||||||
|
the daemon still stops.
|
||||||
|
3. The socket is unlinked on the ways out the daemon does not control as well
|
||||||
|
as the one it does: an `atexit` in the merged `main` for `exit(3)`, which is
|
||||||
|
what `flan_rt.c`'s `rt_die` takes on any runtime trap; by hand in
|
||||||
|
`flan_agent.c`'s `die_now`, and in `main`'s `_exit(rc)` fallback, both of
|
||||||
|
which skip the `atexit` chain deliberately. A stale socket can now only come
|
||||||
|
from a `SIGKILL`.
|
||||||
|
|
||||||
|
`emacs/flan-dev.el`: a refusal on a path that exists is reported as a leftover
|
||||||
|
socket rather than as `Connection refused`. The raw message is what sent two
|
||||||
|
investigations here the wrong way.
|
||||||
|
|
||||||
|
`test/test_emacs.ml` and `test/test_repl.ml`: the daemon's wait status is kept
|
||||||
|
instead of discarded, and the program's output is read *before* the temporary
|
||||||
|
files are removed rather than after. The old order deleted the evidence and
|
||||||
|
then printed the exit code — which is why nobody could tell, twice running,
|
||||||
|
whether the daemon had exited or been killed.
|
||||||
|
|
||||||
|
## The sibling call sites
|
||||||
|
|
||||||
|
Four files are in this family and the answer differs for each:
|
||||||
|
|
||||||
|
- `test_dev.ml` and `test_repl.ml` drive the same daemon, so `lib/dev.ml`'s fix
|
||||||
|
covers them. Neither had a separate copy of the bug.
|
||||||
|
- `test_cider.ml` has **no daemon and no running program** — it drives the
|
||||||
|
inspector and break buffer from fixtures. It is not in this family at all,
|
||||||
|
despite the name.
|
||||||
|
- `test_emacs.ml` was the only one whose harness destroyed the evidence before
|
||||||
|
reading the exit code; `test_repl.ml` had the same ordering and is fixed too.
|
||||||
|
|
||||||
|
So: one bug, one site, three harnesses — not the three-way split the last one
|
||||||
|
had.
|
||||||
|
|
||||||
|
## The tick budget — a second hazard, and not this one
|
||||||
|
|
||||||
|
`test/programs/dev-repl.flan` ran `(dotimes [i 4000] (agent/wait 5) ...)`: a
|
||||||
|
twenty-second program under a two-minute test, and `test_emacs` drives one
|
||||||
|
daemon through the whole run. On a loaded machine the client can still be
|
||||||
|
working when the program reaches its last tick.
|
||||||
|
|
||||||
|
This is real and it is reproducible — sweep the budget and the same two
|
||||||
|
break-loop checks fail at 165, 175 and 185 ticks — but it is **not** the flake
|
||||||
|
above, because it fails honestly: `the program exited; restart flan dev` at one
|
||||||
|
budget, `nothing is listening on ...` at another. Never `Connection refused`.
|
||||||
|
That is what ruled it out.
|
||||||
|
|
||||||
|
Raised to 24000, which is what `dev-robust.flan` already uses for the same
|
||||||
|
reason. The 600s watchdogs are what actually bound the run.
|
||||||
|
|
||||||
|
## Verification
|
||||||
|
|
||||||
|
- `dune test --root .` — three runs, 232 checks, 0 failures, exit 0 each time.
|
||||||
|
All three under sixteen busy loops; two of them alongside a running
|
||||||
|
`test/survey-x86.sh`.
|
||||||
|
- `test/survey-x86.sh` — 103 MATCH / 0 DIFFER / 0 REFUSED.
|
||||||
|
|
||||||
|
## Open questions for the author
|
||||||
|
|
||||||
|
- `lib/cimport.ml:1138` still spells its own `cachedir` under `$TMPDIR`, which
|
||||||
|
NEXT.md:694 (now `TODO.org`) flags as the last remnant of the cold-cache bug. Another lane
|
||||||
|
holds that file. Folding it onto `Build.cachedir` is still a one-line change.
|
||||||
|
- `Build.cachedir` is now under `XDG_CACHE_HOME`, which means it is **shared**
|
||||||
|
between concurrently running lanes rather than private per dune run. The
|
||||||
|
writes are `tmp`-then-`rename`, so nothing can read a half-written object,
|
||||||
|
and nothing in this investigation pointed at it. Noted only because "several
|
||||||
|
compiler lanes at once" is now a condition the suite is expected to survive.
|
||||||
|
- `runtime/flan_dev.c:51` reaches `abort()` on a full name table, and `abort`
|
||||||
|
runs neither the `atexit` chain nor anything else. It is a 4096-name limit
|
||||||
|
and no test comes near it, so it is left as it is.
|
||||||
@@ -0,0 +1,260 @@
|
|||||||
|
# Handoff — one buffer for every lowering
|
||||||
|
|
||||||
|
Branch `dev-loop`, worktree `agent-a9d4028fa5752ba39`, from `f772162`.
|
||||||
|
|
||||||
|
`tools/dump.sh` landed at `f772162` and prints four lowerings of one function side by side: the LLVM IR
|
||||||
|
the frontend emits, what `llc` makes of it at `-O0` and at `-O2`, and what the hand-written x86 backend emits.
|
||||||
|
Reading one against another is the only way to check a lowering by eye. A shell script that prints all four
|
||||||
|
into a scrollback is not how anyone reads them, though: three of the four are noise on any given day, and the
|
||||||
|
one that is not is the one you are elbow-deep in. So the same four go into an Emacs buffer with collapsible
|
||||||
|
sections, and the buffer remembers which of them you had open.
|
||||||
|
|
||||||
|
`M-x flan-lowering`, `C-c C-l` in `flan-mode`.
|
||||||
|
|
||||||
|
## The three decisions
|
||||||
|
|
||||||
|
### 1. It compiles the file; it does not ask the daemon
|
||||||
|
|
||||||
|
`flan-disassemble` (`C-c C-a`) asks the running program what the body it is calling for a name actually came
|
||||||
|
out as. This asks a different question — what does this source compile to, through four different lowerings —
|
||||||
|
and the two cannot be merged, for a concrete reason rather than a stylistic one: **the daemon has the
|
||||||
|
installed body's `.ll` and its `.so`, and neither `llc -O2` nor the hand-written backend has ever been run
|
||||||
|
over it.** There is no answer in the daemon to give. `llc -O2` on the installed IR would be a fifth thing,
|
||||||
|
built here and never run anywhere, and the backend's output for an installed body does not exist at all
|
||||||
|
unless the daemon was started `--x86`.
|
||||||
|
|
||||||
|
So the two commands sit beside each other and each says which question it answers. `flan-disassemble` keeps
|
||||||
|
its header, whose `showing` line is the daemon's own account of how much its answer claims. This buffer's
|
||||||
|
header says the opposite thing just as plainly: it names the file and the compiler flags, and says the
|
||||||
|
listing is what the source on disk compiles to and not what the program is running. Both docstrings
|
||||||
|
cross-reference the other.
|
||||||
|
|
||||||
|
### 2. `outline-minor-mode`, not `magit-section` and not overlays of my own
|
||||||
|
|
||||||
|
Nothing under `emacs/` requires a package that is not in Emacs — the whole client is `subr-x`, `seq`,
|
||||||
|
`pcase`, `cl-lib`, `xref`, `eldoc`, `comint`, `imenu` and its own files. Taking a dependency on Magit for a
|
||||||
|
four-section buffer would be the first, and it would be for folding, which Emacs has had since before Magit
|
||||||
|
existed.
|
||||||
|
|
||||||
|
`outline-minor-mode` on GNU Emacs 30.2.50 is the whole of what was asked for: `outline-cycle` is `TAB` on a
|
||||||
|
heading, `outline-hide-body` and `outline-show-all` collapse and expand everything, and
|
||||||
|
`outline-next-visible-heading` / `outline-previous-visible-heading` are `n` and `p`. Hand-rolling it would be
|
||||||
|
a hundred lines re-implementing that badly.
|
||||||
|
|
||||||
|
`outline-regexp` is `"[▸▾] "` — the fold arrow that starts each heading, and nothing else. That is not
|
||||||
|
decoration standing in for structure, it is the one anchor available: LLVM IR has `;` comments, assembler
|
||||||
|
output has `#` and `;` comments and lines that start with `.`, and `objdump` prints `<flan.step>:` label
|
||||||
|
lines, so a regexp loose enough to match four section headers written in ordinary characters also matches
|
||||||
|
inside three of the four bodies, and folding then fragments in the middle of a listing. Neither arrow can
|
||||||
|
begin a line of any of the three. `outline-search-function` would have done the same job keyed to a text
|
||||||
|
property, at the cost of a four-argument protocol to get exactly right; the arrow is simpler and it is also
|
||||||
|
the affordance, so it earns its place twice.
|
||||||
|
|
||||||
|
### 3. The open/closed state is a global alist keyed by section, and nothing else
|
||||||
|
|
||||||
|
One `defvar`, four entries, alive for the Emacs session and no longer. Not persisted to disk: it is four
|
||||||
|
booleans, a preference file for it would one day have to be migrated, and nobody has ever wanted yesterday's
|
||||||
|
fold state back.
|
||||||
|
|
||||||
|
Keyed to the **section**, not to the function. The workflow is "I am working on the backend today", which is
|
||||||
|
a fact about the section and holds across every function the author looks at while he is doing it. Keyed to
|
||||||
|
the function it would forget on every `M-x flan-lowering` of a different name, which is exactly the thing he
|
||||||
|
asked not to happen.
|
||||||
|
|
||||||
|
The alist is the single source of truth. A toggle mutates it and then applies it to the buffer; a refresh
|
||||||
|
applies it to the newly drawn buffer. Visibility is never read back out — that would couple this to whether
|
||||||
|
outline folds with overlays or with text properties, which is a thing that has changed between Emacs
|
||||||
|
versions and is none of this file's business.
|
||||||
|
|
||||||
|
## What was built
|
||||||
|
|
||||||
|
| file | what |
|
||||||
|
|---|---|
|
||||||
|
| `emacs/flan-lower.el` | the whole feature: the four fetches, the narrowing, the renderer, the folding and the memory of it |
|
||||||
|
| `emacs/flan-mode.el` | `C-c C-l` and the autoload |
|
||||||
|
| `emacs/test-flan-dev.el` | 30 checks, after the disassembly section |
|
||||||
|
| `emacs/MANUAL.md` | its own section, plus rows in both key tables, the settings table and the file table |
|
||||||
|
|
||||||
|
## The keymap
|
||||||
|
|
||||||
|
| Key | Command | Does |
|
||||||
|
|---|---|---|
|
||||||
|
| `TAB`, `RET`, `mouse-1` | `flan-lower-toggle` | open or close the section point is in |
|
||||||
|
| `S-TAB` | `flan-lower-cycle-all` | close everything, or open everything if it is all shut |
|
||||||
|
| `c` | `flan-lower-collapse-all` | close every section |
|
||||||
|
| `e` | `flan-lower-expand-all` | open every section |
|
||||||
|
| `n` / `p` | `outline-next-visible-heading` / `outline-previous-visible-heading` | between headings |
|
||||||
|
| `g` | `flan-lower-refresh` | compile again, redraw all four |
|
||||||
|
| `r` | `flan-lower-refresh-section` | compile and redraw only this one |
|
||||||
|
| `q` | `quit-window` | |
|
||||||
|
|
||||||
|
`n` and `p` are outline's own commands bound straight into the map, which is
|
||||||
|
the same thing they mean in `flan-inspect-mode` and `flan-cnr-mode`: move
|
||||||
|
between the buffer's own units. `special-mode` binds the digits and `-` to
|
||||||
|
`digit-argument` and `negative-argument`, so the collapse and expand keys are
|
||||||
|
letters rather than the `+`/`-` pair they would otherwise have been.
|
||||||
|
|
||||||
|
`r` exists because the four are not the same price. The IR is the frontend
|
||||||
|
alone; `llc -O2` over a whole program's worth of it is the one that is felt.
|
||||||
|
The intermediates live in a scratch directory per buffer, so refreshing one
|
||||||
|
section reuses the IR the other three were made from. Refreshing the IR drops
|
||||||
|
every intermediate, because everything is downstream of it and the next `r` on
|
||||||
|
another section must not answer out of a file the old IR produced. The
|
||||||
|
directory goes with the buffer, on `kill-buffer-hook`, and there is a check
|
||||||
|
for that -- four intermediates per invocation left in `/tmp` would add up.
|
||||||
|
|
||||||
|
## Two things worth knowing
|
||||||
|
|
||||||
|
**The narrowing is `dump.sh`'s awk, ported.** The IR runs from `define
|
||||||
|
...@"flan.NAME"(` to `}`; the two assembler sections from the `flan.NAME:`
|
||||||
|
label to the `.size` that ends it; the disassembly from `<flan.NAME>:` to the
|
||||||
|
blank line after it. All four keep their last line, which is what makes a
|
||||||
|
closing brace part of the listing rather than the start of the next one. The
|
||||||
|
name is the Flan one -- `step`, not `flan.step` -- and a packaged function is
|
||||||
|
written the way the program names it, `sim/settle`, which is why every pattern
|
||||||
|
allows for LLVM's quoting.
|
||||||
|
|
||||||
|
**A section's failure is that section's text, not the buffer's.** `llc` can be
|
||||||
|
missing while the IR is perfectly readable, and a buffer that refused
|
||||||
|
altogether would be the wrong answer to that. Each fetch is wrapped, and the
|
||||||
|
error message -- which is the tool's own stderr -- becomes the body.
|
||||||
|
|
||||||
|
## Testing
|
||||||
|
|
||||||
|
30 checks in `emacs/test-flan-dev.el`, immediately after the disassembly
|
||||||
|
section and needing no daemon, which is itself the distinction between the two
|
||||||
|
commands.
|
||||||
|
|
||||||
|
Twenty-two of them drive the renderer with `flan-lower-fetch-function` rebound
|
||||||
|
to canned text. That is deliberate: folding, and the memory of what was
|
||||||
|
folded, are renderer properties, and putting four compilers and an `llc -O2`
|
||||||
|
behind every redraw would have cost seconds per redraw and proved nothing
|
||||||
|
about folding. The real fetch is exercised once at the end, guarded on `llc`,
|
||||||
|
`as` and `objdump`, and that one costs about 2.2s plus one more `llc -O2` for
|
||||||
|
the `r` check.
|
||||||
|
|
||||||
|
`r` is checked where the real fetch already ran, because the claim it makes is
|
||||||
|
about files rather than about text: the IR's mtime is unchanged after one
|
||||||
|
section is refreshed, which is the only evidence available that the cache does
|
||||||
|
what it says — a re-emitted `out.ll` would have the same contents as the one
|
||||||
|
it replaced. `g` is checked twice: from inside a listing, where point comes
|
||||||
|
back to the same line *and the same text on it*, and from the header, where
|
||||||
|
there is no section to come back to and the answer has to be the top rather
|
||||||
|
than wherever the redraw finished.
|
||||||
|
|
||||||
|
`buffer-string` is useless for any of it, because it returns hidden text too:
|
||||||
|
"all four are still named when everything is shut" would pass without anything
|
||||||
|
being shut. Every visibility check is `invisible-p`, which means what it says
|
||||||
|
whether outline folded with an overlay or with a text property.
|
||||||
|
|
||||||
|
- `dune test --root .` exit 0, every suite green, `emacs: all tests passed`.
|
||||||
|
- `dune build --root . @page` and `@cells` both exit 0.
|
||||||
|
|
||||||
|
## Transcript
|
||||||
|
|
||||||
|
`emacs -Q --batch -L emacs -l try.el -- _build/default/bin/main.exe
|
||||||
|
test/programs/dev-repl.flan`, printing the buffer *as displayed* — invisible
|
||||||
|
characters dropped, so a folded section really is absent rather than merely
|
||||||
|
unprinted.
|
||||||
|
|
||||||
|
Opened on `step`, with the remembered default (the IR open):
|
||||||
|
|
||||||
|
```
|
||||||
|
== M-x flan-lowering step ==
|
||||||
|
; every lowering of step
|
||||||
|
; file ~/Development/flan/.claude/worktrees/agent-a9d4028fa5752ba39/test/programs/dev-repl.flan
|
||||||
|
; compiler /home/joe/Development/flan/.claude/worktrees/agent-a9d4028fa5752ba39/_build/default/bin/main.exe
|
||||||
|
; flags none
|
||||||
|
; showing what this file compiles to, not what a running program is
|
||||||
|
; calling for this name -- for that, C-c C-a
|
||||||
|
|
||||||
|
▾ LLVM IR 8 lines
|
||||||
|
define i64 @"flan.step"(ptr %xfer) {
|
||||||
|
entry:
|
||||||
|
%t1 = load i64, ptr @"flan.ticks"
|
||||||
|
%t2 = add i64 %t1, 1
|
||||||
|
store i64 %t2, ptr @"flan.ticks"
|
||||||
|
%t3 = load i64, ptr @"flan.ticks"
|
||||||
|
ret i64 %t3
|
||||||
|
}
|
||||||
|
|
||||||
|
▸ LLVM -O0 13 lines
|
||||||
|
▸ LLVM -O2 10 lines
|
||||||
|
▸ x86 backend 18 lines
|
||||||
|
```
|
||||||
|
|
||||||
|
`TAB` on the x86 heading, then `TAB` on the IR heading — the state the author
|
||||||
|
described, his own backend open and the other three shut:
|
||||||
|
|
||||||
|
```
|
||||||
|
== TAB on the x86 heading, TAB on the IR heading ==
|
||||||
|
; every lowering of step
|
||||||
|
; file ~/Development/flan/.claude/worktrees/agent-a9d4028fa5752ba39/test/programs/dev-repl.flan
|
||||||
|
; compiler /home/joe/Development/flan/.claude/worktrees/agent-a9d4028fa5752ba39/_build/default/bin/main.exe
|
||||||
|
; flags none
|
||||||
|
; showing what this file compiles to, not what a running program is
|
||||||
|
; calling for this name -- for that, C-c C-a
|
||||||
|
|
||||||
|
▸ LLVM IR 8 lines
|
||||||
|
▸ LLVM -O0 13 lines
|
||||||
|
▸ LLVM -O2 10 lines
|
||||||
|
▾ x86 backend 18 lines
|
||||||
|
0000000000012d94 <flan.step>:
|
||||||
|
12d94: push %rbp
|
||||||
|
12d95: mov %rsp,%rbp
|
||||||
|
...
|
||||||
|
```
|
||||||
|
|
||||||
|
The command run again on a *different* function. The preference is the
|
||||||
|
section's, so the backend is still the open one:
|
||||||
|
|
||||||
|
```
|
||||||
|
== M-x flan-lowering main -- a different function, same preference ==
|
||||||
|
; every lowering of main
|
||||||
|
; file ~/Development/flan/.claude/worktrees/agent-a9d4028fa5752ba39/test/programs/dev-repl.flan
|
||||||
|
; compiler /home/joe/Development/flan/.claude/worktrees/agent-a9d4028fa5752ba39/_build/default/bin/main.exe
|
||||||
|
; flags none
|
||||||
|
; showing what this file compiles to, not what a running program is
|
||||||
|
; calling for this name -- for that, C-c C-a
|
||||||
|
|
||||||
|
▸ LLVM IR 48 lines
|
||||||
|
▸ LLVM -O0 63 lines
|
||||||
|
▸ LLVM -O2 58 lines
|
||||||
|
▾ x86 backend 69 lines
|
||||||
|
0000000000012df4 <flan.main>:
|
||||||
|
12df4: push %rbp
|
||||||
|
```
|
||||||
|
|
||||||
|
`c`, then `e`, then `n`/`p`. Collapsed, all four are still named with their
|
||||||
|
line counts, which is the buffer as a summary:
|
||||||
|
|
||||||
|
```
|
||||||
|
== c, collapse all ==
|
||||||
|
; every lowering of main
|
||||||
|
; file ~/Development/flan/.claude/worktrees/agent-a9d4028fa5752ba39/test/programs/dev-repl.flan
|
||||||
|
; compiler /home/joe/Development/flan/.claude/worktrees/agent-a9d4028fa5752ba39/_build/default/bin/main.exe
|
||||||
|
; flags none
|
||||||
|
; showing what this file compiles to, not what a running program is
|
||||||
|
; calling for this name -- for that, C-c C-a
|
||||||
|
|
||||||
|
▸ LLVM IR 48 lines
|
||||||
|
▸ LLVM -O0 63 lines
|
||||||
|
▸ LLVM -O2 58 lines
|
||||||
|
▸ x86 backend 69 lines
|
||||||
|
== e, expand all, then n/p between headings ==
|
||||||
|
== e, expand all, then n/p between headings ==
|
||||||
|
n -> ▾ LLVM IR 48 lines
|
||||||
|
n n -> ▾ LLVM -O2 58 lines
|
||||||
|
p -> ▾ LLVM -O0 63 lines
|
||||||
|
|
||||||
|
```
|
||||||
|
|
||||||
|
## What is not here
|
||||||
|
|
||||||
|
- `C-c C-l` is not in `web/index.html`, so `web/examples/quotes.sh` does not
|
||||||
|
quote it. Its list of bindings is fixed and the page is a separate artefact;
|
||||||
|
adding a row there is a page change, not this one.
|
||||||
|
- A `desktop` or `savehist` story for the fold state, deliberately: it lives
|
||||||
|
for the Emacs session and no longer.
|
||||||
|
- The batch run leaves its scratch directory behind, because `emacs -batch`
|
||||||
|
exiting runs no `kill-buffer-hook`. Interactively the hook fires.
|
||||||
@@ -2,7 +2,7 @@
|
|||||||
|
|
||||||
Two examples, `text_codepoints_loading` and `textures_image_processing`, ported into
|
Two examples, `text_codepoints_loading` and `textures_image_processing`, ported into
|
||||||
`examples/`. This file is the running record: what is done, what was decided without being
|
`examples/`. This file is the running record: what is done, what was decided without being
|
||||||
able to ask, and what is still open. `PORTING.md` has the findings that outlive the port —
|
able to ask, and what is still open. `../PORTING.md` has the findings that outlive the port —
|
||||||
its last section, "Porting the raylib examples — the last two" — and this file has the
|
its last section, "Porting the raylib examples — the last two" — and this file has the
|
||||||
state of the work.
|
state of the work.
|
||||||
|
|
||||||
@@ -12,7 +12,7 @@ state of the work.
|
|||||||
- [x] `examples/textures-image-processing.flan` — builds
|
- [x] `examples/textures-image-processing.flan` — builds
|
||||||
- [x] `test/programs/raylib-codepoints.flan` and `test/programs/raylib-image-processing.flan`,
|
- [x] `test/programs/raylib-codepoints.flan` and `test/programs/raylib-image-processing.flan`,
|
||||||
both in the acceptance table, both gated on libraylib, both run plain and at `-O0`
|
both in the acceptance table, both gated on libraylib, both run plain and at `-O0`
|
||||||
- [x] `PORTING.md` section for this round
|
- [x] `../PORTING.md` section for this round
|
||||||
- [x] `dune test --root .` green
|
- [x] `dune test --root .` green
|
||||||
|
|
||||||
Four commits, each one a working state:
|
Four commits, each one a working state:
|
||||||
@@ -39,7 +39,7 @@ Four commits, each one a working state:
|
|||||||
reported", *"a `(Ptr T)` where the header says `T *` and the hand-written line chose
|
reported", *"a `(Ptr T)` where the header says `T *` and the hand-written line chose
|
||||||
something more specific"*. The function implements the enum-against-i32 arm and nothing
|
something more specific"*. The function implements the enum-against-i32 arm and nothing
|
||||||
else. That missing arm is the only thing standing between this round's two refused
|
else. That missing arm is the only thing standing between this round's two refused
|
||||||
bindings and ordinary binding work — see `PORTING.md` §A.1 and §A.2, which have the
|
bindings and ordinary binding work — see `../PORTING.md` §A.1 and §A.2, which have the
|
||||||
exact declarations and the exact error. **Not built: it is a compiler change and the
|
exact declarations and the exact error. **Not built: it is a compiler change and the
|
||||||
freeze is on.** It is small and it is well specified, and it is the thing to do first if
|
freeze is on.** It is small and it is well specified, and it is the thing to do first if
|
||||||
these two ports are ever revisited.
|
these two ports are ever revisited.
|
||||||
@@ -77,7 +77,7 @@ Four commits, each one a working state:
|
|||||||
`flan generate-c`. A hand-written `declare-c` that disagrees with `raylib-5.5.h` therefore
|
`flan generate-c`. A hand-written `declare-c` that disagrees with `raylib-5.5.h` therefore
|
||||||
breaks every build in the tree, not just regeneration. That is what makes open question 2
|
breaks every build in the tree, not just regeneration. That is what makes open question 2
|
||||||
a blocker rather than an inconvenience.
|
a blocker rather than an inconvenience.
|
||||||
- `(string (slice b off (len b)))` is the idiom for a C `char *` cursor into the middle of a
|
- `(string (slice b off (length b)))` is the idiom for a C `char *` cursor into the middle of a
|
||||||
string, and it costs nothing. It is correct for every entry point that reads forwards and
|
string, and it costs nothing. It is correct for every entry point that reads forwards and
|
||||||
wrong for every one that reads backwards.
|
wrong for every one that reads backwards.
|
||||||
- `slice-from-ptr` is how a raylib pointer-plus-count becomes something with a length. Both
|
- `slice-from-ptr` is how a raylib pointer-plus-count becomes something with a length. Both
|
||||||
@@ -0,0 +1,208 @@
|
|||||||
|
# The checks nobody runs
|
||||||
|
|
||||||
|
Twice now a script in this repository has been quietly wrong for weeks, and both
|
||||||
|
times it was found by accident rather than by anything failing. `test/survey-x86.sh`
|
||||||
|
had two programs refused by name for about a month. `web/examples/check.sh` had been
|
||||||
|
red since September 12th. This is the inventory of everything in the tree that
|
||||||
|
asserts something and is not reached by `dune test`, what each one says today, and
|
||||||
|
what was done about the general problem.
|
||||||
|
|
||||||
|
A third failure was indeed waiting. It is the interesting one, and it is not the
|
||||||
|
failure it looked like.
|
||||||
|
|
||||||
|
## The inventory
|
||||||
|
|
||||||
|
Everything executable or fixture-shaped outside `dune test`, run rather than assumed.
|
||||||
|
|
||||||
|
| What | Verifies | Run how | State |
|
||||||
|
|---|---|---|---|
|
||||||
|
| `web/examples/check.sh` | each `web/examples/*.flan` against the `.out` beside it, plus `flan shim` on shimdemo and a killed `--dev` build of breakdemo | now `@page` | **passes**, 21 checks |
|
||||||
|
| `web/examples/quotes.sh` | every block on `index.html` that is not a program — usage text, refusal messages, the LLVM excerpt, the renderer's output, the Emacs keys — re-derived and looked for on the page | now `@page` | **was red, 11 of 42**; fixed, now passes |
|
||||||
|
| `test/survey-x86.sh` | stdout, stderr and exit status of every corpus program, x86 backend against LLVM | `@x86`, and by hand | **passes**, 103 match / 0 differ / 0 refused / 38 skip |
|
||||||
|
| `test/cells.sh` | a `--dev` build really calls through its indirection cell: an `LD_PRELOAD`ed constructor stores a different body, four builds, `22 22` against `42 42` | nothing — now `@cells` | **passes**, 4 checks |
|
||||||
|
| `tools/colon-to-dot.py --check` | every `.flan` uses the dot spelling for field labels | nothing | **reports 20 hits, all false.** See below — this one is a hazard, not a check |
|
||||||
|
| `tools/unit-return.py --check` | every `defn` states a return type, `Unit` spelled `()` | nothing | **reports 30 hits, all false.** Same hazard |
|
||||||
|
| `emacs/test-flan-dape.el` | dape driving lldb-dap sets a breakpoint from a `.flan` buffer and reports Flan frames | nothing loads it | **cannot run here** — `require 'dape` fails, dape is not installed. Its own header says it is out of `dune test` on purpose |
|
||||||
|
| `emacs/test-flan-mode.el`, `test-flan-watch.el` | indentation shapes; the watch accumulator | loaded by `test-flan-cider.el` | covered by `dune test` |
|
||||||
|
| `spike/x86/bench.sh`, `cost.sh` | nothing — they measure and print tables | by hand | measurement, not checks |
|
||||||
|
| `spike/embed/run.sh`, `merged.sh`, `sig.sh`, `symbols.sh` | nothing — sizes, startup numbers, a symbol-collision report with no exit status | by hand | measurement, not checks |
|
||||||
|
| `spike/backend/run.sh`, `spike/generics/run.sh` | nothing — they drive a spike by hand | by hand | measurement, not checks |
|
||||||
|
|
||||||
|
Recorded-output fixtures: `find . -name '*.out'` outside `_build` returns twenty
|
||||||
|
files and all twenty are in `web/examples`. There is no second family of golden
|
||||||
|
files hiding anywhere.
|
||||||
|
|
||||||
|
## The red one, and why nobody saw it
|
||||||
|
|
||||||
|
`quotes.sh` failed eleven of its forty-odd checks, and the honest account is that
|
||||||
|
**nine of the eleven were the script's fault, not the page's**. This matters, because
|
||||||
|
the obvious move — "the page is stale, update the page" — would have been wrong nine
|
||||||
|
times out of eleven and would have rewritten correct prose.
|
||||||
|
|
||||||
|
**Three were an over-wide needle.** `result`, `quoted` and `i64index` compare a
|
||||||
|
compiler message against the page. The page has them, exactly. But `flan check` grew
|
||||||
|
a source excerpt with a caret under the offending form, and the script stuffed the
|
||||||
|
whole of the output into the needle, so it was comparing three lines against a page
|
||||||
|
that quotes one. The script now takes the message and nothing else.
|
||||||
|
|
||||||
|
**Six were probes for refusals that no longer happen.** `(Vec T)`, `(Map K V)`,
|
||||||
|
`(Handle T)`, an `(Fn …)` parameter, a `defer` inside a `let`, and `break` were each
|
||||||
|
refused as "not implemented yet" when this loop was written. All six work today. The
|
||||||
|
page's "Not implemented yet" table lost their rows as each one landed — correctly,
|
||||||
|
and `acda9ed` says so in its own message — but nobody went back to the probe list.
|
||||||
|
Those six were the last thing in the tree asserting a claim the page had already
|
||||||
|
stopped making, and they are deleted, with a comment saying what the list used to
|
||||||
|
cover so the next reader is not left guessing.
|
||||||
|
|
||||||
|
**And what kept this invisible is the part worth keeping.** `flan check` answers a
|
||||||
|
program that compiles with its entire symbol table. So each of those six probes
|
||||||
|
failed by printing eighty lines of prelude signatures into a report that was already
|
||||||
|
forty lines long. The author had built a guard against false greens — the empty-needle
|
||||||
|
case, with a comment calling it the one failure the script exists to catch — and the
|
||||||
|
rot arrived instead as a **two-hundred-line unreadable red**. A check whose output
|
||||||
|
nobody can read is a check nobody reads. A clean exit is now its own one-line failure:
|
||||||
|
`this program compiles now — the page still says it is refused`.
|
||||||
|
|
||||||
|
Two failures were genuine, and both were a document that had gone stale:
|
||||||
|
|
||||||
|
**`cell load`.** The page quotes an LLVM excerpt from `flan emit --dev`. A `--dev`
|
||||||
|
`main` now pushes a condition frame before anything else, which shifted the SSA
|
||||||
|
numbering by one, so the page's `%t1 = load ptr, ptr @"flan.cell.work"` is `%t2`
|
||||||
|
today. The three quoted lines are now what the compiler prints, with the frame push
|
||||||
|
marked as elided rather than silently dropped.
|
||||||
|
|
||||||
|
**`renderer`, which is the September 12th failure again and was still there.** The
|
||||||
|
check greps `NEXT.md` (now `TODO.org`) for a line of inspector output. `NEXT.md` is a rolling scratch
|
||||||
|
document; the line was rewritten out of it, the grep went empty, the empty-needle
|
||||||
|
guard fired and said "whatever this quotes has moved" — into a report nobody was
|
||||||
|
reading. Behind that noise the page was genuinely wrong in exactly the way `check.sh`
|
||||||
|
was wrong two days ago: the colon-to-dot sweep rewrote every field label in the
|
||||||
|
corpus, `lib/render.ml` writes `.field` today and `test_repl.ml`'s fixtures are dots
|
||||||
|
throughout, and the page had been showing `(V {:x 1.5 :y 0})` for a renderer that
|
||||||
|
prints `(V {.x 1.5 .y 0})`. The page is corrected; so is the identical block in
|
||||||
|
`docs/BUILT.md`, which nothing checks and which had drifted the same way. The check's
|
||||||
|
anchor moves from `NEXT.md` (now `TODO.org`) to `test/programs/raylib-imported.flan`, which `dune test`
|
||||||
|
builds and runs, so it cannot quietly stop saying it.
|
||||||
|
|
||||||
|
The design lesson is one line: **an anchor in a rolling document is not an anchor.**
|
||||||
|
|
||||||
|
## The hazard in `tools/`
|
||||||
|
|
||||||
|
This is not a rotted check, it is worse, and it deserves its own paragraph.
|
||||||
|
|
||||||
|
`tools/colon-to-dot.py` advertises itself as re-runnable — "converting an already-
|
||||||
|
converted file is a no-op, so this can be run again over files a parallel branch
|
||||||
|
wrote in the old spelling". Run `--check` today and it reports twenty field labels to
|
||||||
|
convert across six files. Every one of them is `{:where (copyable? $t)}`, the generic
|
||||||
|
constraint clause, which is not a struct literal and names no field. The generics lane
|
||||||
|
introduced a brace form the tool has never heard of. **Running that tool for real
|
||||||
|
would corrupt `test/programs/generics.flan`, `reload-generic.flan`,
|
||||||
|
`generic-map-reject.flan`, `generic-runaway.flan`, `spike/generics/prelude-shapes.flan`
|
||||||
|
and `syntax-sketch.flan`.**
|
||||||
|
|
||||||
|
`tools/unit-return.py` has the same shape of fault. It decides whether a `defn`
|
||||||
|
already states a return type by transcribing the old `parse.ml`, and that
|
||||||
|
transcription knows the prelude's types and the builtins but not a type that arrived
|
||||||
|
through `declare-c`. So it reads `(defn v2-add [a Vector2 b Vector2] Vector2 …)` as a
|
||||||
|
function with no return type and would insert `()` in front of sixteen correct
|
||||||
|
signatures in `vendor/raylib/vector.flan`.
|
||||||
|
|
||||||
|
Neither is wired to an alias and neither should be. They are finished one-shot
|
||||||
|
migrations whose `--check` mode now reports noise, and the safe move is to delete them
|
||||||
|
or to put a line at the top of each saying they are historical and must not be re-run
|
||||||
|
without being taught `{:where}` and imported type names first. **That is the author's
|
||||||
|
call and nothing here touched them beyond reading.** It is flagged because a
|
||||||
|
destructive script sitting in `tools/` looking maintained is a worse trap than a red
|
||||||
|
test.
|
||||||
|
|
||||||
|
## What got wired
|
||||||
|
|
||||||
|
Three stanzas in `test/dune`, in the shape `@x86` established — a `rule` with an
|
||||||
|
alias rather than a `test`, because a test stanza attaches to `@runtest` and offers no
|
||||||
|
way to be attached to anything else, and with `FLAN` passed in because a script that
|
||||||
|
shells out to `dune` from inside a dune action waits on a lock it cannot get.
|
||||||
|
|
||||||
|
**`@page`** runs `check.sh` then `quotes.sh`. 42 checks, eleven seconds, five of which
|
||||||
|
is breakdemo's deliberate `timeout 5`. Its comment gives a *different* reason for being
|
||||||
|
opt-in than its three neighbours do, and the difference is the point: `@sanitize`,
|
||||||
|
`@valgrind` and `@x86` are opt-in because they are slow, and this one is not slow. It
|
||||||
|
is separate because of what a failure means. These two fail when a **document** has
|
||||||
|
gone stale, not when the compiler has regressed, and a suite that goes red because
|
||||||
|
prose drifted teaches whoever runs it to skim past red. `dune test` should mean "the
|
||||||
|
language broke". `@page` should mean "the page is lying".
|
||||||
|
|
||||||
|
**`@cells`** runs `test/cells.sh`, which was a real four-check pass/fail script
|
||||||
|
that nothing in the tree ran. It is not folded into `@x86` because it asks a different
|
||||||
|
question: the survey asks whether the backend agrees with LLVM about what a program
|
||||||
|
prints, and no program can answer this one, because a dev build starts with every cell
|
||||||
|
already pointing at the body this build compiled.
|
||||||
|
|
||||||
|
**`@checks`** is `@page`, `@x86` and `@cells` in one word.
|
||||||
|
|
||||||
|
All three scripts learned to resolve `FLAN` to an absolute path, which turned out to
|
||||||
|
be the only thing actually standing between them and a dune rule: `%{workspace_root}`
|
||||||
|
expands relative to the directory the rule is written in, and every one of these
|
||||||
|
scripts `cd`s somewhere before using it.
|
||||||
|
|
||||||
|
## Item 3: what would genuinely have caught these
|
||||||
|
|
||||||
|
The honest answer first. **There is no local mechanism with teeth, and `@checks` is
|
||||||
|
not one.** It is discoverability, not enforcement. An alias nobody types is no better
|
||||||
|
than a script nobody types; it only looks more responsible. What the umbrella buys is
|
||||||
|
that *deciding to check* and *checking everything* become the same act, so the gap
|
||||||
|
between "somebody wondered" and "everything was verified" is one command instead of
|
||||||
|
five — and five names to remember is four too many, paid every time, by whoever is
|
||||||
|
least likely to know they exist. It shortens the gap. It does not close it.
|
||||||
|
|
||||||
|
**The recommendation is `@checks` plus a written convention, and nothing else.**
|
||||||
|
`README.md` now has a "Checking it" section giving the four commands, saying which
|
||||||
|
means what, and saying plainly that nothing runs `@checks` for you. The convention it
|
||||||
|
proposes is that a lane's handoff quotes `@checks`, the way the x86 handoffs already
|
||||||
|
quote the survey's counts — which is a habit this repository demonstrably already has,
|
||||||
|
and habits that already exist are the only ones worth adding a rule to.
|
||||||
|
|
||||||
|
**Against a git hook, which is the tempting answer.** `@checks` is a couple of minutes,
|
||||||
|
nearly all of it `@x86` building every program twice. A pre-commit hook costing two
|
||||||
|
minutes gets switched off within a week, and a disabled hook is strictly worse than no
|
||||||
|
hook because it reads as coverage. A pre-push hook is cheaper in principle, because
|
||||||
|
pushing is rare — but the remote is not reachable from here and this repository's work
|
||||||
|
is merged between local worktrees, so there is no push to hang it on. There is no
|
||||||
|
`.git/hooks` content and no `core.hooksPath` today; that is a reasonable state and it
|
||||||
|
was left alone.
|
||||||
|
|
||||||
|
**What would actually have caught both failures within a day** is CI on every push,
|
||||||
|
and this repository has none. That is the real answer and it should not be dressed up.
|
||||||
|
The failure mode being defended against is not "somebody ran the check and ignored the
|
||||||
|
result" — it is "a month passed and nobody ran anything" — and only a machine that
|
||||||
|
runs without being asked fixes that.
|
||||||
|
|
||||||
|
**One thing deliberately not done, because it is the author's call.** `@page` is eleven
|
||||||
|
seconds against `dune test`'s forty-eight, and five of those eleven are a fixed sleep.
|
||||||
|
That is a quarter again on top of the suite — not free, but not the reason it is out
|
||||||
|
either — and putting it in the suite is the one move that would give it actual teeth. The argument against is the one in its comment —
|
||||||
|
that mixing "the page is lying" into "the language broke" devalues both — and that is
|
||||||
|
a judgement about what a red suite should mean, not a measurement. The number is here
|
||||||
|
so the decision can be made on it rather than on an assumption.
|
||||||
|
|
||||||
|
## Verification
|
||||||
|
|
||||||
|
- `dune test --root .` — 232 checks, 0 failures, 47s. Unchanged: nothing was added to
|
||||||
|
the default suite.
|
||||||
|
- `dune build --root . @x86` — passes. 103 match, 0 differ, 0 refused, 38 skip.
|
||||||
|
- `dune build --root . @page` — passes, 42 checks. Verified both ways:
|
||||||
|
`web/examples/hello.out` was temporarily rewritten to say `goodbye world`, the build
|
||||||
|
went red with a readable diff and exit 1, and the break was reverted. The tree is
|
||||||
|
clean.
|
||||||
|
- `dune build --root . @cells` — passes, 4 checks.
|
||||||
|
|
||||||
|
## Loose ends for the author
|
||||||
|
|
||||||
|
- The two scripts in `tools/` described above. They are live hazards and the fix is a
|
||||||
|
decision, not a patch.
|
||||||
|
- `emacs/test-flan-dape.el` cannot run on this machine and nothing loads it. It is the
|
||||||
|
one check in the inventory whose state is genuinely unknown.
|
||||||
|
- Three commits — `8bd5547`, `64e4f6c`, `0251cf4` — were on this worktree's branch and
|
||||||
|
were dropped by the reset to `dev-loop` that this lane was told to perform. They are
|
||||||
|
your own unmerged edits to `web/index.html`, `plan.org`, `NEXT.md` (now `TODO.org`)
|
||||||
|
and `lib/build.ml`,
|
||||||
|
they are unrelated to anything here, and they are still reachable by hash.
|
||||||
@@ -0,0 +1,130 @@
|
|||||||
|
# Tidying the repository root
|
||||||
|
|
||||||
|
A note from later: `FIX.org`, `NEXT.md`, `DISCUSS.org`, `docs/DISCUSS.md` and
|
||||||
|
the root `HANDOFF.md` have since been merged into `TODO.org` at the root, with
|
||||||
|
the reasoning that would not compress into `docs/BUILT.md`. This report is the
|
||||||
|
record of a session that moved those files around while they existed, so it
|
||||||
|
keeps naming them — including inside the grep patterns it ran. Read every
|
||||||
|
mention of them below as past tense.
|
||||||
|
|
||||||
|
The root had thirty-odd files in it, nine of them session reports sitting at the
|
||||||
|
same level as the language specification, and a README is about to point a
|
||||||
|
newcomer at that. This is the plan and, below it, what actually happened.
|
||||||
|
|
||||||
|
## The plan
|
||||||
|
|
||||||
|
1. `git mv` the nine `HANDOFF-*.md` into `docs/handoffs/`, and `../DISCUSS.md`
|
||||||
|
(since deleted — its decisions are in `TODO.org`, its reasoning in `docs/BUILT.md`),
|
||||||
|
`../BUILT.md`, `../PORTING.md`, `../SPIKE-GENERICS.md`, `../REFERENCES.md` and
|
||||||
|
`../overview.md` into `docs/`. These are written once and read occasionally.
|
||||||
|
2. Leave `plan.org`, `spec-memory.md`, `spec-conditions.md`, `NEXT.md` (now
|
||||||
|
`TODO.org`), the
|
||||||
|
`.flan` scratch programs and the build files where they are: they are cited
|
||||||
|
by bare filename from source comments in dozens of places, and moving them
|
||||||
|
would be a large rewrite for no gain.
|
||||||
|
3. Rewrite every citation of a moved file, zone by zone — a flat substitution is
|
||||||
|
wrong, because a citation inside `docs/` should stay bare while the same
|
||||||
|
citation in `lib/` needs the `docs/` prefix.
|
||||||
|
4. Verify by resolving, not by grepping: for every cited path in the repository,
|
||||||
|
check it exists relative to the citing file or to the root.
|
||||||
|
5. Write `docs/README.md` saying which of these documents are still true.
|
||||||
|
|
||||||
|
## What happened
|
||||||
|
|
||||||
|
**The moves.** Fifteen files, all with `git mv` so `git log --follow` still
|
||||||
|
reaches their history. Nothing else moved.
|
||||||
|
|
||||||
|
**The citations.** 238 of them across 52 files, rewritten by zone. The zones
|
||||||
|
matter and a repository-wide substitution would have corrupted two of them:
|
||||||
|
|
||||||
|
| Citing file lives in | `DISCUSS.md` and its siblings | `HANDOFF-*.md` |
|
||||||
|
|---|---|---|
|
||||||
|
| the root, `lib/`, `test/`, `emacs/`, `spike/`, `examples/`, `vendor/` | `docs/DISCUSS.md` | `docs/handoffs/HANDOFF-x.md` |
|
||||||
|
| `docs/` | unchanged — they are siblings | `handoffs/HANDOFF-x.md` |
|
||||||
|
| `docs/handoffs/` | `../DISCUSS.md` | unchanged — siblings again |
|
||||||
|
|
||||||
|
(The file named in the middle column has since been deleted: its decisions live in
|
||||||
|
`TODO.org` and its reasoning in `docs/BUILT.md`. The names in this table are left as
|
||||||
|
this session wrote them.)
|
||||||
|
|
||||||
|
Most of the citations are prose inside a source comment rather than a link;
|
||||||
|
there is not a single markdown link among the fifteen moved documents. So the
|
||||||
|
rewrite is a rewrite of comments, and in `lib/x86.ml`, `lib/build.ml` and
|
||||||
|
`test/test_reload.ml` — which another lane is editing at the same time — every
|
||||||
|
touched line is a comment line.
|
||||||
|
|
||||||
|
**The verification.** Grep cannot tell you a rewrite is finished, because a grep
|
||||||
|
for `DISCUSS.md` matches `docs/DISCUSS.md` too. So the check resolves instead:
|
||||||
|
every path-shaped citation in the repository is looked up relative to the file
|
||||||
|
that wrote it and relative to the root, and anything that resolves to neither is
|
||||||
|
reported. 817 citations checked. The only failures are seven mentions of
|
||||||
|
`HANDOFF-f1.md`, `HANDOFF-f2.md` and `HANDOFF-f3.md` in `../../NEXT.md` (now
|
||||||
|
`TODO.org`), which were
|
||||||
|
already dangling before this work — the prose around each one says the file was
|
||||||
|
deleted — and one false positive where the pattern caught `"$root/NEXT.md"` out
|
||||||
|
of a shell variable.
|
||||||
|
|
||||||
|
### The judgement calls
|
||||||
|
|
||||||
|
**`MY-NOTES.org` and `conditions.org` stay at the root.** `MY-NOTES.org` is the
|
||||||
|
author's scratch — questions to himself about the standard library, in the
|
||||||
|
second person. `conditions.org` is a live cheatsheet, not a report, and it is
|
||||||
|
the entry point to `conditions-play.flan` beside it. Neither is a document that
|
||||||
|
belongs in a directory of finished reports, and personal files are best left
|
||||||
|
where their owner put them.
|
||||||
|
|
||||||
|
**`conditions-play.flan` stays at the root.** The brief said to move it to
|
||||||
|
`spike/` if nothing referenced it. Three things do: `conditions.org:5` tells the
|
||||||
|
reader to run it, `NEXT.md:1306` (now `TODO.org`) lists it as the program to poke conditions
|
||||||
|
with, and `.gitignore` has an anchored `/conditions-play` for the executable it
|
||||||
|
builds to. It is also not shaped like the rest of `spike/`, which is four
|
||||||
|
self-contained experiment directories with their own runners, not a home for a
|
||||||
|
loose `.flan` file. It is a demonstration that belongs next to the cheatsheet
|
||||||
|
that points at it.
|
||||||
|
|
||||||
|
**`.flan-dev.sock` is not in this worktree.** The stale one is in the author's
|
||||||
|
main checkout, which a worktree-isolated lane cannot reach. The ignore pattern
|
||||||
|
is added here so the next one never shows up in `git status`; the existing
|
||||||
|
socket is the author's to remove.
|
||||||
|
|
||||||
|
**`.gitignore`.** Five entries at the bottom of the file — `.claude/`, `probe`,
|
||||||
|
`probe.c`, `/forms.so`, `_hist/` — were uncommented stragglers in a file where
|
||||||
|
everything else explains itself. They are grouped and explained now, and
|
||||||
|
`.flan-dev.sock` is added. No pattern was removed or changed in meaning.
|
||||||
|
|
||||||
|
### Verification
|
||||||
|
|
||||||
|
- `dune build --root .` exits 0.
|
||||||
|
- `dune test --root . --force` reports 232 checks, 0 failures.
|
||||||
|
- `test/survey-x86.sh`, run detached, reports 103 MATCH, 0 DIFFER, 0 REFUSED,
|
||||||
|
0 NOX86 and 38 SKIP — the baseline, unchanged.
|
||||||
|
|
||||||
|
The resolver reports sixteen unresolved citations and all sixteen are expected.
|
||||||
|
Seven are the deleted `HANDOFF-f1.md`, `HANDOFF-f2.md` and `HANDOFF-f3.md` in
|
||||||
|
`../../NEXT.md`, which the prose around them already calls deleted. One is a
|
||||||
|
false positive where the pattern caught `"$root/NEXT.md"` out of a shell
|
||||||
|
variable in `web/examples/quotes.sh`. The other eight are in this file: the
|
||||||
|
`HANDOFF-x.md` placeholders in the zone table above, and `DISCUSS.md` quoted
|
||||||
|
bare to explain why a grep cannot verify this work. None of them is a path.
|
||||||
|
|
||||||
|
### The branch clutter — reported, not acted on
|
||||||
|
|
||||||
|
`git branch --list 'worktree-agent-*'` returns **113** branches. **111** are
|
||||||
|
fully merged into `dev-loop`. **89** of them have a worktree currently
|
||||||
|
registered under `.claude/worktrees/`, and deleting one of those would break the
|
||||||
|
harness. The two unmerged branches are the two lanes running right now.
|
||||||
|
|
||||||
|
That leaves **24** branches that are both merged and have no live worktree, and
|
||||||
|
those are the only ones safe to delete:
|
||||||
|
|
||||||
|
```sh
|
||||||
|
comm -23 \
|
||||||
|
<(git branch --merged dev-loop --format='%(refname:short)' --list 'worktree-agent-*' | sort) \
|
||||||
|
<(git worktree list --porcelain | sed -n 's|^branch refs/heads/||p' | sort) \
|
||||||
|
| xargs -r git branch -d
|
||||||
|
```
|
||||||
|
|
||||||
|
`git branch -d` rather than `-D` on purpose: it refuses anything that turns out
|
||||||
|
not to be merged after all. The 89 with live worktrees want
|
||||||
|
`git worktree prune` and a decision about the directories first, which is the
|
||||||
|
author's call and not a cleanup to run blind.
|
||||||
@@ -0,0 +1,179 @@
|
|||||||
|
# Handoff — the ABI marker symbol, so a crossed pair is refused at dlopen
|
||||||
|
|
||||||
|
Branch `dev-loop`, from `682cb74`. This closes the serious finding of `HANDOFF-x86-aggregates.md`: a
|
||||||
|
redefinition module built by one backend, dlopened into a host built by the other, links and loads and then
|
||||||
|
dies with SIGSEGV at the first call into a redefined function that takes or returns a struct. Nothing refused
|
||||||
|
it, and `flan build game.flan --x86 --dev` followed by `flan reload game.flan changed.flan` builds exactly that
|
||||||
|
pair.
|
||||||
|
|
||||||
|
**It is refused now, by the loader, before any of the new code runs, with a sentence that says why.** Both
|
||||||
|
directions are in `dune test`.
|
||||||
|
|
||||||
|
## What was built
|
||||||
|
|
||||||
|
| file | what |
|
||||||
|
|---|---|
|
||||||
|
| `lib/x86.ml` | `abi_marker = "flan.abi.x86"`. `program` defines it in `.data`, in a dev build only; `redefinition` emits a `.quad` against it |
|
||||||
|
| `lib/emit.ml` | `abi_marker = "flan.abi.llvm"`, the same two halves — a definition inside `program`'s existing `if dev` block, and an `external` plus a hidden pointer to it in `redefinition`'s |
|
||||||
|
| `vendor/agent/flan_agent.c` | `abi_mismatch`, which turns a `flan.abi.` `dlopen` failure into a sentence; the reload handler uses it |
|
||||||
|
| `test/reload_host.c` | the same function, duplicated rather than shared, and the same use at its `dlopen` |
|
||||||
|
| `test/test_reload.ml` | `agg_cross`, run both ways, asserting a nonzero exit *and* the sentence *and* which marker was missing |
|
||||||
|
|
||||||
|
`lib/build.ml` was not touched. Its option-record guard is the other half of this answer and is unchanged; the
|
||||||
|
comment there already says what it cannot catch, which is what the marker is for.
|
||||||
|
|
||||||
|
## The mechanism, and why it is a datum and not a call
|
||||||
|
|
||||||
|
A dev build defines a marker symbol naming the backend that built it. A redefinition module emits a
|
||||||
|
pointer-sized datum holding the address of the marker it was itself built for.
|
||||||
|
|
||||||
|
That datum is the whole of it. A pointer in `.data` is a relocation the dynamic loader has to resolve while it
|
||||||
|
maps the object, whatever it does about lazy binding of calls, so a host that does not define the marker fails
|
||||||
|
the `dlopen` outright. A call into an absent function would do as well under `RTLD_NOW`, which is what both
|
||||||
|
loaders in this repo pass, but the datum does not depend on that and costs eight bytes.
|
||||||
|
|
||||||
|
Both sides are gated on `dev`, for two reasons that happen to agree. A release build has no cells and nothing
|
||||||
|
to load into one, so the marker would be dead weight; and `Build.executable` passes `-rdynamic` only for a dev
|
||||||
|
build, so a release build could not export the symbol even if it emitted it. Gating also keeps a release
|
||||||
|
build's output byte-for-byte what it was, which `x86.ml`'s `.Ldwtext` comment says the repo cares about.
|
||||||
|
Measured on `test/programs/cleanup.flan`:
|
||||||
|
|
||||||
|
```
|
||||||
|
x86 --dev : 00000000004280f0 D flan.abi.x86
|
||||||
|
llvm --dev : 000000000041d3f0 B flan.abi.llvm
|
||||||
|
x86 release : (nothing)
|
||||||
|
```
|
||||||
|
|
||||||
|
Macro modules are unaffected and were checked: `Build.macro_module` calls `Emit.program` without `~dev`, so a
|
||||||
|
macro module neither defines a marker nor requires one, and the OCaml-side `dlopen` in `lib/dynload_stubs.c` —
|
||||||
|
which is the *only* other `dlopen` of a Flan-built object anywhere — never sees one. It therefore got no arm,
|
||||||
|
deliberately.
|
||||||
|
|
||||||
|
`lib/dev.ml` got no arm either, and this is worth stating because it looks like an omission. The daemon builds
|
||||||
|
the host itself and sends every module to the agent in the game process; it has no `dlopen` of a redefinition
|
||||||
|
module of its own, and `--x86` has no spelling anywhere in `dev.ml` or `session.ml`, so a `flan dev` session
|
||||||
|
builds host and modules both through LLVM and is matched by construction. The mismatch is only reachable
|
||||||
|
through `flan build --x86 --dev` plus a separately built module, and that module is loaded by the agent, which
|
||||||
|
is where the sentence lives.
|
||||||
|
|
||||||
|
## What the crossed pair does now
|
||||||
|
|
||||||
|
Verbatim, from the two new cases in `test/test_reload.ml`, captured from the host's stderr:
|
||||||
|
|
||||||
|
```
|
||||||
|
flan: the module and this host were built by different backends: the module came from LLVM and needs
|
||||||
|
flan.abi.llvm, which an --x86 host does not define. The two backends pass every struct differently. Rebuild
|
||||||
|
the host without --x86.
|
||||||
|
```
|
||||||
|
|
||||||
|
```
|
||||||
|
flan: the module and this host were built by different backends: the module came from the x86 dev backend and
|
||||||
|
needs flan.abi.x86, which this host does not define. The two backends pass every struct differently. Rebuild
|
||||||
|
the host with --x86.
|
||||||
|
```
|
||||||
|
|
||||||
|
Exit 1 in both cases, from the host refusing to install. Before this it was exit 139 — SIGSEGV, at a call site,
|
||||||
|
after `a1` and `host 54063108` had already been printed.
|
||||||
|
|
||||||
|
The agent's wording is longer than the test host's, because its reader is a person in an editor rather than a
|
||||||
|
test: it names the running program rather than "this host", says the pair would die at the first call into a
|
||||||
|
redefined function taking or returning a struct, and — in the LLVM-module direction — says why the program is
|
||||||
|
the half that has to move.
|
||||||
|
|
||||||
|
The agent's two sentences have no unit test of their own, so they were checked the one way that matters: that
|
||||||
|
they are in a binary a user would actually run. `vendor/agent/flan_agent.c` reaches a program through the
|
||||||
|
vendor package's C sources rather than through an embedded-as-a-string module like `Runtime_src`, so an edit to
|
||||||
|
it lands without regenerating anything — but that had to be confirmed rather than assumed, because a repo that
|
||||||
|
embeds one C file that way can embed another.
|
||||||
|
|
||||||
|
```
|
||||||
|
flan build test/programs/agent.flan --dev -o ahost ; strings ahost | grep -c "built by different backends" → 2
|
||||||
|
flan build test/programs/agent.flan --x86 --dev -o ahost ; strings ahost | grep -c "built by different backends" → 2
|
||||||
|
```
|
||||||
|
|
||||||
|
Two, in both configurations: one sentence per direction.
|
||||||
|
|
||||||
|
Two things about the matching that are deliberate. It matches on the *marker's name*, not on `"undefined
|
||||||
|
symbol"`, which is glibc's phrasing and glibc's to change. And `dlerror` is one-shot with a buffer the next
|
||||||
|
`dl` call may clobber, so the pointer is taken once and used for both the test and the reply; the agent's
|
||||||
|
existing code called it once and still does.
|
||||||
|
|
||||||
|
## Why it is in `dune test` now, when the segfault was not
|
||||||
|
|
||||||
|
The aggregate lane measured the crossed pair and deliberately left it out: it was undefined behaviour, what it
|
||||||
|
printed was a property of whichever LLVM was installed, and a test pinning it would have been pinning the shape
|
||||||
|
of a crash. That is no longer true. The refusal happens in the loader, at a fixed point, before a single
|
||||||
|
instruction of the new body runs, so it is deterministic and is asserted the way the retyped-global and
|
||||||
|
registry-overflow cases already were: on the exit status *and* on the message.
|
||||||
|
|
||||||
|
Both directions, because a marker only one backend emitted would refuse in one direction and say nothing in the
|
||||||
|
other — and the direction with no test is the direction that quietly stops working.
|
||||||
|
|
||||||
|
The matched pairs are unchanged and still print the transcript the aggregate lane derived:
|
||||||
|
|
||||||
|
```
|
||||||
|
a1 / host 54063108 / a1 / after1 54063108 / a2 / after2 104337044 / counter 12
|
||||||
|
```
|
||||||
|
|
||||||
|
from `Emit.redefinition` + `Build.shared` and from `X86.redefinition` + `Build.shared_x86` alike.
|
||||||
|
|
||||||
|
And "a matched pair is unaffected" is checked through the agent as well as through `reload_host.c`, which is
|
||||||
|
worth saying because the two are different code paths and only one of them is what a user meets. The daemon
|
||||||
|
tests in `dune test` — `dev-globals`, `dev-repl`, `dev-watch`, `dev-pause`, `dev-loop` — start a real `flan
|
||||||
|
dev` session, build a real host, and send real redefinition modules to the agent in it over the socket. Every
|
||||||
|
one of those `dlopen`s now has to resolve `flan.abi.llvm`, and every one of those tests passes.
|
||||||
|
|
||||||
|
## `flan reload --x86` did not land, and should not have
|
||||||
|
|
||||||
|
The brief left this to judgement. It is item 3 of `HANDOFF-x86-redef.md`, not a flag.
|
||||||
|
|
||||||
|
`flan reload` does not build a module directly; it runs a `Session` over the program and asks
|
||||||
|
`Session.eval` for one, and `Session.change` holds a single `ir : string` field filled by
|
||||||
|
`Emit.redefinition ~consts`. Three things would have to move together:
|
||||||
|
|
||||||
|
- `Session.change` would need a backend-tagged payload rather than an `ir` string, and every one of the six
|
||||||
|
`Emit.redefinition` call sites in `session.ml` would have to choose.
|
||||||
|
- `X86.redefinition` raises `Unsupported` on `~consts`, on `~call`, and on any name the host was not built
|
||||||
|
with. `Session.eval` passes `~consts` as a matter of course and the expression path passes `~call`. So the
|
||||||
|
x86 path would refuse most of what a session legitimately sends, and the refusals would surface as "this
|
||||||
|
works in LLVM and not in x86" rather than as anything a user could act on.
|
||||||
|
- The daemon is the real caller of all of this. Giving `flan reload` a flag the daemon does not have would
|
||||||
|
leave the two commands disagreeing about what a session can do.
|
||||||
|
|
||||||
|
So the deliverable here is the refusal, which is the part that matters: a silent segfault is the bug. The
|
||||||
|
remedy the messages name is the one that actually exists today — rebuild the host to match the module — rather
|
||||||
|
than a flag that does not. When item 3 does land, the marker is what makes the choice checkable rather than
|
||||||
|
merely intended, and these two crossed tests are what will catch a half-done version of it.
|
||||||
|
|
||||||
|
## Baseline
|
||||||
|
|
||||||
|
| | before | after |
|
||||||
|
|---|---|---|
|
||||||
|
| `test/survey-x86.sh` | 103 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **103 / 0 / 0 / 0** |
|
||||||
|
| skip breakdown | 28 does-not-compile / 8 no-main / 2 runs-forever | **28 / 8 / 2** |
|
||||||
|
| `test/cells.sh` | 4/4 ok | **4/4 ok** |
|
||||||
|
| `dune test --root .` | exit 0, 232 checks, 0 failures | **exit 0, 232 checks, 0 failures** |
|
||||||
|
|
||||||
|
The survey is the measurement that could have moved and did not, which is the point of running it: both
|
||||||
|
backends now emit a symbol into every `--dev` build, and the survey's default is a release build on both sides,
|
||||||
|
so an unguarded marker would have shown up as 103 identical-but-different objects rather than as a wrong
|
||||||
|
answer. It agrees byte-for-byte on what the programs print.
|
||||||
|
|
||||||
|
Run it detached — `setsid timeout 2400 test/survey-x86.sh > log 2>&1 </dev/null` — or a signal to this
|
||||||
|
harness's process group comes back as `SURVEY_EXIT=143`, which is not a result. The log is block-buffered
|
||||||
|
through the redirect and stays empty until the end; that is not a hang.
|
||||||
|
|
||||||
|
## What remains
|
||||||
|
|
||||||
|
- Item 3 of `HANDOFF-x86-redef.md`: `flan dev` and `flan reload` choosing host and module backend together.
|
||||||
|
The marker is now the thing that makes that checkable.
|
||||||
|
- A per-shape crossed measurement, still unmeasured and still depended on by nothing. It is *harder* to get
|
||||||
|
now, not easier: the marker refuses the pair before any of the four `step` functions runs, so anyone who
|
||||||
|
wants the answer has to build the crossed module with the marker suppressed on purpose.
|
||||||
|
- Items 1, 2 and 5 of `HANDOFF-x86-redef.md`, untouched.
|
||||||
|
- A seam worth knowing about before anyone renames a marker. The two strings live in OCaml — `X86.abi_marker`
|
||||||
|
and `Emit.abi_marker` — and the two `abi_mismatch` functions match the same literals in C, with nothing
|
||||||
|
linking the four. Rename one and the refusal still fires, because the symbol is still missing; it just stops
|
||||||
|
being a sentence and reverts to the loader's bare "undefined symbol", which is the failure this lane was
|
||||||
|
about. The crossed tests would catch it — they assert on the marker's name — so the seam is guarded, but it
|
||||||
|
is a seam.
|
||||||
@@ -138,9 +138,9 @@ together, the marker is what makes the choice checkable rather than merely inten
|
|||||||
|
|
||||||
| | before | after |
|
| | before | after |
|
||||||
|---|---|---|
|
|---|---|---|
|
||||||
| `spike/x86/survey.sh` | 99 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **99 / 0 / 0 / 0** |
|
| `test/survey-x86.sh` | 99 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **99 / 0 / 0 / 0** |
|
||||||
| skip breakdown | 28 does-not-compile / 6 no-main / 2 runs-forever | 28 / **8** / 2 |
|
| skip breakdown | 28 does-not-compile / 6 no-main / 2 runs-forever | 28 / **8** / 2 |
|
||||||
| `spike/x86/cells.sh` | 4/4 ok | **4/4 ok** |
|
| `test/cells.sh` | 4/4 ok | **4/4 ok** |
|
||||||
| `dune test --root .` | exit 0 | **exit 0** |
|
| `dune test --root .` | exit 0 | **exit 0** |
|
||||||
|
|
||||||
The `no-main` count moving from 6 to 8 is the two new fixtures existing: `survey.sh` globs
|
The `no-main` count moving from 6 to 8 is the two new fixtures existing: `survey.sh` globs
|
||||||
@@ -0,0 +1,233 @@
|
|||||||
|
# Handoff — `flan emit --x86` annotated, so its output can be read
|
||||||
|
|
||||||
|
Branch `dev-loop`, from `f772162`.
|
||||||
|
|
||||||
|
The x86 backend exists so that a dev build is ours end to end and so that a reader can be told *why* each
|
||||||
|
instruction is there. Until now `flan emit --x86` printed a three-line file header and then nothing but
|
||||||
|
`.byte` blobs: no source form, no frame key, no statement of the calling convention, nothing naming the
|
||||||
|
bookkeeping. Reading it meant `as` plus `objdump`, and even that answers only *what*.
|
||||||
|
|
||||||
|
**It is annotated now.** Every run of bytes is headed by the Flan form that produced it; every function
|
||||||
|
carries a frame map and a statement of how its arguments arrived; and every piece of bookkeeping the
|
||||||
|
compiler adds has a name where it appears and an explanation once, in a legend at the top of the file.
|
||||||
|
|
||||||
|
## What was built
|
||||||
|
|
||||||
|
| file | what |
|
||||||
|
|---|---|
|
||||||
|
| `lib/loc.ml` | `Loc.snippet` — the text of a span, on one line, whitespace collapsed, or `None` where there is no readable source. The squiggle's other half: the squiggle points at a form in its own file, this quotes it somewhere the file is not |
|
||||||
|
| `lib/x86.ml` | the annotation machinery: a queue of pending comments on `buf`, the per-form hook in `lower`, `frame_map`, the bookkeeping `note`s, and the legend |
|
||||||
|
| `bin/main.ml` | `emit --x86` annotates; `--no-annotate` is the bare spelling |
|
||||||
|
| `spike/x86/annot.sh` | **new** — emits every program in the corpus both ways, assembles both, and compares every section of the two objects byte for byte, in all three of default, `--dev` and `--debug` |
|
||||||
|
| `tools/dump.sh` | its x86 section now shows the annotated listing *and* the disassembly of the object that listing assembles to — why beside what |
|
||||||
|
|
||||||
|
`lib/build.ml` was not touched. A `--x86` build emits exactly the assembly it emitted before.
|
||||||
|
|
||||||
|
## The two decisions
|
||||||
|
|
||||||
|
**Annotation is always on for `flan emit --x86` and always off for a `--x86` build.** `flan emit` exists to
|
||||||
|
be read by a person, and there is no reason to make a reader ask for the thing the command is for. A build's
|
||||||
|
`.s` is a temporary file handed straight to clang and read by nobody, so leaving it untouched costs nothing
|
||||||
|
and buys something: `survey.sh`'s 103 MATCH stays a statement about the same text it has always been about,
|
||||||
|
rather than about text this lane rewrote. `--no-annotate` exists for exactly one consumer, `annot.sh`.
|
||||||
|
|
||||||
|
**None of this belongs to the LLVM path.** `flan emit` already prints IR that names its values, carries
|
||||||
|
`!dbg` on every instruction and a `!DILocalVariable` per slot. The problem being fixed here is one this
|
||||||
|
backend has and LLVM does not.
|
||||||
|
|
||||||
|
## Mnemonics: not done, deliberately
|
||||||
|
|
||||||
|
The brief allowed a trailing mnemonic per line as a bonus and said not to write a disassembler for it. No
|
||||||
|
disassembler was written — but the honest reason is not that one would be needed. The encoder knows the
|
||||||
|
mnemonic at the moment it emits the bytes; threading a text trace through every one of its entry points,
|
||||||
|
with memory-operand formatting to match, is a larger change than the request and would touch every encoding
|
||||||
|
function in the file, which is the part of it the survey is a structural check on.
|
||||||
|
|
||||||
|
What replaces it is cheaper and arguably better: `dump.sh` now prints the annotated `.s` and `objdump`'s
|
||||||
|
disassembly of the same object side by side. The disassembly says what the instructions are; the listing
|
||||||
|
says why they exist. Neither answers the other's question, and having both is what the four-way comparison
|
||||||
|
was for.
|
||||||
|
|
||||||
|
## How the annotation is attached, and why that shape
|
||||||
|
|
||||||
|
The bytes accumulate in `buf.pend` and flush as one `.byte` directive. A comment therefore cannot simply be
|
||||||
|
written when a form starts lowering — the form may emit nothing, and a heading left standing would be read
|
||||||
|
as belonging to whatever came next.
|
||||||
|
|
||||||
|
So headings are **queued, not written**. `annote` puts one on `buf.ann` with a serial; the next byte written
|
||||||
|
flushes the pending directive and then the queue, so the comment lands immediately above the bytes it is
|
||||||
|
about; and `unannote` withdraws whatever a form queued and never spent. The serials are monotonic, so
|
||||||
|
"was mine written?" is one integer comparison against the highest serial ever written.
|
||||||
|
|
||||||
|
The hook is in `lower`, beside `dwline`, and for the same reason `dwline` is there: the recursion that
|
||||||
|
lowers a nested call also lowers its arguments, so a heading queued in `lower` spans exactly the bytes that
|
||||||
|
form and everything inside it emit. The margin moves with the nesting, so an argument's code steps in and
|
||||||
|
the call's steps back out and the shape of the expression is visible without reading a word.
|
||||||
|
|
||||||
|
**Atoms are not annotated**, and this is the single detail the acceptance test turns on. A literal, a local
|
||||||
|
or a global would steal its parent's heading: `(* n 2)` lowers as a load, a load and an `imul`, and if the
|
||||||
|
two operands each queued a heading of their own then the line standing above the `imul` would name the
|
||||||
|
literal `2`. Skipping them leaves `(* n 2)` queued until the first byte and spanning the whole run. Read the
|
||||||
|
sample below: the line above the `imul` is the one that had to be right.
|
||||||
|
|
||||||
|
A form the checker invented carries `Loc.unknown` and is not annotated either — there is no source text to
|
||||||
|
quote, and it inherits the heading of the form that contains it, which is where it really came from. A form
|
||||||
|
at the same position as the last heading written is skipped, which is what stops a macro from printing its
|
||||||
|
call site once per form of its expansion. A function whose source is not readable from here — the prelude —
|
||||||
|
gets its frame map, no form headings, and one line saying so, rather than a column of bare positions.
|
||||||
|
|
||||||
|
## The frame map
|
||||||
|
|
||||||
|
This is the half that matters most and the one no amount of disassembly recovers. LLVM's output names its
|
||||||
|
values; this backend's cannot, because every value it has is a bump-allocated frame temporary and a
|
||||||
|
temporary has no name. So `-0x20(%rbp)` is the whole vocabulary of the listing and the map is its key.
|
||||||
|
|
||||||
|
Everything in it is read out of state `emit_fn` already keeps — `f.slots` *is* what the prologue stores
|
||||||
|
through, `fn.snames` is what the source called each slot — so it cannot drift from the code it describes.
|
||||||
|
The boundary between named slots and temporaries is captured as `fixed` right after the fixed allocations
|
||||||
|
and before the body is lowered; `maxframe` would be the wrong number, because that is the high-water mark of
|
||||||
|
the temporaries rather than where they start.
|
||||||
|
|
||||||
|
What is deliberately *not* described is any individual temporary. `scoped` reclaims them and a later form
|
||||||
|
reuses the bytes, so naming an offset that holds something else half the time is worse than saying where the
|
||||||
|
region begins — the same call the DWARF above it makes about locals, and for the same reason.
|
||||||
|
|
||||||
|
## The bookkeeping, named
|
||||||
|
|
||||||
|
Five things the compiler adds that no form asked for, each named where it appears and explained once in the
|
||||||
|
file legend rather than at every site: the transfer guard after every call to Flan code, the bounds check and
|
||||||
|
its signalling slow path, the arithmetic guard and the float-to-integer range check, `rep movsb` for every
|
||||||
|
aggregate copy, and the indirection cell a `--dev` build calls through. The prologue, the epilogue, the
|
||||||
|
transfer exit and C's `main` carry a prose block each.
|
||||||
|
|
||||||
|
## A worked sample
|
||||||
|
|
||||||
|
`tools/dump.sh small.flan twice`, on
|
||||||
|
|
||||||
|
```
|
||||||
|
(defn twice [n i64] i64
|
||||||
|
(* n 2))
|
||||||
|
```
|
||||||
|
|
||||||
|
LLVM at `-O2`:
|
||||||
|
|
||||||
|
```
|
||||||
|
flan.twice:
|
||||||
|
movq %rdi, -8(%rsp)
|
||||||
|
leaq (%rdi,%rdi), %rax
|
||||||
|
retq
|
||||||
|
```
|
||||||
|
|
||||||
|
and the same function out of this backend:
|
||||||
|
|
||||||
|
```
|
||||||
|
# ────────────────────────────────────────────────────────────────────
|
||||||
|
# "flan.twice" (defn twice [n i64] i64 small.flan:1:7
|
||||||
|
#
|
||||||
|
# Arguments: n from rdi.
|
||||||
|
# Returns i64 in rax.
|
||||||
|
# The transfer channel arrives last of all, from rsi. It is a pointer to the
|
||||||
|
# cell a callee writes its target into, and reading it is what every guard
|
||||||
|
# below does.
|
||||||
|
#
|
||||||
|
# The frame is 0x30 bytes below rbp. No call in it passes an argument on the
|
||||||
|
# stack.
|
||||||
|
#
|
||||||
|
# -0x8 n i64 parameter 1, from rdi
|
||||||
|
# -0x10 <chan> ptr the transfer channel this frame passes on
|
||||||
|
# -0x18 <ret> i64 the return value the epilogue loads
|
||||||
|
# Everything below -0x18 is a temporary. They are bump-allocated and
|
||||||
|
# reclaimed at the end of the form that made them, so a later form reuses
|
||||||
|
# the bytes and no one offset down there means one thing for long.
|
||||||
|
# ────────────────────────────────────────────────────────────────────
|
||||||
|
.globl "flan.twice"
|
||||||
|
.type "flan.twice", @function
|
||||||
|
"flan.twice":
|
||||||
|
# The prologue: save rbp, take the frame in one sub, and spill every incoming
|
||||||
|
# register into its slot. rsp is written here and by leave and nowhere else,
|
||||||
|
# so rsp % 16 == 0 at every call site below is a property of that one rounded
|
||||||
|
# sub rather than an invariant each case has to keep.
|
||||||
|
.byte 0x55,0x48,0x89,0xe5,0x48,0x81,0xec,0x30,...
|
||||||
|
# (* n 2) small.flan:2:3
|
||||||
|
.byte 0x48,0x8b,0x85,0xf8,0xff,0xff,0xff,0x48,0x89,0x85,0xe0,...
|
||||||
|
# The epilogue, and every return and every transfer out of this frame arrives
|
||||||
|
# here, so the frame is torn down once.
|
||||||
|
.Lret1048:
|
||||||
|
.byte 0x48,0x8b,0x85,0xe8,0xff,0xff,0xff,0xc9,0xc3
|
||||||
|
.size "flan.twice", . - "flan.twice"
|
||||||
|
```
|
||||||
|
|
||||||
|
Three LLVM instructions against thirteen, and the listing now says where the difference went: a real frame
|
||||||
|
rather than a red zone, because rsp is written twice per function and never at a call site; a transfer
|
||||||
|
channel parameter that LLVM's `-O2` dropped as dead and this backend spills because a dev build does not
|
||||||
|
optimise; and both operands of the multiply through frame temporaries at `-0x20` and `-0x28`, because every
|
||||||
|
intermediate in this backend is a frame temporary. None of that is visible in the disassembly and all of it
|
||||||
|
is visible here.
|
||||||
|
|
||||||
|
A denser one, from `bounds.flan` — the four instructions after every call, and the bounds triple:
|
||||||
|
|
||||||
|
```
|
||||||
|
# (at args 1) bounds.flan:11:35
|
||||||
|
.byte 0x48,0xb8,0x01,...
|
||||||
|
# The bounds check. One unsigned compare catches a negative index as
|
||||||
|
# well as an oversized one, and the not-taken branch is the whole of
|
||||||
|
# the fast path.
|
||||||
|
.byte 0x48,0x63,0x85,0xa4,...,0x48,0x39,0xc8,0x0f,0x82
|
||||||
|
.long .Linb1078 - . - 4
|
||||||
|
# Out of bounds: the location string, the operands, and this frame's
|
||||||
|
# channel, then flan_bounds_error, which signals
|
||||||
|
.byte 0x48,0x8d,0x3d
|
||||||
|
.long .Lk1079 - . - 4
|
||||||
|
...
|
||||||
|
call flan_bounds_error
|
||||||
|
# The transfer guard, after every call to Flan code: load this
|
||||||
|
# frame's channel, load through it, test, and branch if it is set —
|
||||||
|
# a callee that transferred left a target there and the value in rax
|
||||||
|
# means nothing.
|
||||||
|
.byte 0x4c,0x8b,0x9d,0xd0,...,0x0f,0x85
|
||||||
|
.long .Lxfer1077 - . - 4
|
||||||
|
# ud2, where emit.ml writes unreachable. Nothing answered the signal,
|
||||||
|
# so the runtime already died inside that call and nothing falls
|
||||||
|
# through to here.
|
||||||
|
.byte 0x0f,0x0b
|
||||||
|
```
|
||||||
|
|
||||||
|
## Verification
|
||||||
|
|
||||||
|
**Byte identity — `spike/x86/annot.sh`, 342 SAME / 0 DIFFER, measured on this code.** Every program in `test/programs` and in
|
||||||
|
`spike/x86`, emitted both ways, assembled both ways, and every section of the two objects compared byte for
|
||||||
|
byte — in the default build, in `--dev`, and in `--debug`. The `--debug` case is the sharp one: a
|
||||||
|
`.debug_line` row is an address expressed as a label, and annotation issues no labels and consumes no
|
||||||
|
`uniq`, precisely so that those cannot move. The 84 SKIPs are programs that do not compile at all — the
|
||||||
|
reject corpus and the generic-milestone ones — and are the same set the survey skips.
|
||||||
|
|
||||||
|
**`dune test --root .` — 232 checks, 0 failures**, run against this code. `dune build @page` and
|
||||||
|
`dune build @cells` both exit 0; `@cells` reports `x86 --dev: 22 22` and `x86 : 42 42`, which is the check
|
||||||
|
that the indirection cells and the ABI marker still come out where they were.
|
||||||
|
|
||||||
|
**`test/survey-x86.sh` has NOT been run on this work.** Two runs were started and both were invalidated by
|
||||||
|
racing with a `dune build` that replaced `bin/main.exe` underneath them; a third was killed on instruction
|
||||||
|
before it finished. **Whoever picks this up must not assume the 103 MATCH / 0 DIFFER / 0 REFUSED baseline
|
||||||
|
still holds — it is the one check that matters and it is outstanding.** Run it detached and with the
|
||||||
|
compiler pinned, so it cannot race a rebuild:
|
||||||
|
|
||||||
|
```
|
||||||
|
FLAN=_build/default/bin/main.exe setsid timeout 2400 test/survey-x86.sh > log 2>&1 </dev/null
|
||||||
|
```
|
||||||
|
|
||||||
|
What makes an unwelcome result unlikely rather than impossible: the survey builds through `flan build --x86`,
|
||||||
|
which passes `annotate = false`, so the assembly it compiles is produced by the same code path as before with
|
||||||
|
one field added to a record and two branches that are never taken. The edits that *could* reach it are the
|
||||||
|
ones to `buf` — `flush` now writes `b.ind`, which is `""` in a build, and `u8`/`dir`/`text`/`lbl` now test
|
||||||
|
`b.ann`, which is empty in a build. `annot.sh` proves those are inert for the object at 342 SAME across the
|
||||||
|
corpus in all three of default, `--dev` and `--debug`, but it proves it about the *assembly*, and only the
|
||||||
|
survey proves it about the programs.
|
||||||
|
|
||||||
|
## What is not here
|
||||||
|
|
||||||
|
- No mnemonics, for the reason above.
|
||||||
|
- No annotation of an individual temporary, for the reason above.
|
||||||
|
- The redefinition emitter (`X86.redefinition`) builds its install stub with annotation off. It is generated
|
||||||
|
code with no Flan form behind it and a frame map of two slots; the legend would be longer than the
|
||||||
|
function. If the reload path ever wants a readable listing, the `ann` field on its context is the one
|
||||||
|
line to change.
|
||||||
@@ -16,7 +16,7 @@ reason: it builds every corpus program twice and runs both, which is minutes whe
|
|||||||
dune build --root . @x86
|
dune build --root . @x86
|
||||||
|
|
||||||
It is a `(rule ...)` with no `(executable ...)` beside it, which is where it differs from its two neighbours. The
|
It is a `(rule ...)` with no `(executable ...)` beside it, which is where it differs from its two neighbours. The
|
||||||
check already exists — `spike/x86/survey.sh` is what every handoff quotes its counts from — and a second
|
check already exists — `test/survey-x86.sh` is what every handoff quotes its counts from — and a second
|
||||||
implementation of it in OCaml would be a second thing to drift, which is exactly the failure this alias is meant
|
implementation of it in OCaml would be a second thing to drift, which is exactly the failure this alias is meant
|
||||||
to prevent. So the rule runs the script, and the script grew three environment variables to make that possible:
|
to prevent. So the rule runs the script, and the script grew three environment variables to make that possible:
|
||||||
|
|
||||||
@@ -212,8 +212,8 @@ multi-file case: its directory table has one entry and its file table two, `gene
|
|||||||
|
|
||||||
| | before (`957ba07`) | after, on `957ba07` | after, rebased onto `eacf7c4` |
|
| | before (`957ba07`) | after, on `957ba07` | after, rebased onto `eacf7c4` |
|
||||||
|---|---|---|---|
|
|---|---|---|---|
|
||||||
| `spike/x86/survey.sh` | 99 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86, skips 28 + 6 + 2 | **99 / 0 / 0 / 0**, skips 28 + 6 + 2 | **101 / 0 / 0 / 0**, skips 28 + 6 + 2 |
|
| `test/survey-x86.sh` | 99 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86, skips 28 + 6 + 2 | **99 / 0 / 0 / 0**, skips 28 + 6 + 2 | **101 / 0 / 0 / 0**, skips 28 + 6 + 2 |
|
||||||
| `spike/x86/cells.sh` | 4/4 ok | 4/4 ok | **4/4 ok** |
|
| `test/cells.sh` | 4/4 ok | 4/4 ok | **4/4 ok** |
|
||||||
| `dune test --root .` | exit 0 | exit 0 | **exit 0**, run without a pipe; acceptance reports **232 checks, 0 failures** |
|
| `dune test --root .` | exit 0 | exit 0 | **exit 0**, run without a pipe; acceptance reports **232 checks, 0 failures** |
|
||||||
|
|
||||||
The MATCH count went from 99 to 101 across the rebase and neither is this lane's doing: the
|
The MATCH count went from 99 to 101 across the rebase and neither is this lane's doing: the
|
||||||
@@ -0,0 +1,260 @@
|
|||||||
|
# Handoff — the x86 backend, wired to the dev loop
|
||||||
|
|
||||||
|
Branch `dev-loop`, worktree `agent-aaf84e55296df121c`, from `f459352`. Items 1, 2 and 3 of
|
||||||
|
`HANDOFF-x86-redef.md`'s "What remains": the new-name path, the transient thunk, and the wiring that lets
|
||||||
|
`flan dev` choose the backend for a host and its modules together.
|
||||||
|
|
||||||
|
**All three landed, and the numbers say the lane was worth it.** A `C-c C-c` round trip through a real daemon
|
||||||
|
is **62–66ms on LLVM and 27–30ms on `--x86`** on this machine; `C-x C-e` is **60ms and 24ms**. The build inside
|
||||||
|
those is **53ms and 17–18ms**. Details and caveats in §Measured.
|
||||||
|
|
||||||
|
There is one finding that is not good news and it is in §The merged daemon: `flan dev --x86` refuses the
|
||||||
|
*merged* daemon and needs `--two-process`, because the compiler's macro module is a third way the two backends
|
||||||
|
can meet in one process and `flan.abi.x86` does not guard it.
|
||||||
|
|
||||||
|
> **Closed.** `docs/handoffs/HANDOFF-x86-macro-visibility.md` took the recommendation in §The merged daemon —
|
||||||
|
> hidden visibility on a macro module's Flan bodies — and `flan dev --x86` starts a merged daemon now. The
|
||||||
|
> refusal in `Dev.start` is gone, `test_dev.ml` drives a merged `--x86` session through C-x C-e, C-c C-c, a
|
||||||
|
> park and a `rerun`, and the analysis below stands as the account of what the failure *was*. One correction
|
||||||
|
> to it: by the time that lane ran, `-Wl,-Bsymbolic` had already landed for an unrelated reason (a package's
|
||||||
|
> `defmacro` resolving to the merged host's copy, commit 65d14f4) and was incidentally suppressing this crash
|
||||||
|
> too. It has been removed in favour of the narrow fix, for the reason §The merged daemon gives for not
|
||||||
|
> wanting it.
|
||||||
|
|
||||||
|
## What was built
|
||||||
|
|
||||||
|
| file | what |
|
||||||
|
|---|---|
|
||||||
|
| `lib/x86.ml` — `loc`'s new `Lslot`, `fnctx.slot` | a name the host was never built with: the address lives in a module-local slot the installer fills by string. `Lgot`'s shape with `Sym` where it has `Got` |
|
||||||
|
| `lib/x86.ml` — `redefinition`'s installer | `flan_dev_cell` / `flan_dev_global` lookups, an init image per new global, the `consts` republish, and a real frame so those calls are made on an aligned stack |
|
||||||
|
| `lib/x86.ml` — `flan_reload_call`, `flan_reload_transient` | what an expression evaluation compiles to, and the claim the agent unloads on |
|
||||||
|
| `lib/x86.ml` — `string_const` | now bumps `Emit.m.nstr`, which is the third transient condition |
|
||||||
|
| `lib/session.ml` — `t.x86`, `change.x86`, `redefinition` | the backend choice, as a session setting, made in one place |
|
||||||
|
| `lib/dev.ml` — `build_module`, `module_ext`, `Dev.start ?x86` | the daemon picking builder and extension off the change, and the two refusals |
|
||||||
|
| `lib/dev.ml` — `rename_program_main_asm`, `merged_executable`'s fork | an `--x86` merged host, which builds and is currently refused (see below) |
|
||||||
|
| `bin/main.ml` | `flan dev --x86`, `flan reload --x86`, and a bare `Failure` printed as a sentence |
|
||||||
|
| `test/programs/reload-v6.flan` | a run-time-new global with a value of its own |
|
||||||
|
| `test/test_reload.ml` | the x86 section runs all four modules against the LLVM transcript; the refusal it asserted is gone |
|
||||||
|
| `test/test_dev.ml` | an `--x86` daemon driven through `C-c C-c`, `C-x C-e`, a literal, a new `defvar` and a new `defn`; plus the merged refusal |
|
||||||
|
|
||||||
|
## 1. The new-name path
|
||||||
|
|
||||||
|
A function or a `defvar` the running process has no symbol for. ELF cannot grow one, so the address is asked
|
||||||
|
for by string at install time and parked in a slot this module defines — `flan.cellp.<n>` for a function's
|
||||||
|
cell, `flan.gp.<n>` for a global's storage, spelled as `Emit.cellptr` and `Emit.globalptr` spell them so the
|
||||||
|
two sides read against each other.
|
||||||
|
|
||||||
|
The reference side is **one new `loc` case and nothing else**. `Lslot` loads the slot and answers
|
||||||
|
`Reg (scratch, d)`, which is exactly what `Lgot` already did with `Got` where this has `Sym`. Every site that
|
||||||
|
reaches a cell already double-loads, so no call site, no place expression and no `sym_loc` caller had to learn
|
||||||
|
a third case. `fnctx.slot` is a *second* predicate rather than a widened `ext` because the two answer different
|
||||||
|
questions: `ext` says "the host's, reach it through the GOT", `slot` says "nobody's yet, reach it through a
|
||||||
|
slot I filled". It defaults to `fun _ -> None`, so the whole-program path emits byte-identical output and
|
||||||
|
`survey.sh` goes on being a structural check on all of this.
|
||||||
|
|
||||||
|
Three things that would each have cost a session:
|
||||||
|
|
||||||
|
- **`flan_reload_install` had to become a function with a frame.** It was a run of loads and stores plus `ret`,
|
||||||
|
which was fine while it called nothing. The moment it calls `flan_dev_cell`, rsp is 8-mod-16 at the call and
|
||||||
|
glibc's `movaps` inside `strcmp` faults — a failure that reads as a backend bug and is an ABI bug. Its shape
|
||||||
|
is now `emit_globals_init`'s, down to owning the null transfer cell no caller hands it.
|
||||||
|
- **A new global's declared value has to travel with it.** `flan_dev_global` copies it onto the allocation the
|
||||||
|
first time the name is interned and ignores it after, which is where "a reload must not reset the program's
|
||||||
|
state" lives. `emit.ml` folds that value into an LLVM constant and this file has no folder, so the image is a
|
||||||
|
module-local `.bss` buffer written by the initialiser *lowered as ordinary code* — which is the bargain
|
||||||
|
`emit_globals_data`'s comment already makes for a whole program, and it needs no second evaluator that could
|
||||||
|
disagree with the first about what a struct literal means.
|
||||||
|
- **Order inside the installer is load-bearing and is not checkable from outside.** Every lookup resolves
|
||||||
|
before any body is published; publishing first exposes a function whose slots are still null to every call
|
||||||
|
site in the host. `emit.ml` says the same and `test_reload.ml` checks it *there* by grepping the IR text.
|
||||||
|
There is no text to grep on this side, so the guarantee is the loop order and the comment above it.
|
||||||
|
|
||||||
|
`reload-v6.flan` is new and is the reason the fixture set was not enough. v3's `extra` is declared zero, which
|
||||||
|
`calloc` also gives, so a run-time-new global whose image never arrived would still have passed. v6's `tuning`
|
||||||
|
is 42 and the host prints 88.
|
||||||
|
|
||||||
|
Republishing a `defconst` came free once the rest was there — one store of the new constant into the host's
|
||||||
|
global, which is what `emit.ml` does — so that refusal is gone too.
|
||||||
|
|
||||||
|
## 2. The transient thunk
|
||||||
|
|
||||||
|
`flan_reload_call` is `emit_main` without the argv and the exit: no caller hands it a transfer channel, so it
|
||||||
|
owns a null cell on its own frame and passes that cell's address on. Sixteen bytes of frame rather than eight,
|
||||||
|
because rsp has to be 16-aligned at the call.
|
||||||
|
|
||||||
|
The thunk is excluded from everything else the module does — no cell, no publish, no registry slot. There are
|
||||||
|
4096 slots and an expression evaluated in a loop would exhaust them, and a module with nothing pointing into it
|
||||||
|
is what lets the agent `dlclose` it at all.
|
||||||
|
|
||||||
|
`@flan_reload_transient` is that claim, under `emit.ml`'s three conditions. The third is about **data** rather
|
||||||
|
than text and is the one that can be got wrong in the dangerous direction: a string literal lives in this
|
||||||
|
module's image, an expression may store one anywhere it likes, and a global left pointing into an unmapped
|
||||||
|
image is silent garbage rather than a fault. So the count is kept where the literals are made — `string_const`
|
||||||
|
bumps the same `Emit.m.nstr` field `emit.ml` counts on. Two deliberate decisions in that:
|
||||||
|
|
||||||
|
- **A float constant is not counted.** It is a label in the same `.rodata` and it is *loaded*, never retained.
|
||||||
|
Counting rodata bytes would be the wrong test; `emit.ml` keeps frame descriptors in a separate `nfi` for
|
||||||
|
exactly this reason and says so.
|
||||||
|
- **The installer's own registry name strings are counted.** That is right rather than incidental: a module
|
||||||
|
that interned a name left something behind, and `flan_dev.c` `strdup`s it precisely because the module that
|
||||||
|
passed it may go away.
|
||||||
|
|
||||||
|
## 3. The wiring
|
||||||
|
|
||||||
|
**The choice is a session setting, not a per-command flag**, and it is spelled exactly as `debug` already is:
|
||||||
|
one field on `Session.t`, set once in `Dev.start`, carried on every `Session.change` the session emits.
|
||||||
|
`session.ml`'s own comment on `debug` gives the reason and it is the same one — the modules have to match the
|
||||||
|
process they are loaded into. `Session.redefinition` is the single place that picks a backend, so the six call
|
||||||
|
sites cannot disagree and the refusal has one home; `change.x86` rides beside `change.ir` so the text and the
|
||||||
|
builder can never come from two different answers to the same question.
|
||||||
|
|
||||||
|
**There is no fallback and there must not be one.** If `X86.redefinition` refuses a form the daemon reports the
|
||||||
|
refusal. Quietly building an LLVM module instead is precisely the crossed pair `flan.abi.x86` exists to refuse
|
||||||
|
at `dlopen`. A refusal reaches the editor as a diagnostic like any other: `X86.Unsupported` is re-raised as a
|
||||||
|
`Loc.Error` at the form it is about, because every caller already handles that and none handled the other, and
|
||||||
|
a daemon that died on the first unsupported form would be worse than one that says so and stays up.
|
||||||
|
|
||||||
|
`flan reload` got the same flag at the same time. A command that could build a module for a host the other
|
||||||
|
backend compiled is how the crossed pair was reachable from the CLI at all; `HANDOFF-x86-aggregates.md`'s
|
||||||
|
two-line reproduction no longer has a second half.
|
||||||
|
|
||||||
|
**`--x86 --debug` is refused for the daemon**, and this is a decision rather than an oversight.
|
||||||
|
`flan build --x86 --debug` stays allowed — `X86.program` emits a hand-written DWARF 4 unit — but
|
||||||
|
`X86.redefinition` emits none, so a `--debug` session would build a host with a line table and then send it
|
||||||
|
modules without one. A breakpoint set on a line in the buffer would fire before the first `C-c C-c` and stop
|
||||||
|
firing after it. Accepting the flag and ignoring it would be worse.
|
||||||
|
|
||||||
|
## The merged daemon, which is the finding
|
||||||
|
|
||||||
|
**`flan dev --x86` refuses the merged daemon and needs `--two-process`.**
|
||||||
|
|
||||||
|
A merged build is the program and the compiler in one process. The compiler expands macros by `dlopen`ing a
|
||||||
|
module `Build.macro_module` made — through `Emit.program`, always, and cached on disk under
|
||||||
|
`~/.cache/flan/objcache` by the *macro source*, not by the backend. A merged host is linked `-rdynamic` so a
|
||||||
|
redefinition module can reach its cells, and that exports every `flan.*` body it has. So the macro module's own
|
||||||
|
copy of a prelude function is **interposed by the host's**.
|
||||||
|
|
||||||
|
With an LLVM host both halves are LLVM and nobody notices. With an `--x86` host the caller is LLVM and the body
|
||||||
|
it lands in is this backend's. Measured, before the refusal went in:
|
||||||
|
|
||||||
|
```
|
||||||
|
Thread 2 "program" received signal SIGSEGV
|
||||||
|
#0 0x0000000000403884 in flan[clamp] () <- the --x86 host's body
|
||||||
|
#1 0x00007ffff6f6b58c in flan.macro[clamp] () from ~/.cache/flan/objcache/flan-macros-....so
|
||||||
|
#2 flan_macro_call (dynload_stubs.c:68)
|
||||||
|
...
|
||||||
|
#19 camlFlan__Session.create_inner (lib/session.ml:117)
|
||||||
|
#20 camlFlan__Dev.merged_setup (lib/dev.ml:3013)
|
||||||
|
```
|
||||||
|
|
||||||
|
During the **first macro expansion**, before the program had started. `flan dev --x86` printed its build line
|
||||||
|
and exited 139.
|
||||||
|
|
||||||
|
Three things worth stating about it:
|
||||||
|
|
||||||
|
- **`flan.abi.x86` does not catch this and was never meant to.** It guards a redefinition module.
|
||||||
|
`HANDOFF-x86-abi-marker.md` reasoned explicitly that macro modules are unaffected because
|
||||||
|
`Build.macro_module` calls `Emit.program` without `~dev`, so a macro module neither defines nor requires a
|
||||||
|
marker — and that reasoning was correct for what it covered. This is a *third* path, and it exists only
|
||||||
|
because the merged daemon puts the compiler and the program in one address space.
|
||||||
|
- **`-Bsymbolic` is the wrong fix**, though it is one line. The macro module links its own `flan_rt.c`, and
|
||||||
|
binding symbolically would bind those calls to a copy of the runtime `flan_rt_init` never ran on — a second
|
||||||
|
bug hiding behind a green suite — and it would change the cached object for the LLVM path, which is the
|
||||||
|
default and must not move. `-Bsymbolic-functions` has the same defect.
|
||||||
|
- **The honest fix is hidden visibility on a macro module's Flan bodies.** That leaves the C runtime symbols
|
||||||
|
binding to the host's exactly as they do now and stops only the Flan ones from being interposed. It still
|
||||||
|
changes the cached object for both backends, so it wants a lane and a suite run of its own.
|
||||||
|
|
||||||
|
`--two-process` has no such meeting: the compiler is a separate binary that LLVM built, the macro module is
|
||||||
|
loaded into *it* and never into the program, and the only thing crossing between them is a redefinition module
|
||||||
|
— which this session now builds with the same backend as the host.
|
||||||
|
|
||||||
|
`start_merged` keeps its `--x86` plumbing (`rename_program_main_asm`, the `merged_executable` fork, the
|
||||||
|
`FLAN_DEV_X86` environment variable). It is unreachable today. It is the half that is right and it is what will
|
||||||
|
be wanted the day the macro module is fixed: the `--x86` merged host does build and link, and it is the *macro*
|
||||||
|
module and nothing about the host that stops it.
|
||||||
|
|
||||||
|
## Measured
|
||||||
|
|
||||||
|
One machine, `llc`/`clang` as installed here, warm caches. **This machine's `llc` is slower than the one
|
||||||
|
`docs/BUILT.md` was written on** — 42–48ms against that file's 15–17ms — so both rows below are measured here
|
||||||
|
rather than compared against that table. The shape of the answer is what matters and it does not depend on
|
||||||
|
which machine: `llc` is replaced by `as`, and `as` is five times cheaper.
|
||||||
|
|
||||||
|
`flan reload`, five runs each, on one changed `defn`:
|
||||||
|
|
||||||
|
| | LLVM | `--x86` |
|
||||||
|
|---|---|---|
|
||||||
|
| codegen | `llc` **42–48ms** | `as` **8.0–8.4ms** |
|
||||||
|
| link | `ld -shared` 9.7–11.4ms | `ld -shared` 8.9–9.3ms |
|
||||||
|
|
||||||
|
**Read `timing.llc_ms` carefully**: `Build.shared_x86` puts the *assembler's* time in that field, because the
|
||||||
|
record is shared between the two. `flan reload` now prints `as` or `llc` according to what ran, so its output
|
||||||
|
does not mislead; anything reading the field directly still has to know.
|
||||||
|
|
||||||
|
The round trip a user feels, through a real `flan dev --two-process` daemon on `programs/dev-repl.flan`,
|
||||||
|
measured at the socket — so this includes checking the form, emitting, building, delivering to the agent and
|
||||||
|
waiting for a frame boundary:
|
||||||
|
|
||||||
|
| | LLVM | `--x86` |
|
||||||
|
|---|---|---|
|
||||||
|
| `C-c C-c` (`eval`, one `defn`) | 62, 66, 65ms | **27, 28, 30ms** |
|
||||||
|
| of which the build reports | 53.0, 52.6, 53.5ms | **17.9, 17.2, 18.2ms** |
|
||||||
|
| `C-x C-e` (`eval-expr`) | 61, 60, 60ms | **24, 24, 25ms** |
|
||||||
|
|
||||||
|
**Better than twice as fast end to end, and three times on the build.** That is the claim the lane was written
|
||||||
|
to test and it holds.
|
||||||
|
|
||||||
|
Two things the numbers say that the headline does not:
|
||||||
|
|
||||||
|
- **`ld -shared` is now the bulk of the `--x86` build.** 9ms of an 18ms build, and it did not move between the
|
||||||
|
two backends. `docs/BUILT.md` records it at 3ms on the other machine; whatever the cause, the next
|
||||||
|
millisecond in this loop is in the linker and not in codegen. Nothing here tried to move it.
|
||||||
|
- **About 9ms of the round trip is neither codegen nor link.** 27ms at the socket against an 18ms build leaves
|
||||||
|
the frontend re-checking the program, the wire, the `dlopen` and the wait for a frame boundary.
|
||||||
|
`docs/BUILT.md` puts the re-check "under 10ms" and that is consistent. It was 14% of the LLVM round trip and
|
||||||
|
is 33% of this one, which is the ordinary consequence of removing the big term: the next thing worth
|
||||||
|
measuring has changed.
|
||||||
|
|
||||||
|
## Verification
|
||||||
|
|
||||||
|
| | before (`f459352`) | after |
|
||||||
|
|---|---|---|
|
||||||
|
| `dune test --root .` | exit 0, 232 checks, 0 failures | **exit 0, 232 checks, 0 failures**, three runs |
|
||||||
|
| `test/survey-x86.sh` | 103 MATCH / 0 DIFFER / 0 REFUSED / 0 NOX86 | **103 / 0 / 0 / 0** |
|
||||||
|
| skip breakdown | 28 does-not-compile / 8 no-main / 2 runs-forever | 28 / **9** / 2 |
|
||||||
|
| `test/cells.sh` | 4/4 ok | **4/4 ok** |
|
||||||
|
| `bash web/examples/check.sh` | green | **green** |
|
||||||
|
|
||||||
|
The `no-main` count moving from 8 to 9 is `reload-v6.flan` existing: `survey.sh` globs
|
||||||
|
`test/programs/*.flan`, and a program with no `main` fails the LLVM link and is classified there before the x86
|
||||||
|
build is attempted. `reload-agg.flan` moved it from 6 to 8 for the same reason. The **MATCH** count is what
|
||||||
|
must not move, and it did not.
|
||||||
|
|
||||||
|
The survey is the measurement that could have moved and did not, which is why it is run: `Lslot` and
|
||||||
|
`fnctx.slot` default to the whole-program answer and `string_const` now mutates `md.Emit.nstr` on that path
|
||||||
|
too, harmlessly, because nothing there reads it. The survey is what says so structurally rather than by
|
||||||
|
argument.
|
||||||
|
|
||||||
|
One more trap, and it wasted a run here. `dune test` caches a test's *result*: the second and third runs of an
|
||||||
|
unchanged tree print nothing and exit 0 without having executed anything. If what you want is three real runs
|
||||||
|
— which is what the flakiness in this area asks for — it is `dune test --root . --force`.
|
||||||
|
|
||||||
|
Run `dune test --root .` **without a pipe** — piping to `tail` gives you `tail`'s exit status, and the
|
||||||
|
`dev-robust` fixture puts `ld` and `clang` failure text in the output either way. Run the survey **detached**
|
||||||
|
(`setsid timeout 2400 test/survey-x86.sh > log 2>&1 </dev/null`) or a signal to the harness's process group
|
||||||
|
comes back as 143, which is not a result. And do not run the survey while `dune test` is running: both take the
|
||||||
|
`_build` lock, and the loser reports a lock error rather than a count.
|
||||||
|
|
||||||
|
## What remains
|
||||||
|
|
||||||
|
- ~~**The macro module, so the merged daemon can be `--x86`.**~~ Done — `HANDOFF-x86-macro-visibility.md`.
|
||||||
|
- **The linker.** 9ms, unchanged between backends, now the bulk of an `--x86` build.
|
||||||
|
- **DWARF from `X86.redefinition`**, which is what `flan dev --x86 --debug` is refused for.
|
||||||
|
- **`X86.program ~macros`**, if the macro module is ever to be built by this backend rather than merely made
|
||||||
|
immune to interposition. Not needed for the fix recommended above.
|
||||||
|
- **`test/test_emacs.ml` got no `--x86` case, deliberately.** It drives the Elisp client against a daemon, and
|
||||||
|
the client neither knows nor can say which backend a session uses — the flag is `flan dev`'s and the protocol
|
||||||
|
above it is identical. The real editor path for *this* lane is `test_dev.ml`, which drives the daemon's own
|
||||||
|
verbs and is where the case went. Worth revisiting only if `--x86` ever grows a spelling in the protocol.
|
||||||
|
- Items 2–7 of `HANDOFF-x86-rt.md` §6, unchanged. And still worth doing: **run `test/survey-x86.sh` in CI**.
|
||||||
@@ -19,7 +19,7 @@ and the caller that matters here is `guard`, the two-load-and-branch check emitt
|
|||||||
condition reads, in source terms: **a function that has a defer and makes no guarded call at all** — neither in the
|
condition reads, in source terms: **a function that has a defer and makes no guarded call at all** — neither in the
|
||||||
body nor in the defers, which are spliced onto the normal exit path and so are lowered as part of the body.
|
body nor in the defers, which are spliced onto the normal exit path and so are lowered as part of the body.
|
||||||
|
|
||||||
That is not an exotic shape. It is any leaf function with a defer. `spike/x86/p9-dead-defers.flan` is ten lines:
|
That is not an exotic shape. It is any leaf function with a defer. `test/programs/x86-p9-dead-defers.flan` is ten lines:
|
||||||
|
|
||||||
```flan
|
```flan
|
||||||
(defn quiet [n i32] i32
|
(defn quiet [n i32] i32
|
||||||
@@ -94,7 +94,7 @@ named `cleanup` is the innermost one, and anything that finds the channel set ag
|
|||||||
|
|
||||||
**Is the block emitted?** Yes, whenever a defer body contains a guarded call in a function that can unwind. `used` is
|
**Is the block emitted?** Yes, whenever a defer body contains a guarded call in a function that can unwind. `used` is
|
||||||
a `bool ref` set by `current_pad`, so a defer that only assigns — which is what `p6-transfer.flan`'s `middle` does —
|
a `bool ref` set by `current_pad`, so a defer that only assigns — which is what `p6-transfer.flan`'s `middle` does —
|
||||||
never emits it. `objdump -d` over `spike/x86/p10-defer-transfer.flan` built with `--x86` finds two references to
|
never emits it. `objdump -d` over `test/programs/x86-p10-defer-transfer.flan` built with `--x86` finds two references to
|
||||||
`flan_transfer_fail`.
|
`flan_transfer_fail`.
|
||||||
|
|
||||||
**Does anything arrive there?** Yes. The thing that makes this hard to construct is that `lib/check.ml`'s
|
**Does anything arrive there?** Yes. The thing that makes this hard to construct is that `lib/check.ml`'s
|
||||||
@@ -104,7 +104,7 @@ remaining case lives: "this is the one that reaches a function through a call, w
|
|||||||
So the probe puts the `invoke-restart` in an ordinary `defn` and has the defer call it. The checker has nothing to
|
So the probe puts the `invoke-restart` in an ordinary `defn` and has the defer call it. The checker has nothing to
|
||||||
object to, because from where it stands `second` is a function like any other.
|
object to, because from where it stands `second` is a function like any other.
|
||||||
|
|
||||||
`spike/x86/p10-defer-transfer.flan` is that program. `outer` establishes two nested restart-cases and a handler-bind
|
`test/programs/x86-p10-defer-transfer.flan` is that program. `outer` establishes two nested restart-cases and a handler-bind
|
||||||
and calls `middle`; `deep` signals; the handler aims a transfer at `esc-one`; the transfer unwinds `deep` and then
|
and calls `middle`; `deep` signals; the handler aims a transfer at `esc-one`; the transfer unwinds `deep` and then
|
||||||
`middle`; `middle`'s transfer exit clears the channel and runs its defers; and the defer calls `second`, which aims a
|
`middle`; `middle`'s transfer exit clears the channel and runs its defers; and the defer calls `second`, which aims a
|
||||||
second transfer at `esc-two`. The restart frames are both still pushed at that moment — it is `outer`'s own pad that
|
second transfer at `esc-two`. The restart frames are both still pushed at that moment — it is `outer`'s own pad that
|
||||||
@@ -115,7 +115,7 @@ is why the second restart-case has to be established *outside* the first.
|
|||||||
Both backends, verbatim and identical, at exit status 134:
|
Both backends, verbatim and identical, at exit status 134:
|
||||||
|
|
||||||
```
|
```
|
||||||
spike/x86/p10-defer-transfer.flan:39:7: a defer invoked a restart, which a defer may not do — it is the cleanup a transfer runs on its way out
|
test/programs/x86-p10-defer-transfer.flan:39:7: a defer invoked a restart, which a defer may not do — it is the cleanup a transfer runs on its way out
|
||||||
```
|
```
|
||||||
|
|
||||||
The location is `Loc.to_string fn.Tast.floc` — `middle`'s own `defer` form — on both sides, which is the part a
|
The location is `Loc.to_string fn.Tast.floc` — `middle`'s own `defer` form — on both sides, which is the part a
|
||||||
@@ -132,14 +132,14 @@ has for the case, and the corpus simply had no program that started a transfer f
|
|||||||
| file | state | what |
|
| file | state | what |
|
||||||
|---|---|---|
|
|---|---|---|
|
||||||
| `lib/x86.ml` — `emit_fn`, tail of the transfer exit | working | the item-5 refusal removed; one hunk, six lines out, a comment in. Nothing else in the file |
|
| `lib/x86.ml` — `emit_fn`, tail of the transfer exit | working | the item-5 refusal removed; one hunk, six lines out, a comment in. Nothing else in the file |
|
||||||
| `spike/x86/p9-dead-defers.flan` | working, MATCH | a leaf function with a defer and no call. Was the refusal |
|
| `test/programs/x86-p9-dead-defers.flan` | working, MATCH | a leaf function with a defer and no call. Was the refusal |
|
||||||
| `spike/x86/p10-defer-transfer.flan` | working, MATCH at 134 | a defer that calls a function that invokes a restart, while a first transfer unwinds |
|
| `test/programs/x86-p10-defer-transfer.flan` | working, MATCH at 134 | a defer that calls a function that invokes a restart, while a first transfer unwinds |
|
||||||
|
|
||||||
`lib/emit.ml`, `lib/check.ml` and `runtime/flan_rt.c` were not modified; no change to any of them was needed.
|
`lib/emit.ml`, `lib/check.ml` and `runtime/flan_rt.c` were not modified; no change to any of them was needed.
|
||||||
|
|
||||||
## The survey
|
## The survey
|
||||||
|
|
||||||
`bash spike/x86/survey.sh p9 p10` — the two new probes, both sides, built and run:
|
`bash test/survey-x86.sh p9 p10` — the two new probes, both sides, built and run:
|
||||||
|
|
||||||
```
|
```
|
||||||
MATCH 2
|
MATCH 2
|
||||||
@@ -153,7 +153,7 @@ Worth saying what that second row proves for `p10`, because it is not obvious: t
|
|||||||
hand-encoded backend that got the `.rodata` label or the length register wrong would still exit 134 and would still
|
hand-encoded backend that got the `.rodata` label or the length register wrong would still exit 134 and would still
|
||||||
look like a match to anything comparing only exit statuses.
|
look like a match to anything comparing only exit statuses.
|
||||||
|
|
||||||
And the full run, `SURVEY_QUIET=1 spike/x86/survey.sh`, over `test/programs` and `spike/x86` together:
|
And the full run, `SURVEY_QUIET=1 test/survey-x86.sh`, over `test/programs` and `spike/x86` together:
|
||||||
|
|
||||||
```
|
```
|
||||||
MATCH 99
|
MATCH 99
|
||||||
@@ -0,0 +1,149 @@
|
|||||||
|
# Handoff — a macro module keeps its own prelude, so the merged daemon can be `--x86`
|
||||||
|
|
||||||
|
Branch `dev-loop`, worktree `agent-a8f1c40df2a41e094`, from `9e80147`. This closes the finding of
|
||||||
|
`HANDOFF-x86-devloop.md` §The merged daemon: `flan dev --x86` refused the merged daemon and demanded
|
||||||
|
`--two-process`, because the compiler's macro module is a third way the two backends can meet in one process
|
||||||
|
and `flan.abi.x86` does not guard it.
|
||||||
|
|
||||||
|
**`flan dev --x86` starts a merged daemon now.** One process, a program that uses macros, C-x C-e, C-c C-c, a
|
||||||
|
park and a `rerun`, all in `dune test`. The LLVM path is byte-identical — see §Verification, which is the one
|
||||||
|
section of this file that had to be written before anything else was believed.
|
||||||
|
|
||||||
|
## What was built
|
||||||
|
|
||||||
|
| file | what |
|
||||||
|
|---|---|
|
||||||
|
| `lib/emit.ml` — `program ?hidden`, `emit_global ?hidden` | every Flan definition in the module emitted `hidden`, except the `flan.macro.*` thunks. Defaults to `false`, so no other caller moves |
|
||||||
|
| `lib/build.ml` — `macro_module` | passes `~hidden:true`, and drops the `-Wl,-Bsymbolic` that was doing the same job bluntly |
|
||||||
|
| `lib/dev.ml` — `Dev.start` | the `x86 && merged` refusal is gone; the comment in its place records what made the combination safe |
|
||||||
|
| `test/programs/dev-macro.flan` | new: `dev-loop.flan`'s shape with a prelude macro in it, and a bounded run so it parks on the clock |
|
||||||
|
| `test/test_dev.ml` | the assertion that the merged daemon refuses `--x86` is now a merged `--x86` session driven through both editor verbs, a park and a `rerun` |
|
||||||
|
| `NEXT.md`, `HANDOFF-x86-devloop.md` | the open finding, pointed at this file — `NEXT.md` is now `TODO.org` |
|
||||||
|
|
||||||
|
## The correction that came first
|
||||||
|
|
||||||
|
`HANDOFF-x86-devloop.md` says `-Bsymbolic` is the wrong fix and should not be reached for. By the time this
|
||||||
|
lane opened it was **already in the tree**: commit 65d14f4, for a different bug — a package's `defmacro`
|
||||||
|
compiled into the merged host, whose body was qualified after the quasiquote had become a string literal, so
|
||||||
|
expanding through the host's copy produced an unqualified `begin-drawing` the checker refused. That flag binds
|
||||||
|
*every* reference locally, so it had been incidentally suppressing the SIGSEGV as well.
|
||||||
|
|
||||||
|
So the first thing done here was to delete the refusal and change nothing else. `flan dev --x86` on
|
||||||
|
`test/programs/dev-repl.flan` and on `test/programs/sand-headless.flan` — which imports `sand.flan` and so
|
||||||
|
expands `rl/with-drawing` — both came up merged, served a C-c C-c and a C-x C-e, parked and reran. **The crash
|
||||||
|
was already gone.** That is worth stating plainly, because it changes what the rest of this lane is: not
|
||||||
|
"reproduce and fix a segfault" but "replace a blunt fix that works with a narrow one that works for a reason,
|
||||||
|
and prove both properties the blunt one was covering".
|
||||||
|
|
||||||
|
`-Bsymbolic` is worth replacing rather than leaving alone, and the reason is not tidiness. The macro module
|
||||||
|
links its own `flan_rt.c`. Binding symbolically aims its calls at that copy rather than the host's — a copy
|
||||||
|
`flan_rt_init` never ran on, and one whose `flan_exit_hook` is null. That hook is how a merged build parks
|
||||||
|
instead of exiting: a runtime trap raised inside a macro expansion would have called `exit(3)` and taken the
|
||||||
|
session down with it. Nothing in the suite goes there, which is exactly the shape of a bug that hides behind a
|
||||||
|
green run.
|
||||||
|
|
||||||
|
## The fix
|
||||||
|
|
||||||
|
`Emit.program ~hidden:true` writes `define hidden` on every Flan function and `hidden global` on every Flan
|
||||||
|
global. The thunks stay at default visibility, and that is the whole of the boundary: `flan_macro_call`
|
||||||
|
(`lib/dynload_stubs.c`) reaches a macro by `dlsym`, a hidden symbol is not in the table `dlsym` searches, and
|
||||||
|
nothing else in the module is anybody's to call. Measured on the module the suite builds:
|
||||||
|
|
||||||
|
```
|
||||||
|
$ nm -D --defined-only ~/.cache/flan/objcache/flan-macros-<key>.so | grep 'flan\.'
|
||||||
|
0000000000006490 T flan.macro.clamp
|
||||||
|
00000000000064b0 T flan.macro.unless
|
||||||
|
00000000000064d0 T flan.macro.into
|
||||||
|
```
|
||||||
|
|
||||||
|
Three symbols, and they are the three the compiler asks for by name. The 155 `flan_*` C symbols are still
|
||||||
|
exported and still bind to the host's when there is a host, which is the property `-Bsymbolic` was taking
|
||||||
|
away.
|
||||||
|
|
||||||
|
The mechanism was already in the file: `emit_fn ?hidden` exists for `Emit.redefinition`, whose comment records
|
||||||
|
the mirror-image failure — a redefinition's own body interposed by the host's, so the installer publishes the
|
||||||
|
function it was replacing and the reload appears to do nothing. `emit_global` needed the parameter added.
|
||||||
|
|
||||||
|
## What still depends on `-rdynamic`, audited
|
||||||
|
|
||||||
|
The export exists so a redefinition module can reach a running program's cells, and none of that moved: the fix
|
||||||
|
is on the module that is *loaded*, not on the process loading it. `Build.executable` still passes `-rdynamic`
|
||||||
|
for a dev build and `Emit.program` still defaults `hidden` to `false`, so a merged host's dynamic symbol table
|
||||||
|
is what it was. Item by item, with what says so:
|
||||||
|
|
||||||
|
- **A redefinition module reaching the host's cells and globals.** `Emit.redefinition` emits an `external` for
|
||||||
|
a global the host has and reaches a function through the host's cell symbol. Both are host exports. Covered
|
||||||
|
by the merged `--x86` C-c C-c in `test_dev.ml` and by every LLVM case above it.
|
||||||
|
- **`flan_dev_cell` / `flan_dev_global`.** C symbols in `runtime/flan_dev.c`, linked into the host, reached
|
||||||
|
from an installer by the same export. They are the new-name path. `test_dev.ml`'s `--two-process` `--x86`
|
||||||
|
case still does a new `defvar`, a new `defn` and a round trip through both.
|
||||||
|
- **`Emit.cellptr` / `Emit.globalptr`.** Module-local slots in the *redefinition* module that the installer
|
||||||
|
fills by string. Nothing in a macro module emits either, and `Emit.redefinition` is untouched.
|
||||||
|
- **`flan_reload_transient`.** Defined by a redefinition module and `dlsym`'d by `vendor/agent/flan_agent.c`
|
||||||
|
to decide whether the module can be unloaded. Also `Emit.redefinition`'s, also untouched — and note it is a
|
||||||
|
symbol looked up in a *dlopened object*, which is the one place hidden visibility would have broken
|
||||||
|
something had it been applied there.
|
||||||
|
- **The weak-symbol pattern in `lib/dynload_stubs.c`.** `flan_agent_request`, `flan_merged_rerun` and
|
||||||
|
`flan_merged_program_state` are `__attribute__((weak))` declarations resolved when the *compiler* is linked
|
||||||
|
into the merged executable — a static link, decided before any `dlopen` happens. A macro module has no
|
||||||
|
bearing on them. `rerun` working in the new test is the end-to-end proof: it is that exact pattern.
|
||||||
|
|
||||||
|
The one thing that did change is stated in §The correction above, and it changed *back*: the macro module's
|
||||||
|
calls into the C runtime bind to the host's copy again, as they did before 65d14f4.
|
||||||
|
|
||||||
|
**The invariant that keeps it that way: `~hidden:true` is passed by exactly one caller, `Build.macro_module`,
|
||||||
|
and it never passes `~dev`.** `Emit.program` refuses the pair outright now, because nothing in the types stops
|
||||||
|
someone writing it and the consequence would be a merged host that links, runs, and silently installs nothing:
|
||||||
|
a dev build's cells, globals and `flan.abi.*` marker are in the dynamic symbol table *on purpose*, for a
|
||||||
|
redefinition module to bind against. The other four call sites (`Build.executable`, `Dev.merged_executable`,
|
||||||
|
`bin/main.ml`'s `emit`, and the tests) take the default.
|
||||||
|
|
||||||
|
## Verification
|
||||||
|
|
||||||
|
| | before (`9e80147`) | after |
|
||||||
|
|---|---|---|
|
||||||
|
| `dune test --root . --force` | exit 0, 232 checks | **exit 0, 232 checks, `dev: all tests passed`** |
|
||||||
|
| emitted IR, 540 files | — | **byte-identical** |
|
||||||
|
| `flan dev --x86` merged, `sand-headless.flan` | SIGSEGV / refused | **up, parked, reran, same grid hash as LLVM** |
|
||||||
|
| `flan dev` merged, `sand-headless.flan` | up | **up, `rl/with-drawing` still expands** |
|
||||||
|
|
||||||
|
**The IR comparison is how "the LLVM path did not move" was verified, and it is the check worth repeating.**
|
||||||
|
Every `test/programs/*.flan` plus `sand.flan` and `calc-me.flan`, emitted twice — once release, once `--dev` —
|
||||||
|
by the compiler at `9e80147` and by this one: 540 files, `diff -rq` reports nothing. `hidden` defaults to
|
||||||
|
`false` and the only other edit to a format string adds an empty interpolation, so for those two paths this is
|
||||||
|
the argument made mechanical rather than a sample.
|
||||||
|
|
||||||
|
Be clear about what that diff does *not* say: it covers `Emit.program`'s default, which is every path but the
|
||||||
|
new one. `macro_module` deletes its `.ll` unless `opts.keep`, so the `hidden:true` output is not in it. What
|
||||||
|
stands behind the new path is `nm -D` on the linked object above — three thunks and nothing else of Flan's,
|
||||||
|
which is the property being claimed, read off the artefact rather than off the text that made it.
|
||||||
|
|
||||||
|
`test/survey-x86.sh` was **not** run here — it is forty minutes and this lane changes no lowering. It will
|
||||||
|
report one more `runs-forever` when it next runs: `dev-macro.flan` waits on an agent that is not there, which
|
||||||
|
is what `dev-loop.flan` and `dev-repl.flan` already do.
|
||||||
|
|
||||||
|
The two properties that had to hold together, in one run each:
|
||||||
|
|
||||||
|
- **LLVM merged, `sand-headless.flan`.** This is the one that checks 65d14f4, and the fixture is chosen for
|
||||||
|
it: `sand-headless.flan` imports `sand.flan` as a package, `sand.flan` imports `vendor:raylib` and calls
|
||||||
|
`rl/with-drawing` — a *package's* `defmacro`, reached through an import, which is exactly the shape the
|
||||||
|
reproduced bug had. A prelude macro would not have covered it, because the prelude's macros are not the ones
|
||||||
|
whose bodies were qualified after the quasiquote became a literal. If hidden visibility did not cover that
|
||||||
|
bug the daemon would have died with the checker refusing an unqualified `begin-drawing`. It came up and ran.
|
||||||
|
- **`--x86` merged, same program.** Both runs print the same grid hash, `15595743031174623232`, which is the
|
||||||
|
simulation having produced identical output through two backends in a process that also expanded macros.
|
||||||
|
|
||||||
|
## Notes for whoever is next
|
||||||
|
|
||||||
|
- **`dev-macro.flan` parks on a clock, not on a delivery**, and that is deliberate. `dev-loop.flan` waits for
|
||||||
|
a delivery per `while`, which means a test has to pace its ops to match the fixture's count; `dev-repl.flan`
|
||||||
|
runs for two minutes. This one runs 400 frames of 5ms and then returns, so the park is going to happen
|
||||||
|
whether or not `agent/wait` reported the thing the test sent. Two seconds of the default suite's 44.
|
||||||
|
- **The C-x C-e in that case is retried, not asked once.** `merged_setup` binds the socket and the program's
|
||||||
|
thread starts after it returns, so the first ask can land before there is an agent to reach. That is a race
|
||||||
|
with the startup and not a result.
|
||||||
|
- **`X86.program ~macros` is still unbuilt**, and is still not needed. A macro module is LLVM's and immune to
|
||||||
|
the host rather than matched to it, which is the cheaper of the two answers and the one that works when the
|
||||||
|
host is a backend the macro path has never heard of.
|
||||||
|
- `--x86 --debug` is still refused for the daemon, for the unrelated reason in `Dev.start`:
|
||||||
|
`X86.redefinition` emits no DWARF.
|
||||||
@@ -10,8 +10,8 @@ module publishes a new body into the host's cell, and the host's un-rebuilt call
|
|||||||
|
|
||||||
| | before (`b1cc67b`) | after |
|
| | before (`b1cc67b`) | after |
|
||||||
|---|---|---|
|
|---|---|---|
|
||||||
| `spike/x86/survey.sh` | 97 MATCH / 0 DIFFER / 0 refused | (see §"After", below) |
|
| `test/survey-x86.sh` | 97 MATCH / 0 DIFFER / 0 refused | (see §"After", below) |
|
||||||
| `spike/x86/cells.sh` | 4/4 ok | 4/4 ok |
|
| `test/cells.sh` | 4/4 ok | 4/4 ok |
|
||||||
| `dune test --root .` | exit 0 | exit 0 |
|
| `dune test --root .` | exit 0 | exit 0 |
|
||||||
|
|
||||||
`dune test` prints two `ld` / `clang` failures from inside the `dev-robust` fixture and still exits 0. Check the
|
`dune test` prints two `ld` / `clang` failures from inside the `dev-robust` fixture and still exits 0. Check the
|
||||||
@@ -61,7 +61,8 @@ So a reference to a symbol the object does not define goes through the GOT. Meas
|
|||||||
`call_flan`'s `` `Cell `` target loaded **one** level: `mov r11, cell@GOTPCREL(%rip)` then `call *%r11`. That
|
`call_flan`'s `` `Cell `` target loaded **one** level: `mov r11, cell@GOTPCREL(%rip)` then `call *%r11`. That
|
||||||
reads as "call through the cell" in a disassembly and in fact *calls the cell*. The GOT slot holds the cell's
|
reads as "call through the cell" in a disassembly and in fact *calls the cell*. The GOT slot holds the cell's
|
||||||
**address**; reading what the cell holds is two loads, not one. Found by the segfault, not by reading — which is
|
**address**; reading what the cell holds is two loads, not one. Found by the segfault, not by reading — which is
|
||||||
DISCUSS.md item 15's claim, now with a sixth instance. `load_sym` is the fix and is the only helper that
|
../DISCUSS.md item 15's claim (now docs/BUILT.md, "The bugs, and the shape they share"), now with a sixth
|
||||||
|
instance. `load_sym` is the fix and is the only helper that
|
||||||
double-loads; `Lgot` gets it right for free because `lmem` already had the shape.
|
double-loads; `Lgot` gets it right for free because `lmem` already had the shape.
|
||||||
|
|
||||||
## Scope, deliberately narrower than `Emit.redefinition`
|
## Scope, deliberately narrower than `Emit.redefinition`
|
||||||
@@ -97,14 +98,14 @@ That is `C-c C-c` on an existing `defn`, which is the demo, and it is what `test
|
|||||||
path; add a fixture beside it.
|
path; add a fixture beside it.
|
||||||
5. Items 2–7 of `HANDOFF-x86-rt.md` §6, unchanged.
|
5. Items 2–7 of `HANDOFF-x86-rt.md` §6, unchanged.
|
||||||
|
|
||||||
Also still true and still worth doing: **run `spike/x86/survey.sh` in CI**.
|
Also still true and still worth doing: **run `test/survey-x86.sh` in CI**.
|
||||||
|
|
||||||
## After, measured
|
## After, measured
|
||||||
|
|
||||||
| | before (`b1cc67b`) | after |
|
| | before (`b1cc67b`) | after |
|
||||||
|---|---|---|
|
|---|---|---|
|
||||||
| `spike/x86/survey.sh` | 97 MATCH / 0 DIFFER / 0 refused | **97 / 0 / 0**, skips `28 does-not-compile / 6 no-main / 2 runs-forever` — identical |
|
| `test/survey-x86.sh` | 97 MATCH / 0 DIFFER / 0 refused | **97 / 0 / 0**, skips `28 does-not-compile / 6 no-main / 2 runs-forever` — identical |
|
||||||
| `spike/x86/cells.sh` | 4/4 ok | **4/4 ok** |
|
| `test/cells.sh` | 4/4 ok | **4/4 ok** |
|
||||||
| `dune test --root .` | exit 0 | **exit 0**, run without a pipe |
|
| `dune test --root .` | exit 0 | **exit 0**, run without a pipe |
|
||||||
|
|
||||||
The skip breakdown is the line that matters beyond the MATCH count, because the no-`main` relaxation is the one
|
The skip breakdown is the line that matters beyond the MATCH count, because the no-`main` relaxation is the one
|
||||||
@@ -1,7 +1,8 @@
|
|||||||
# Handoff — the x86 backend's last two correctness items
|
# Handoff — the x86 backend's last two correctness items
|
||||||
|
|
||||||
Branch: `dev-loop`, worktree `agent-af9064091c0602dc8`. Three commits plus this one; nothing is half-written and
|
Branch: `dev-loop`, worktree `agent-af9064091c0602dc8`. Three commits plus this one; nothing is half-written and
|
||||||
nothing is reverted. The long-form report is **DISCUSS.md item 18**; this file is the operational version.
|
nothing is reverted. The long-form report is **../DISCUSS.md item 18** (now docs/BUILT.md, "The hand-written x86 backend, and the four
|
||||||
|
measurements behind it"); this file is the operational version.
|
||||||
|
|
||||||
## 1. The `flan_vec_as_slice` answer — got it, and it is complete
|
## 1. The `flan_vec_as_slice` answer — got it, and it is complete
|
||||||
|
|
||||||
@@ -48,7 +49,7 @@ repeated it. Verified with the survey: `Vec`/`Map` via `vec.flan`, `vec-of-vec.f
|
|||||||
|
|
||||||
## 2. Survey counts, measured
|
## 2. Survey counts, measured
|
||||||
|
|
||||||
`spike/x86/survey.sh`, unchanged in what it compares (stdout + stderr + exit status, same bounds-check setting both
|
`test/survey-x86.sh`, unchanged in what it compares (stdout + stderr + exit status, same bounds-check setting both
|
||||||
sides).
|
sides).
|
||||||
|
|
||||||
| | brief said | measured before | after |
|
| | brief said | measured before | after |
|
||||||
@@ -62,7 +63,7 @@ sides).
|
|||||||
two refusals — `slice-from-ptr.flan` and `bounds.flan` — both reported as `x86: primitive with 2 arguments`. Fixing
|
two refusals — `slice-from-ptr.flan` and `bounds.flan` — both reported as `x86: primitive with 2 arguments`. Fixing
|
||||||
that is commit 1 and is reported separately so the "after" number is not misread as this lane's work.
|
that is commit 1 and is reported separately so the "after" number is not misread as this lane's work.
|
||||||
|
|
||||||
Also measured, opt-in and new: `SURVEY_FLAGS=--dev spike/x86/survey.sh` → **97 MATCH / 0 DIFFER**.
|
Also measured, opt-in and new: `SURVEY_FLAGS=--dev test/survey-x86.sh` → **97 MATCH / 0 DIFFER**.
|
||||||
|
|
||||||
## 3. What was built, file by file
|
## 3. What was built, file by file
|
||||||
|
|
||||||
@@ -80,11 +81,11 @@ All **working and verified**; nothing in this list is unverified or reverted.
|
|||||||
| `lib/x86.ml` — `program` | working | now `~checks ?dev`; emits cells and the `flan_dev_reg_enable` ctor when `dev` |
|
| `lib/x86.ml` — `program` | working | now `~checks ?dev`; emits cells and the `flan_dev_reg_enable` ctor when `dev` |
|
||||||
| `lib/x86.ml` — `layout_ctx` | working | now `~checks ~dev`; `Emit.m.dev` is no longer hardcoded `false` |
|
| `lib/x86.ml` — `layout_ctx` | working | now `~checks ~dev`; `Emit.m.dev` is no longer hardcoded `false` |
|
||||||
| `lib/build.ml` | working | `--dev` removed from the `--x86` refusal list; `~dev:opts.dev` threaded to `X86.program` |
|
| `lib/build.ml` | working | `--dev` removed from the `--x86` refusal list; `~dev:opts.dev` threaded to `X86.program` |
|
||||||
| `spike/x86/survey.sh` | working | `SURVEY_FLAGS`, given to **both** sides. Default unchanged |
|
| `test/survey-x86.sh` | working | `SURVEY_FLAGS`, given to **both** sides. Default unchanged |
|
||||||
| `spike/x86/p7-slice-from-ptr.flan` | working, MATCH | negative length through a parameter and a `restart-case` |
|
| `test/programs/x86-p7-slice-from-ptr.flan` | working, MATCH | negative length through a parameter and a `restart-case` |
|
||||||
| `spike/x86/p8-cell.flan` | working, MATCH | direct call + function value, for `cells.sh` |
|
| `test/programs/x86-p8-cell.flan` | working, MATCH | direct call + function value, for `cells.sh` |
|
||||||
| `spike/x86/cell-override.c` | working | `dlsym("flan.cell.twice")` + store, in a constructor |
|
| `test/cell-override.c` | working | `dlsym("flan.cell.twice")` + store, in a constructor |
|
||||||
| `spike/x86/cells.sh` | working, 4/4 ok | the only test of the cell that can exist |
|
| `test/cells.sh` | working, 4/4 ok | the only test of the cell that can exist |
|
||||||
|
|
||||||
`lib/emit.ml` was **not** modified. No change to it was needed.
|
`lib/emit.ml` was **not** modified. No change to it was needed.
|
||||||
|
|
||||||
@@ -93,10 +94,10 @@ All **working and verified**; nothing in this list is unverified or reverted.
|
|||||||
Nothing fought for an hour. Four short false starts, all mine and all one-line:
|
Nothing fought for an hour. Four short false starts, all mine and all one-line:
|
||||||
|
|
||||||
- `handler-bind` clause syntax guessed as an `fn` literal:
|
- `handler-bind` clause syntax guessed as an `fn` literal:
|
||||||
`spike/x86/p7-slice-from-ptr.flan:30:18: a handler-bind clause is (Type [name] body ...)`.
|
`test/programs/x86-p7-slice-from-ptr.flan:30:18: a handler-bind clause is (Type [name] body ...)`.
|
||||||
The form is `(BoundsError [c] body ...)`; `test/programs/bounds-condition.flan:112` is the model.
|
The form is `(BoundsError [c] body ...)`; `test/programs/bounds-condition.flan:112` is the model.
|
||||||
- `(defn show [name [u8] ...])` for a literal argument:
|
- `(defn show [name [u8] ...])` for a literal argument:
|
||||||
`spike/x86/p7-slice-from-ptr.flan:37:14: expected [u8], found string`. A string literal wants `string`, not `[u8]`,
|
`test/programs/x86-p7-slice-from-ptr.flan:37:14: expected [u8], found string`. A string literal wants `string`, not `[u8]`,
|
||||||
even though they are the same two words at the machine level.
|
even though they are the same two words at the machine level.
|
||||||
- `cmp_imm` takes `~dst` and an `int`, not `~reg` and an `Int64`.
|
- `cmp_imm` takes `~dst` and an `int`, not `~reg` and an `Int64`.
|
||||||
- `cell-override.c`: `error: 'NULL' undeclared` — needs `<stddef.h>` beside `<dlfcn.h>`.
|
- `cell-override.c`: `error: 'NULL' undeclared` — needs `<stddef.h>` beside `<dlfcn.h>`.
|
||||||
@@ -111,7 +112,7 @@ fixtures did **not** fail here — `/tmp` had room throughout (6% used at start
|
|||||||
|
|
||||||
**Yes, reached and tested.** And the test is the interesting part, because *the corpus cannot do it*: a dev build
|
**Yes, reached and tested.** And the test is the interesting part, because *the corpus cannot do it*: a dev build
|
||||||
starts with every cell pointing at the body that build compiled, so it prints exactly what a release build prints
|
starts with every cell pointing at the body that build compiled, so it prints exactly what a release build prints
|
||||||
whether or not anything reads the cell. `spike/x86/cells.sh` preloads a `.so` whose constructor `dlsym`s
|
whether or not anything reads the cell. `test/cells.sh` preloads a `.so` whose constructor `dlsym`s
|
||||||
`flan.cell.twice` (the cells are in `.dynsym` — a dev build is `-rdynamic`) and stores a different body there. Four
|
`flan.cell.twice` (the cells are in `.dynsym` — a dev build is `-rdynamic`) and stores a different body there. Four
|
||||||
builds; the two release rows are the control that says the effect is the indirection and not symbol interposition:
|
builds; the two release rows are the control that says the effect is the indirection and not symbol interposition:
|
||||||
|
|
||||||
@@ -161,5 +162,5 @@ returned a struct. `cells.sh` does not reach it: the body it installs is `(i64,
|
|||||||
bounds check, every intermediate in memory, `rep movsb` block copies, and now an extra load per call site in a dev
|
bounds check, every intermediate in memory, `rep movsb` block copies, and now an extra load per call site in a dev
|
||||||
build — which is the one item `emit.ml` pays too.
|
build — which is the one item `emit.ml` pays too.
|
||||||
|
|
||||||
**Also worth doing and not a backend item: run `spike/x86/survey.sh` in CI.** The 2 refusals this lane found were a
|
**Also worth doing and not a backend item: run `test/survey-x86.sh` in CI.** The 2 refusals this lane found were a
|
||||||
month-old lane's new prim, and nothing noticed. A backend that refuses by name does not rot quietly, but it does rot.
|
month-old lane's new prim, and nothing noticed. A backend that refuses by name does not rot quietly, but it does rot.
|
||||||
+912
-124
File diff suppressed because it is too large.
Load diff
+987
-200
File diff suppressed because it is too large.
Load diff
+28
-9
@@ -1,6 +1,25 @@
|
|||||||
;;; flan-dape.el --- Debug a Flan program with dape and lldb-dap -*- lexical-binding: t; -*-
|
;;; flan-dape.el --- Debug a Flan program with dape and lldb-dap -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
;; The other half of the dev loop. flan-dev.el is about a program that keeps
|
;; Author: Joseph Ferano <joseph@ferano.io>
|
||||||
|
;; Version: 0.1.0
|
||||||
|
;; Package-Requires: ((emacs "29.1"))
|
||||||
|
;; Keywords: languages, lisp, tools
|
||||||
|
|
||||||
|
;; The headers above are what make this directory installable. M-x
|
||||||
|
;; package-install-file on it reads them, and a file with no Version: is not a
|
||||||
|
;; package as far as package.el is concerned -- until now the client was
|
||||||
|
;; reachable only by adding it to load-path by hand, which is a thing to
|
||||||
|
;; explain to every person who wants to try it.
|
||||||
|
;;
|
||||||
|
;; 29.1 is the floor because it is the oldest Emacs any of this has been run
|
||||||
|
;; against, not because some function here is known to need it. dape, which
|
||||||
|
;; flan-dape drives, asks for 29.1 as well and is a soft dependency: it is
|
||||||
|
;; reached through declare-function, so the rest of the client loads and works
|
||||||
|
;; without it and it is deliberately not listed above. The compiler this talks
|
||||||
|
;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md
|
||||||
|
;; says what has to be on PATH.
|
||||||
|
|
||||||
|
;; The other half of the dev loop. flan.el is about a program that keeps
|
||||||
;; running while you change it; this is about stopping one and reading it.
|
;; running while you change it; this is about stopping one and reading it.
|
||||||
;;
|
;;
|
||||||
;; There is no DAP implementation here and there should not be. `flan build
|
;; There is no DAP implementation here and there should not be. `flan build
|
||||||
@@ -46,7 +65,7 @@
|
|||||||
|
|
||||||
(defcustom flan-dape-command "flan"
|
(defcustom flan-dape-command "flan"
|
||||||
"The flan executable used to build a program for debugging.
|
"The flan executable used to build a program for debugging.
|
||||||
Its own option rather than flan-dev.el's `flan-dev-command', because this
|
Its own option rather than flan.el's `flan-command', because this
|
||||||
file is meant to load without that one: editing Flan, debugging Flan and
|
file is meant to load without that one: editing Flan, debugging Flan and
|
||||||
attaching to a running Flan are three independent things to want."
|
attaching to a running Flan are three independent things to want."
|
||||||
:type 'string)
|
:type 'string)
|
||||||
@@ -70,14 +89,14 @@ does and does not buy."
|
|||||||
:type '(repeat string))
|
:type '(repeat string))
|
||||||
|
|
||||||
(defun flan-dape--source ()
|
(defun flan-dape--source ()
|
||||||
"The .flan file this session is about.
|
"The .flan or .fln file this session is about.
|
||||||
The buffer's own file, or the nearest one up from it — so M-x flan-debug
|
The buffer's own file, or the nearest one up from it — so M-x flan-debug
|
||||||
from a *compilation* buffer or a dired still has an answer."
|
from a *compilation* buffer or a dired still has an answer."
|
||||||
(or (and buffer-file-name
|
(or (and buffer-file-name
|
||||||
(string-suffix-p ".flan" buffer-file-name)
|
(string-match-p "\\.fla?n\\'" buffer-file-name)
|
||||||
buffer-file-name)
|
buffer-file-name)
|
||||||
(car (directory-files default-directory t "\\.flan\\'"))
|
(car (directory-files default-directory t "\\.fla?n\\'"))
|
||||||
(user-error "No .flan file here to debug")))
|
(user-error "No .flan or .fln file here to debug")))
|
||||||
|
|
||||||
(defun flan-dape--binary (source)
|
(defun flan-dape--binary (source)
|
||||||
"Where the debug build of SOURCE goes.
|
"Where the debug build of SOURCE goes.
|
||||||
@@ -107,7 +126,7 @@ one made by `flan build'."
|
|||||||
;; can just read `buffer-file-name'. `dape' itself expects an already
|
;; can just read `buffer-file-name'. `dape' itself expects an already
|
||||||
;; evaluated config, so `flan-debug' below must not hand it the raw entry.
|
;; evaluated config, so `flan-debug' below must not hand it the raw entry.
|
||||||
(defconst flan-dape-config
|
(defconst flan-dape-config
|
||||||
'(modes (flan-mode)
|
'(modes (flan-base-mode)
|
||||||
ensure dape-ensure-command
|
ensure dape-ensure-command
|
||||||
command-cwd dape-command-cwd
|
command-cwd dape-command-cwd
|
||||||
compile (flan-dape--compile-command (flan-dape--source))
|
compile (flan-dape--compile-command (flan-dape--source))
|
||||||
@@ -159,11 +178,11 @@ common case is one command rather than a config prompt."
|
|||||||
;; thing entirely.
|
;; thing entirely.
|
||||||
;;;###autoload
|
;;;###autoload
|
||||||
(with-eval-after-load 'flan-mode
|
(with-eval-after-load 'flan-mode
|
||||||
(define-key (symbol-value 'flan-mode-map) (kbd "C-c C-g") #'flan-debug))
|
(define-key (symbol-value 'flan-base-mode-map) (kbd "C-c C-g") #'flan-debug))
|
||||||
|
|
||||||
;;; --dev and --debug are different builds
|
;;; --dev and --debug are different builds
|
||||||
;;
|
;;
|
||||||
;; `flan dev' — what flan-dev.el connects to — builds with --dev: every
|
;; `flan dev' — what flan.el connects to — builds with --dev: every
|
||||||
;; cross-function call goes through a cell so a redefinition can be installed,
|
;; cross-function call goes through a cell so a redefinition can be installed,
|
||||||
;; and -rdynamic exports those cells. `flan build --debug' is a different
|
;; and -rdynamic exports those cells. `flan build --debug' is a different
|
||||||
;; axis: -O0, DWARF, and no cells unless --dev is also passed.
|
;; axis: -O0, DWARF, and no cells unless --dev is also passed.
|
||||||
|
|||||||
-2016
File diff suppressed because it is too large.
Load diff
File diff suppressed because it is too large.
Load diff
+1215
-126
File diff suppressed because it is too large.
Load diff
@@ -0,0 +1,864 @@
|
|||||||
|
;;; flan-lower.el --- Every lowering of one function, in one buffer -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Author: Joseph Ferano <joseph@ferano.io>
|
||||||
|
;; Version: 0.1.0
|
||||||
|
;; Package-Requires: ((emacs "29.1"))
|
||||||
|
;; Keywords: languages, lisp, tools
|
||||||
|
|
||||||
|
;; The headers above are what make this directory installable. M-x
|
||||||
|
;; package-install-file on it reads them, and a file with no Version: is not a
|
||||||
|
;; package as far as package.el is concerned -- until now the client was
|
||||||
|
;; reachable only by adding it to load-path by hand, which is a thing to
|
||||||
|
;; explain to every person who wants to try it.
|
||||||
|
;;
|
||||||
|
;; 29.1 is the floor because it is the oldest Emacs any of this has been run
|
||||||
|
;; against, not because some function here is known to need it. dape, which
|
||||||
|
;; flan-dape drives, asks for 29.1 as well and is a soft dependency: it is
|
||||||
|
;; reached through declare-function, so the rest of the client loads and works
|
||||||
|
;; without it and it is deliberately not listed above. The compiler this talks
|
||||||
|
;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md
|
||||||
|
;; says what has to be on PATH.
|
||||||
|
|
||||||
|
;; `tools/dump.sh' prints four lowerings of one function side by side --
|
||||||
|
;; the LLVM IR the frontend emits, what `llc' makes of it at -O0 and at -O2,
|
||||||
|
;; and what the hand-written x86 backend emits. Reading one against another is
|
||||||
|
;; the only way to check a lowering by eye, and the whole reason the second
|
||||||
|
;; backend is trustworthy is that the two agree. This is that script with a
|
||||||
|
;; buffer around it.
|
||||||
|
;;
|
||||||
|
;; A scrollback is the wrong shape for it. Three of the four are noise on any
|
||||||
|
;; given day and the fourth is the one being worked on, so the four are
|
||||||
|
;; sections that fold, and which of them is open is remembered -- keyed to the
|
||||||
|
;; section and not to the function, because "I am on the backend this week" is
|
||||||
|
;; a fact about the backend and holds across every function looked at while it
|
||||||
|
;; is true.
|
||||||
|
;;
|
||||||
|
;; This is *not* `flan-disassemble', and the two cannot be merged. `C-c C-a'
|
||||||
|
;; asks the running program what the body it is calling for a name actually
|
||||||
|
;; came out as; only the daemon can answer that, because the daemon compiled
|
||||||
|
;; the module and still has both the .ll and the .so. Neither `llc -O2' nor
|
||||||
|
;; the hand-written backend has ever been run over that body, so there is no
|
||||||
|
;; four-way answer in the daemon to give. This command asks the other
|
||||||
|
;; question -- what does the source on disk compile to -- by compiling it, and
|
||||||
|
;; its header says so in as many words so that a listing never implies the
|
||||||
|
;; stronger claim.
|
||||||
|
;;
|
||||||
|
;; The folding is `outline-minor-mode', which is Emacs' own and has been since
|
||||||
|
;; long before Magit: `outline-flag-region' hides a subtree and
|
||||||
|
;; `outline-next-visible-heading' walks between them. Nothing under emacs/
|
||||||
|
;; requires a package that is not in Emacs and this does not start.
|
||||||
|
;;
|
||||||
|
;; Headings are found by the arrow that starts them, `▸' or `▾' at column
|
||||||
|
;; zero. That is not decoration standing in for structure: a regexp loose
|
||||||
|
;; enough to match four section headers written in ordinary characters also
|
||||||
|
;; matches inside three of the four bodies -- LLVM IR has `;' comments,
|
||||||
|
;; assembler output has `#' and `;' comments and lines beginning `.', and
|
||||||
|
;; objdump prints `<flan.step>:' label lines -- and folding then fragments in
|
||||||
|
;; the middle of a listing. Neither arrow can begin a line of any of the
|
||||||
|
;; three, so the arrow is both the affordance and the anchor.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'subr-x)
|
||||||
|
(require 'seq)
|
||||||
|
(require 'outline)
|
||||||
|
(require 'flan)
|
||||||
|
|
||||||
|
(defgroup flan-lower nil
|
||||||
|
"Every lowering of one Flan function, side by side."
|
||||||
|
:group 'flan
|
||||||
|
:prefix "flan-lower-")
|
||||||
|
|
||||||
|
(defcustom flan-lower-buffer "*flan-lowering*"
|
||||||
|
"Buffer `flan-lowering' writes into."
|
||||||
|
:type 'string)
|
||||||
|
|
||||||
|
(defcustom flan-lower-program "flan"
|
||||||
|
"The Flan compiler this shells out to.
|
||||||
|
A buffer under this editor is usually being worked on beside the compiler
|
||||||
|
that built it, so the useful value is often an absolute path into a build
|
||||||
|
directory rather than whatever is first on PATH."
|
||||||
|
:type 'string)
|
||||||
|
|
||||||
|
(defcustom flan-lower-flags nil
|
||||||
|
"Flags passed to `flan emit', and so to both the IR and the x86 section.
|
||||||
|
`(\"--dev\")' compares the four dev lowerings rather than the four release
|
||||||
|
ones. Only `flan emit' understands them: `llc' is handed the IR that came
|
||||||
|
out, so the two LLVM sections follow whatever this chose without being told."
|
||||||
|
:type '(repeat string))
|
||||||
|
|
||||||
|
(defcustom flan-lower-llc "llc"
|
||||||
|
"The LLVM static compiler the -O0 and -O2 sections are made with."
|
||||||
|
:type 'string)
|
||||||
|
|
||||||
|
;; The four, in the order they lower: what the frontend wrote, what LLVM makes
|
||||||
|
;; of it twice, and what this project's own backend makes of it. The symbols
|
||||||
|
;; are what the remembered state is keyed by, so they are the one part of this
|
||||||
|
;; list that is not free to change.
|
||||||
|
(defconst flan-lower--sections
|
||||||
|
'((ir . "LLVM IR")
|
||||||
|
(O0 . "LLVM -O0")
|
||||||
|
(O2 . "LLVM -O2")
|
||||||
|
(x86 . "x86 backend"))
|
||||||
|
"Section ids and the names they are shown under, in order.")
|
||||||
|
|
||||||
|
(defconst flan-lower--heading-re "^[▸▾] "
|
||||||
|
"What a section heading looks like from the start of a line.")
|
||||||
|
|
||||||
|
;; Session state and nothing more. Four booleans do not want a preference
|
||||||
|
;; file: it would be a thing to migrate the first time a section is renamed,
|
||||||
|
;; and nobody has ever wanted yesterday's fold state back. The IR is open to
|
||||||
|
;; begin with because a buffer that opens with everything shut reads as though
|
||||||
|
;; the command failed.
|
||||||
|
(defvar flan-lower--state
|
||||||
|
'((ir . t) (O0 . nil) (O2 . nil) (x86 . nil))
|
||||||
|
"Which sections are open, for this Emacs session.
|
||||||
|
Keyed by section and not by function on purpose -- see the header. This is
|
||||||
|
the single source of truth: a toggle changes this and then applies it to the
|
||||||
|
buffer, and a redraw applies it to the buffer it has just drawn. Visibility
|
||||||
|
is never read back out, which would tie this to whether outline folds with
|
||||||
|
overlays or with text properties.")
|
||||||
|
|
||||||
|
(defvar flan-lower-fetch-function #'flan-lower--fetch
|
||||||
|
"How one section's text is obtained.
|
||||||
|
Called with (SECTION FILE NAME FLAGS) and answers a string, or signals an
|
||||||
|
error whose message becomes the section's body. A variable rather than a
|
||||||
|
call so that the renderer can be driven from a test without four subprocesses
|
||||||
|
and an `llc -O2' per redraw.")
|
||||||
|
|
||||||
|
(defvar-local flan-lower--file nil "Source file the sections were made from.")
|
||||||
|
(defvar-local flan-lower--name nil "Flan name the sections were narrowed to.")
|
||||||
|
(defvar-local flan-lower--flags nil "Flags `flan emit' was given.")
|
||||||
|
(defvar-local flan-lower--texts nil "Alist of section id to its text.")
|
||||||
|
(defvar-local flan-lower--dir nil "Scratch directory the intermediates live in.")
|
||||||
|
|
||||||
|
;;; Faces
|
||||||
|
|
||||||
|
(defface flan-lower-heading '((t :inherit bold))
|
||||||
|
"Face for a section heading.")
|
||||||
|
|
||||||
|
(defface flan-lower-count '((t :inherit shadow))
|
||||||
|
"Face for the line count beside a section heading.")
|
||||||
|
|
||||||
|
;;; Getting the four
|
||||||
|
|
||||||
|
(defun flan-lower--scratch ()
|
||||||
|
"The scratch directory for this buffer, made on first use.
|
||||||
|
The intermediates are kept rather than piped so that refreshing one section
|
||||||
|
does not recompile the file: `llc -O2' is the slow one and the IR it reads
|
||||||
|
has not changed."
|
||||||
|
(unless (and flan-lower--dir (file-directory-p flan-lower--dir))
|
||||||
|
(setq flan-lower--dir (make-temp-file "flan-lower-" t)))
|
||||||
|
flan-lower--dir)
|
||||||
|
|
||||||
|
(defun flan-lower--clean ()
|
||||||
|
"Remove this buffer's scratch directory."
|
||||||
|
(when (and flan-lower--dir (file-directory-p flan-lower--dir))
|
||||||
|
(delete-directory flan-lower--dir t))
|
||||||
|
(setq flan-lower--dir nil))
|
||||||
|
|
||||||
|
(defun flan-lower--run (out program &rest args)
|
||||||
|
"Run PROGRAM with ARGS, stdout to OUT, and answer OUT.
|
||||||
|
A failure is signalled with the program's own stderr, because every one of
|
||||||
|
these is a compiler and the compiler's complaint is the whole of what a
|
||||||
|
reader needs."
|
||||||
|
(let ((err (expand-file-name "stderr" (flan-lower--scratch))))
|
||||||
|
(unless (executable-find program)
|
||||||
|
(error "no %s on PATH" program))
|
||||||
|
(let ((code (apply #'call-process program nil (list (list :file out) err)
|
||||||
|
nil args)))
|
||||||
|
(unless (eq code 0)
|
||||||
|
(error "%s exited %s: %s" program code
|
||||||
|
(string-trim
|
||||||
|
(with-temp-buffer (insert-file-contents err) (buffer-string)))))
|
||||||
|
out)))
|
||||||
|
|
||||||
|
(defun flan-lower--slurp (file)
|
||||||
|
"The contents of FILE as a string."
|
||||||
|
(with-temp-buffer (insert-file-contents file) (buffer-string)))
|
||||||
|
|
||||||
|
(defun flan-lower--ll (file flags &optional debug)
|
||||||
|
"The IR for FILE under FLAGS, made once and kept.
|
||||||
|
Every section is downstream of this one: `llc' reads it twice and the x86
|
||||||
|
section is the same frontend asked for a different back half.
|
||||||
|
|
||||||
|
With DEBUG, the same IR with a line table in it, which is what `llc' is
|
||||||
|
given: its output then says which source position each instruction came
|
||||||
|
from, and `flan-lower--annotate-llc' turns those into the forms. A line
|
||||||
|
table changes no instruction LLVM emits, so the two LLVM sections are still
|
||||||
|
what the IR section compiles to."
|
||||||
|
(let ((ll (expand-file-name (if debug "out.dbg.ll" "out.ll")
|
||||||
|
(flan-lower--scratch))))
|
||||||
|
(unless (file-exists-p ll)
|
||||||
|
(apply #'flan-lower--run ll flan-lower-program "emit" file
|
||||||
|
(if (and debug (not (member "--debug" flags)))
|
||||||
|
(append flags '("--debug"))
|
||||||
|
flags)))
|
||||||
|
ll))
|
||||||
|
|
||||||
|
;;; Source lines
|
||||||
|
|
||||||
|
;; Every listing here is headed by the Flan forms it came from. The IR carries
|
||||||
|
;; them itself: `flan emit' writes a `; form file:line:col' comment above the
|
||||||
|
;; first instruction of each form. The other three lose comments on the way
|
||||||
|
;; through a compiler, so each gets them back from what survives: `llc' keeps
|
||||||
|
;; the line table's positions as `.loc' directives, and the x86 backend ends
|
||||||
|
;; each function with a map from byte offsets to forms, which the assembler
|
||||||
|
;; ignores and which is read here out of the assembly it was given.
|
||||||
|
|
||||||
|
(defun flan-lower--split-where (where)
|
||||||
|
"WHERE, a heading's \"file:line:col\", as (FILE LINE COL), or nil.
|
||||||
|
The file is everything before the last two colons, so a name holding a colon
|
||||||
|
or a space survives."
|
||||||
|
(when (string-match "\\`\\(.*\\):\\([0-9]+\\):\\([0-9]+\\)\\'" where)
|
||||||
|
(list (match-string 1 where)
|
||||||
|
(string-to-number (match-string 2 where))
|
||||||
|
(string-to-number (match-string 3 where)))))
|
||||||
|
|
||||||
|
(defun flan-lower--shown (where)
|
||||||
|
"WHERE as a listing shows it: the file by its base name."
|
||||||
|
(pcase (flan-lower--split-where where)
|
||||||
|
(`(,file ,line ,col) (format "%s:%d:%d" (file-name-nondirectory file) line col))
|
||||||
|
(_ where)))
|
||||||
|
|
||||||
|
(defun flan-lower--comment-text (s)
|
||||||
|
"S with its control characters escaped, as `flan emit' writes a file name."
|
||||||
|
(replace-regexp-in-string
|
||||||
|
"[\x00-\x1f\x7f]"
|
||||||
|
(lambda (c)
|
||||||
|
(pcase (aref c 0)
|
||||||
|
(?\n "\\\\n") (?\r "\\\\r") (?\t "\\\\t")
|
||||||
|
(ch (format "\\\\x%02x" ch))))
|
||||||
|
s t))
|
||||||
|
|
||||||
|
(defun flan-lower--same-file (table heading)
|
||||||
|
"Whether TABLE, a path from a line table, names the file HEADING names.
|
||||||
|
The line table's path may have been made absolute where the heading's is the
|
||||||
|
one the program was given, so a trailing run of whole components counts."
|
||||||
|
(let ((table (flan-lower--comment-text table)))
|
||||||
|
(or (equal table heading)
|
||||||
|
(and (< (length heading) (length table))
|
||||||
|
(string-suffix-p (concat "/" heading) table)))))
|
||||||
|
|
||||||
|
(defun flan-lower--headings (ir)
|
||||||
|
"The headings in IR, as a table of (LINE . COL) to a list of (FILE . FORM).
|
||||||
|
A heading is `; form', padding, a tab and its position; the tab is the one
|
||||||
|
character neither half can hold."
|
||||||
|
(let ((tbl (make-hash-table :test #'equal)))
|
||||||
|
(dolist (l (split-string ir "\n"))
|
||||||
|
(when (string-match "\\`[ \t]*; \\([^\t]*\\)\t\\(.*\\)\\'" l)
|
||||||
|
;; Both taken before `string-trim', which matches a regexp of its own.
|
||||||
|
(let* ((where (match-string 2 l))
|
||||||
|
(form (string-trim (match-string 1 l))))
|
||||||
|
(pcase (flan-lower--split-where where)
|
||||||
|
(`(,file ,line ,col)
|
||||||
|
(push (cons file form) (gethash (cons line col) tbl)))))))
|
||||||
|
tbl))
|
||||||
|
|
||||||
|
(defun flan-lower--unoctal (s)
|
||||||
|
"S, a string from an assembler directive, with its octal escapes decoded."
|
||||||
|
(replace-regexp-in-string
|
||||||
|
"\\\\\\([0-7]\\{3\\}\\|\\\\\\|\"\\)"
|
||||||
|
(lambda (m)
|
||||||
|
(let ((e (substring m 1)))
|
||||||
|
(if (string-match-p "\\`[0-7]\\{3\\}\\'" e)
|
||||||
|
(string (string-to-number e 8))
|
||||||
|
e)))
|
||||||
|
s t t))
|
||||||
|
|
||||||
|
(defun flan-lower--files (asm)
|
||||||
|
"The `.file' table of ASM, `llc' output: file number to path."
|
||||||
|
(let ((tbl (make-hash-table)))
|
||||||
|
(dolist (l (split-string asm "\n"))
|
||||||
|
(when (string-match
|
||||||
|
"\\`[ \t]*\\.file[ \t]+\\([0-9]+\\)[ \t]+\"\\(\\(?:[^\"\\]\\|\\\\.\\)*\\)\"\\(?:[ \t]+\"\\(\\(?:[^\"\\]\\|\\\\.\\)*\\)\"\\)?" l)
|
||||||
|
(let* ((n (string-to-number (match-string 1 l)))
|
||||||
|
(a (flan-lower--unoctal (match-string 2 l)))
|
||||||
|
(b (and (match-string 3 l) (flan-lower--unoctal (match-string 3 l)))))
|
||||||
|
(puthash n (cond ((null b) a)
|
||||||
|
((file-name-absolute-p b) b)
|
||||||
|
(t (concat (file-name-as-directory a) b)))
|
||||||
|
tbl))))
|
||||||
|
tbl))
|
||||||
|
|
||||||
|
(defun flan-lower--annotate-llc (text headings files)
|
||||||
|
"TEXT, `llc' output with a line table, with each position written as its form.
|
||||||
|
A `.loc' whose file (looked up in FILES, the `.file' table) and position have
|
||||||
|
a form in HEADINGS becomes a comment quoting it, unless it names the form just
|
||||||
|
quoted; the directives, and the labels the line table alone needed, are
|
||||||
|
dropped."
|
||||||
|
(let ((last nil) (out nil))
|
||||||
|
(dolist (l (split-string text "\n"))
|
||||||
|
(cond
|
||||||
|
((string-match "\\`[ \t]*\\.loc[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)[ \t]+\\([0-9]+\\)" l)
|
||||||
|
(let* ((path (gethash (string-to-number (match-string 1 l)) files))
|
||||||
|
(line (string-to-number (match-string 2 l)))
|
||||||
|
(col (string-to-number (match-string 3 l)))
|
||||||
|
(hit (and path
|
||||||
|
(seq-find (lambda (h) (flan-lower--same-file path (car h)))
|
||||||
|
(gethash (cons line col) headings))))
|
||||||
|
(form (cdr hit)))
|
||||||
|
(when (and form (not (equal form last)))
|
||||||
|
(setq last form)
|
||||||
|
(push (format "\t# %s%s%s" form
|
||||||
|
(make-string (max 1 (- 56 (length form))) ?\s)
|
||||||
|
(format "%s:%d:%d"
|
||||||
|
(file-name-nondirectory (car hit)) line col))
|
||||||
|
out))))
|
||||||
|
((string-match-p "\\`\\(\\.Ltmp[0-9]+\\|\\.Lfunc_begin[0-9]+\\):\\'" l))
|
||||||
|
((string-match-p "\\`[ \t]*\\.file[ \t]+[0-9]" l))
|
||||||
|
(t (push l out))))
|
||||||
|
(string-join (nreverse out) "\n")))
|
||||||
|
|
||||||
|
(defun flan-lower--srcmap (asm name)
|
||||||
|
"The x86 backend's source map for NAME out of ASM, as (OFFSET DEPTH WHERE FORM)."
|
||||||
|
(let ((sym (concat "flan." name)) (out nil))
|
||||||
|
(dolist (l (split-string asm "\n"))
|
||||||
|
(let ((f (split-string (string-trim l) "\t")))
|
||||||
|
(when (and (>= (length f) 6)
|
||||||
|
(equal (nth 0 f) "#@")
|
||||||
|
(equal (nth 1 f) sym))
|
||||||
|
(push (list (string-to-number (substring (nth 2 f) 2) 16)
|
||||||
|
(string-to-number (nth 3 f))
|
||||||
|
(nth 4 f)
|
||||||
|
(string-join (nthcdr 5 f) "\t"))
|
||||||
|
out))))
|
||||||
|
(nreverse out)))
|
||||||
|
|
||||||
|
(defun flan-lower--annotate-x86 (text srcmap)
|
||||||
|
"TEXT, objdump's listing of one function, with SRCMAP's forms placed in it.
|
||||||
|
Each form is written above the first instruction at or past its offset from
|
||||||
|
the function's first byte, indented by how deeply it is nested."
|
||||||
|
(let ((base nil) (out nil) (pending srcmap))
|
||||||
|
(dolist (l (split-string text "\n"))
|
||||||
|
(cond
|
||||||
|
((string-match "\\`\\([0-9a-f]+\\) <[^>]+>:" l)
|
||||||
|
(setq base (string-to-number (match-string 1 l) 16)))
|
||||||
|
((and base (string-match "\\`[ \t]*\\([0-9a-f]+\\):" l))
|
||||||
|
(let ((off (- (string-to-number (match-string 1 l) 16) base)))
|
||||||
|
(while (and pending (<= (car (car pending)) off))
|
||||||
|
(pcase-let* ((`(,_ ,depth ,where ,form) (pop pending))
|
||||||
|
(head (format "\t%s# %s" (make-string (* 2 depth) ?\s)
|
||||||
|
form)))
|
||||||
|
(push (concat head (make-string (max 1 (- 62 (length head))) ?\s)
|
||||||
|
(flan-lower--shown where))
|
||||||
|
out))))))
|
||||||
|
(push l out))
|
||||||
|
(string-join (nreverse out) "\n")))
|
||||||
|
|
||||||
|
(defun flan-lower--fetch (section file name flags)
|
||||||
|
"The text of SECTION for NAME in FILE, compiled with FLAGS.
|
||||||
|
Narrowed to the one function, which is almost always what is wanted: the
|
||||||
|
prelude is emitted too, so a two-line program is ten thousand lines of IR."
|
||||||
|
(let ((sym (concat "flan\\." (regexp-quote name))))
|
||||||
|
(pcase section
|
||||||
|
('ir
|
||||||
|
;; LLVM spells the name `@"flan.step"' when it needs quoting and
|
||||||
|
;; `@flan.step' when it does not, and a packaged name always needs it.
|
||||||
|
(flan-lower--narrow (flan-lower--slurp (flan-lower--ll file flags))
|
||||||
|
(concat "^define .*@\"?" sym "\"?(") "^}"))
|
||||||
|
((or 'O0 'O2)
|
||||||
|
(let ((s (expand-file-name (format "out.%s.s" section) (flan-lower--scratch)))
|
||||||
|
(ll (flan-lower--ll file flags t)))
|
||||||
|
(unless (file-exists-p s)
|
||||||
|
(flan-lower--run s flan-lower-llc
|
||||||
|
(if (eq section 'O0) "-O0" "-O2")
|
||||||
|
ll "-o" s))
|
||||||
|
;; `.size' ends the function in GAS output, and it is the last line
|
||||||
|
;; of it rather than the first line of the next.
|
||||||
|
(let* ((asm (flan-lower--slurp s))
|
||||||
|
(text (flan-lower--narrow asm (concat "^\"?" sym "\"?:")
|
||||||
|
"\\.size")))
|
||||||
|
(and text
|
||||||
|
(flan-lower--annotate-llc
|
||||||
|
text (flan-lower--headings (flan-lower--slurp ll))
|
||||||
|
(flan-lower--files asm))))))
|
||||||
|
('x86
|
||||||
|
(let ((dis (expand-file-name "out.x86.dis" (flan-lower--scratch))))
|
||||||
|
(unless (file-exists-p dis)
|
||||||
|
(let ((s (expand-file-name "out.x86.s" (flan-lower--scratch)))
|
||||||
|
(o (expand-file-name "out.x86.o" (flan-lower--scratch))))
|
||||||
|
;; The IR is asked for first even though this path does not read
|
||||||
|
;; it, so that a frontend error is reported once, in whichever
|
||||||
|
;; section is fetched first, rather than twice in two dialects.
|
||||||
|
(flan-lower--ll file flags)
|
||||||
|
(apply #'flan-lower--run s flan-lower-program
|
||||||
|
"emit" "--x86" file flags)
|
||||||
|
;; The backend writes machine code, not mnemonics, so its .s is
|
||||||
|
;; `.byte' blobs. Assembling and disassembling is what makes it
|
||||||
|
;; readable -- and it is also a check that the bytes are well
|
||||||
|
;; formed, which reading them never would be.
|
||||||
|
(flan-lower--run o "as" "--64" "-o" o s)
|
||||||
|
(flan-lower--run dis "objdump" "-d" "--no-show-raw-insn" o)))
|
||||||
|
(let ((text (flan-lower--narrow (flan-lower--slurp dis)
|
||||||
|
(concat "<" sym ">:") "^$"))
|
||||||
|
(s (expand-file-name "out.x86.s" (flan-lower--scratch))))
|
||||||
|
(and text
|
||||||
|
(flan-lower--annotate-x86
|
||||||
|
text (and (file-exists-p s)
|
||||||
|
(flan-lower--srcmap (flan-lower--slurp s) name)))))))
|
||||||
|
(_ (error "no such section: %s" section)))))
|
||||||
|
|
||||||
|
(defun flan-lower--narrow (text start end)
|
||||||
|
"The run of TEXT from the line matching START to the line matching END.
|
||||||
|
Both lines are kept, which is what makes a function's closing brace and its
|
||||||
|
`.size' part of the listing rather than the start of the next one. Answers
|
||||||
|
nil when START never matches, which is what a name the file does not define
|
||||||
|
looks like."
|
||||||
|
(with-temp-buffer
|
||||||
|
(insert text)
|
||||||
|
(goto-char (point-min))
|
||||||
|
(when (re-search-forward start nil t)
|
||||||
|
(let ((beg (line-beginning-position)))
|
||||||
|
(forward-line 1)
|
||||||
|
(if (re-search-forward end nil t)
|
||||||
|
(buffer-substring-no-properties beg (line-beginning-position 2))
|
||||||
|
(buffer-substring-no-properties beg (point-max)))))))
|
||||||
|
|
||||||
|
(defun flan-lower--copies-from-compiler (name file)
|
||||||
|
"The copies of generic NAME that FILE makes, asked of `flan copies', or nil.
|
||||||
|
For when no daemon is attached to say; it is the same compiler run the other
|
||||||
|
sections already make, over the same file."
|
||||||
|
(when (and file (executable-find flan-lower-program))
|
||||||
|
(with-temp-buffer
|
||||||
|
(when (eq 0 (call-process flan-lower-program nil (list (current-buffer) nil)
|
||||||
|
nil "copies" file name))
|
||||||
|
(sort (split-string (buffer-string) "\n" t) #'string<)))))
|
||||||
|
|
||||||
|
(defun flan-lower--copies (name &optional file)
|
||||||
|
"The names of the copies of generic NAME the connected program has, or nil.
|
||||||
|
A generic has no code under its own name: each type it is called at makes a
|
||||||
|
copy named for the types, `selection-sort-i32'. The daemon lists the generic
|
||||||
|
with its signature as written, `$' and all, and lists each copy with the
|
||||||
|
generic's own location -- which is what tells a copy from an unrelated
|
||||||
|
function that happens to share the prefix, `sort-bytes' beside `sort'.
|
||||||
|
With no daemon that knows NAME, FILE is asked of the compiler instead."
|
||||||
|
(let ((g (assoc name flan--defs)))
|
||||||
|
(if g
|
||||||
|
(when (string-match-p "\\$" (nth 2 g))
|
||||||
|
(let ((prefix (concat name "-")))
|
||||||
|
(sort (mapcar #'car
|
||||||
|
(seq-filter
|
||||||
|
(lambda (d)
|
||||||
|
(and (string-prefix-p prefix (car d))
|
||||||
|
(equal (nth 1 d) "fn")
|
||||||
|
(equal (nth 3 d) (nth 3 g))))
|
||||||
|
flan--defs))
|
||||||
|
#'string<)))
|
||||||
|
(flan-lower--copies-from-compiler name file))))
|
||||||
|
|
||||||
|
(defun flan-lower--fetch-copies (section name)
|
||||||
|
"SECTION for each copy of generic NAME, each under a line naming it, or nil.
|
||||||
|
The copies are the session's, and the file may call the generic at fewer
|
||||||
|
types than the session does; a copy the file does not make is named as such
|
||||||
|
rather than left out."
|
||||||
|
(let ((copies (flan-lower--copies name flan-lower--file)))
|
||||||
|
(and copies
|
||||||
|
(mapconcat
|
||||||
|
(lambda (c)
|
||||||
|
(format ";; %s\n%s" c
|
||||||
|
(or (funcall flan-lower-fetch-function
|
||||||
|
section flan-lower--file c flan-lower--flags)
|
||||||
|
"not made by this file: nothing in it calls at these types\n")))
|
||||||
|
copies "\n"))))
|
||||||
|
|
||||||
|
(defun flan-lower--gather (sections)
|
||||||
|
"Fetch each of SECTIONS into `flan-lower--texts', replacing what was there.
|
||||||
|
One section's failure is that section's text and not the buffer's: `llc' can
|
||||||
|
be missing while the IR is perfectly readable, and a buffer that refuses
|
||||||
|
altogether would be the wrong answer to that."
|
||||||
|
(dolist (s sections)
|
||||||
|
(let ((text (condition-case err
|
||||||
|
(or (funcall flan-lower-fetch-function
|
||||||
|
s flan-lower--file flan-lower--name
|
||||||
|
flan-lower--flags)
|
||||||
|
(flan-lower--fetch-copies s flan-lower--name)
|
||||||
|
(format "nothing for `%s' here\n" flan-lower--name))
|
||||||
|
(error (concat (error-message-string err) "\n")))))
|
||||||
|
(setf (alist-get s flan-lower--texts) text))))
|
||||||
|
|
||||||
|
;;; Drawing it
|
||||||
|
|
||||||
|
(defun flan-lower--header (label text)
|
||||||
|
"Insert a header line naming LABEL with TEXT, wrapped under the label.
|
||||||
|
Wrapped by hand rather than with `fill-region', which is what the sibling
|
||||||
|
buffer uses: filling canonicalises runs of spaces, and every value here is a
|
||||||
|
path or a flag list whose columns are the point of it."
|
||||||
|
(let* ((start (point))
|
||||||
|
(indent "; ")
|
||||||
|
(lead (format "; %-11s " label))
|
||||||
|
(col (length lead))
|
||||||
|
(fresh t))
|
||||||
|
(insert lead)
|
||||||
|
(dolist (word (split-string (or text "") "[ \t\n]+" t))
|
||||||
|
(cond
|
||||||
|
(fresh (setq fresh nil))
|
||||||
|
((> (+ col 1 (length word)) 78)
|
||||||
|
(insert "\n" indent)
|
||||||
|
(setq col (length indent)))
|
||||||
|
(t (insert " ") (setq col (1+ col))))
|
||||||
|
(insert word)
|
||||||
|
(setq col (+ col (length word))))
|
||||||
|
(insert "\n")
|
||||||
|
(put-text-property start (point) 'face 'font-lock-comment-face)))
|
||||||
|
|
||||||
|
|
||||||
|
;; Enough highlighting to tell the three languages apart at a glance, and no
|
||||||
|
;; more. A major mode for each would be three modes to keep, and what is
|
||||||
|
;; wanted here is only that a register not read like a mnemonic.
|
||||||
|
(defconst flan-lower--ir-keywords
|
||||||
|
(regexp-opt '("define" "declare" "ret" "load" "store" "call" "br" "add"
|
||||||
|
"sub" "mul" "sdiv" "udiv" "srem" "icmp" "fcmp" "alloca"
|
||||||
|
"getelementptr" "phi" "select" "switch" "bitcast" "zext"
|
||||||
|
"sext" "trunc" "inttoptr" "ptrtoint" "unreachable" "tail"
|
||||||
|
"and" "or" "xor" "shl" "lshr" "ashr" "label")
|
||||||
|
'symbols))
|
||||||
|
|
||||||
|
(defconst flan-lower--ir-types
|
||||||
|
(regexp-opt '("i1" "i8" "i16" "i32" "i64" "ptr" "void" "float" "double")
|
||||||
|
'symbols))
|
||||||
|
|
||||||
|
(defun flan-lower--rules (section)
|
||||||
|
"Highlighting rules for SECTION, as an alist of regexp to face."
|
||||||
|
(pcase section
|
||||||
|
('ir `((,flan-lower--ir-keywords . font-lock-keyword-face)
|
||||||
|
(,flan-lower--ir-types . font-lock-type-face)
|
||||||
|
("[%@][-A-Za-z0-9_.\"$/]+" . font-lock-variable-name-face)
|
||||||
|
("^\\s-*;.*$" . font-lock-comment-face)))
|
||||||
|
('x86 `(("^ *[0-9a-f]+:" . shadow)
|
||||||
|
("<[^>\n]+>" . font-lock-function-name-face)
|
||||||
|
("%[a-z0-9]+" . font-lock-variable-name-face)
|
||||||
|
("\\$0x[0-9a-f]+" . font-lock-constant-face)
|
||||||
|
("#.*$" . font-lock-comment-face)))
|
||||||
|
(_ `(("^\\s-*\\.[a-zA-Z_0-9.]+" . font-lock-preprocessor-face)
|
||||||
|
("^[^ \t\n#][^ \t\n]*:" . font-lock-function-name-face)
|
||||||
|
("%[a-z0-9]+" . font-lock-variable-name-face)
|
||||||
|
("\\$-?[0-9]+\\|\\$0x[0-9a-f]+" . font-lock-constant-face)
|
||||||
|
("#.*$" . font-lock-comment-face)))))
|
||||||
|
|
||||||
|
(defun flan-lower--fontify (beg end section)
|
||||||
|
"Highlight BEG..END as SECTION's language.
|
||||||
|
Earlier rules win, which is why comments come last in every list: a `#' to
|
||||||
|
the end of the line is a comment whatever it holds, so it is painted over
|
||||||
|
whatever the rules above it found in there."
|
||||||
|
(save-excursion
|
||||||
|
(dolist (rule (flan-lower--rules section))
|
||||||
|
(goto-char beg)
|
||||||
|
(while (re-search-forward (car rule) end t)
|
||||||
|
(let ((s (match-beginning 0)) (e (match-end 0)))
|
||||||
|
;; An anchored rule can match the empty string, and a search that
|
||||||
|
;; does not move is a loop that does not end.
|
||||||
|
(if (= s e)
|
||||||
|
(unless (eobp) (forward-char 1))
|
||||||
|
(unless (get-text-property s 'face)
|
||||||
|
(put-text-property s e 'face (cdr rule)))))))))
|
||||||
|
|
||||||
|
(defun flan-lower--insert-section (id label)
|
||||||
|
"Insert the heading and body for section ID under LABEL."
|
||||||
|
(let* ((raw (or (alist-get id flan-lower--texts) ""))
|
||||||
|
;; Trimmed, because the blank line that ends an objdump function is
|
||||||
|
;; the narrowing's terminator rather than part of the listing, and a
|
||||||
|
;; count that included it would be one instruction out.
|
||||||
|
(text (if (string-empty-p (string-trim raw)) raw
|
||||||
|
(concat (string-trim-right raw "\n+") "\n")))
|
||||||
|
(lines (if (string-empty-p text) 0
|
||||||
|
(1- (length (split-string text "\n")))))
|
||||||
|
(open (alist-get id flan-lower--state))
|
||||||
|
(hbeg (point)))
|
||||||
|
(insert (if open "▾ " "▸ "))
|
||||||
|
(insert (propertize label 'face 'flan-lower-heading))
|
||||||
|
(insert (propertize (format " %d line%s" lines (if (= lines 1) "" "s"))
|
||||||
|
'face 'flan-lower-count))
|
||||||
|
(insert "\n")
|
||||||
|
(put-text-property hbeg (point) 'flan-lower-section id)
|
||||||
|
;; The blank line after the listing belongs to the body and not to the
|
||||||
|
;; gap between sections. That is what makes an open section breathe and a
|
||||||
|
;; buffer with everything shut four adjacent lines -- a summary, which is
|
||||||
|
;; the shape it is meant to have when it is closed.
|
||||||
|
(let ((bbeg (point)))
|
||||||
|
(insert text)
|
||||||
|
(unless (string-suffix-p "\n" text) (insert "\n"))
|
||||||
|
(flan-lower--fontify bbeg (point) id)
|
||||||
|
(insert "\n")
|
||||||
|
(put-text-property bbeg (point) 'flan-lower-section id))))
|
||||||
|
|
||||||
|
(defun flan-lower--draw ()
|
||||||
|
"Erase this buffer and write the header and the four sections into it."
|
||||||
|
(let ((inhibit-read-only t))
|
||||||
|
(erase-buffer)
|
||||||
|
(let ((start (point)))
|
||||||
|
(insert (format "; every lowering of %s\n" flan-lower--name))
|
||||||
|
(put-text-property start (point) 'face 'font-lock-comment-face))
|
||||||
|
(flan-lower--header "file" (abbreviate-file-name (or flan-lower--file "")))
|
||||||
|
(flan-lower--header "compiler" flan-lower-program)
|
||||||
|
(flan-lower--header "flags" (if flan-lower--flags
|
||||||
|
(string-join flan-lower--flags " ")
|
||||||
|
"none"))
|
||||||
|
;; The counterpart of `flan-disassemble's `showing' line, and it has to be
|
||||||
|
;; here for the same reason: four listings of a name look exactly like an
|
||||||
|
;; answer about the program, and this one is an answer about the file.
|
||||||
|
(flan-lower--header
|
||||||
|
"showing" "what this file compiles to, not what a running program is \
|
||||||
|
calling for this name -- for that, C-c C-a")
|
||||||
|
(insert "\n")
|
||||||
|
(pcase-dolist (`(,id . ,label) flan-lower--sections)
|
||||||
|
(flan-lower--insert-section id label))
|
||||||
|
(flan-lower--apply-state)
|
||||||
|
(set-buffer-modified-p nil)))
|
||||||
|
|
||||||
|
;;; Folding
|
||||||
|
|
||||||
|
(defun flan-lower--heading-bounds ()
|
||||||
|
"Bounds of the section whose heading point is on, as (HEAD-END . SUB-END)."
|
||||||
|
(let ((hend (line-end-position))
|
||||||
|
(send (save-excursion
|
||||||
|
(forward-line 1)
|
||||||
|
(if (re-search-forward flan-lower--heading-re nil t)
|
||||||
|
(1- (match-beginning 0))
|
||||||
|
(point-max)))))
|
||||||
|
(cons hend (max hend send))))
|
||||||
|
|
||||||
|
(defun flan-lower--apply-state ()
|
||||||
|
"Fold every section the way `flan-lower--state' says, arrows and all."
|
||||||
|
(let ((inhibit-read-only t)
|
||||||
|
(modified (buffer-modified-p)))
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (point-min))
|
||||||
|
(while (re-search-forward flan-lower--heading-re nil t)
|
||||||
|
(goto-char (match-beginning 0))
|
||||||
|
(let* ((id (get-text-property (point) 'flan-lower-section))
|
||||||
|
(open (alist-get id flan-lower--state))
|
||||||
|
(props (text-properties-at (point))))
|
||||||
|
;; The arrow is rewritten rather than redrawn with the rest, so the
|
||||||
|
;; properties that make it a heading have to be put back by hand:
|
||||||
|
;; inserted text inherits nothing the caller did not arrange.
|
||||||
|
(delete-char 1)
|
||||||
|
(insert (if open "▾" "▸"))
|
||||||
|
(set-text-properties (1- (point)) (point) props)
|
||||||
|
(goto-char (match-beginning 0))
|
||||||
|
(pcase-let ((`(,hend . ,send) (flan-lower--heading-bounds)))
|
||||||
|
(outline-flag-region hend send (not open))
|
||||||
|
;; Onwards from the end of this heading, so the next search does
|
||||||
|
;; not find the arrow that was just rewritten.
|
||||||
|
(goto-char hend)))))
|
||||||
|
(set-buffer-modified-p modified)))
|
||||||
|
|
||||||
|
(defun flan-lower--section-at-point ()
|
||||||
|
"The section point is in, heading or body, or nil above the first one."
|
||||||
|
(get-text-property (point) 'flan-lower-section))
|
||||||
|
|
||||||
|
(defun flan-lower--goto-section (id)
|
||||||
|
"Put point on section ID's heading, if it is here."
|
||||||
|
(let ((pos (save-excursion
|
||||||
|
(goto-char (point-min))
|
||||||
|
(catch 'found
|
||||||
|
(while (re-search-forward flan-lower--heading-re nil t)
|
||||||
|
(when (eq (get-text-property (match-beginning 0)
|
||||||
|
'flan-lower-section)
|
||||||
|
id)
|
||||||
|
(throw 'found (match-beginning 0))))
|
||||||
|
nil))))
|
||||||
|
(when pos (goto-char pos))))
|
||||||
|
|
||||||
|
(defun flan-lower-toggle (&optional event)
|
||||||
|
"Open or close the section point is in, or the one EVENT was over.
|
||||||
|
Above the first heading there is nothing to fold, so this moves to the first
|
||||||
|
section instead of doing nothing -- the same bargain `flan-cnr-tab' makes."
|
||||||
|
(interactive (list last-nonmenu-event))
|
||||||
|
(when (and event (listp event) (mouse-event-p event)) (mouse-set-point event))
|
||||||
|
(let ((id (flan-lower--section-at-point)))
|
||||||
|
(if (null id)
|
||||||
|
(outline-next-visible-heading 1)
|
||||||
|
(setf (alist-get id flan-lower--state) (not (alist-get id flan-lower--state)))
|
||||||
|
;; Point may be inside a body that is about to be hidden, and a point
|
||||||
|
;; in invisible text is a cursor that appears to have vanished.
|
||||||
|
(flan-lower--goto-section id)
|
||||||
|
(flan-lower--apply-state))))
|
||||||
|
|
||||||
|
(defun flan-lower--set-all (open)
|
||||||
|
"Open every section if OPEN, else close every one."
|
||||||
|
(pcase-dolist (`(,id . ,_) flan-lower--sections)
|
||||||
|
(setf (alist-get id flan-lower--state) open))
|
||||||
|
(let ((id (flan-lower--section-at-point)))
|
||||||
|
(when (and id (not open)) (flan-lower--goto-section id)))
|
||||||
|
(flan-lower--apply-state))
|
||||||
|
|
||||||
|
(defun flan-lower-collapse-all ()
|
||||||
|
"Close every section, leaving the four names and their line counts."
|
||||||
|
(interactive)
|
||||||
|
(flan-lower--set-all nil))
|
||||||
|
|
||||||
|
(defun flan-lower-expand-all ()
|
||||||
|
"Open every section."
|
||||||
|
(interactive)
|
||||||
|
(flan-lower--set-all t))
|
||||||
|
|
||||||
|
(defun flan-lower-cycle-all ()
|
||||||
|
"Close everything if anything is open, and otherwise open everything."
|
||||||
|
(interactive)
|
||||||
|
(flan-lower--set-all
|
||||||
|
(not (seq-some (lambda (s) (alist-get (car s) flan-lower--state))
|
||||||
|
flan-lower--sections))))
|
||||||
|
|
||||||
|
;;; Refreshing
|
||||||
|
|
||||||
|
(defun flan-lower--position ()
|
||||||
|
"Where point is, as (SECTION . LINE-WITHIN-IT), for putting it back."
|
||||||
|
(let ((id (flan-lower--section-at-point)))
|
||||||
|
(when id
|
||||||
|
(cons id (count-lines
|
||||||
|
(or (save-excursion (flan-lower--goto-section id) (point))
|
||||||
|
(point-min))
|
||||||
|
(line-beginning-position))))))
|
||||||
|
|
||||||
|
(defun flan-lower--restore (pos screen-line)
|
||||||
|
"Put point back at POS and the window back at SCREEN-LINE."
|
||||||
|
(if pos
|
||||||
|
(when (flan-lower--goto-section (car pos))
|
||||||
|
(forward-line (cdr pos)))
|
||||||
|
;; Point was in the header, above every section. The top is where it was
|
||||||
|
;; and the top is where it goes back to; leaving it wherever the redraw
|
||||||
|
;; finished would put it at the end of the buffer, which is a worse jump
|
||||||
|
;; than the one this whole function exists to avoid.
|
||||||
|
(goto-char (point-min)))
|
||||||
|
;; Guarded because under `emacs -batch' there is no window at all, and an
|
||||||
|
;; unguarded `set-window-start' would be a failure with nothing to do with
|
||||||
|
;; what was being refreshed.
|
||||||
|
(when-let ((win (and screen-line (get-buffer-window (current-buffer)))))
|
||||||
|
(set-window-start win (save-excursion
|
||||||
|
(vertical-motion (- screen-line))
|
||||||
|
(point)))))
|
||||||
|
|
||||||
|
(defun flan-lower--redraw (sections)
|
||||||
|
"Re-fetch SECTIONS and draw the buffer again, keeping point where it was."
|
||||||
|
(let* ((pos (flan-lower--position))
|
||||||
|
(win (get-buffer-window (current-buffer)))
|
||||||
|
;; How far down the window point is sitting, so that a redraw is a
|
||||||
|
;; redraw and not a jump to the top of a listing being read.
|
||||||
|
(screen-line (and win (count-screen-lines (window-start win) (point)))))
|
||||||
|
(flan-lower--gather sections)
|
||||||
|
(flan-lower--draw)
|
||||||
|
(flan-lower--restore pos screen-line)))
|
||||||
|
|
||||||
|
(defun flan-lower-refresh ()
|
||||||
|
"Compile the file again and redraw all four sections."
|
||||||
|
(interactive)
|
||||||
|
(flan-lower--clean)
|
||||||
|
(setq flan-lower--texts nil)
|
||||||
|
(flan-lower--redraw (mapcar #'car flan-lower--sections)))
|
||||||
|
|
||||||
|
(defun flan-lower-refresh-section ()
|
||||||
|
"Compile and redraw only the section point is in.
|
||||||
|
Worth its own key because the four are not the same price: the IR is the
|
||||||
|
frontend alone, and `llc -O2' over a whole program's worth of it is the one
|
||||||
|
that is felt."
|
||||||
|
(interactive)
|
||||||
|
(let ((id (flan-lower--section-at-point)))
|
||||||
|
(unless id (user-error "flan: point is not in a section"))
|
||||||
|
;; Only this section's intermediate goes; the IR everything is downstream
|
||||||
|
;; of stays, which is the whole saving.
|
||||||
|
;; The IR is what the other three are made from, so refreshing it drops
|
||||||
|
;; their intermediates too -- they are not redrawn here, but the next `r'
|
||||||
|
;; on one of them must not answer out of a file the old IR produced.
|
||||||
|
(dolist (f (pcase id
|
||||||
|
('ir '("out.ll" "out.dbg.ll" "out.O0.s" "out.O2.s"
|
||||||
|
"out.x86.s" "out.x86.o" "out.x86.dis"))
|
||||||
|
('O0 '("out.O0.s"))
|
||||||
|
('O2 '("out.O2.s"))
|
||||||
|
('x86 '("out.x86.s" "out.x86.o" "out.x86.dis"))))
|
||||||
|
(let ((p (expand-file-name f (flan-lower--scratch))))
|
||||||
|
(when (file-exists-p p) (delete-file p))))
|
||||||
|
(flan-lower--redraw (list id))))
|
||||||
|
|
||||||
|
;;; The mode
|
||||||
|
|
||||||
|
(defvar flan-lower-mode-map
|
||||||
|
(let ((map (make-sparse-keymap)))
|
||||||
|
(define-key map (kbd "TAB") #'flan-lower-toggle)
|
||||||
|
(define-key map (kbd "RET") #'flan-lower-toggle)
|
||||||
|
(define-key map [mouse-1] #'flan-lower-toggle)
|
||||||
|
(define-key map [backtab] #'flan-lower-cycle-all)
|
||||||
|
(define-key map "c" #'flan-lower-collapse-all)
|
||||||
|
(define-key map "e" #'flan-lower-expand-all)
|
||||||
|
;; `n' and `p' move between the buffer's own units, the way they do in
|
||||||
|
;; `flan-inspect-mode' and `flan-cnr-mode'. Here the unit is a section.
|
||||||
|
(define-key map "n" #'outline-next-visible-heading)
|
||||||
|
(define-key map "p" #'outline-previous-visible-heading)
|
||||||
|
(define-key map "g" #'flan-lower-refresh)
|
||||||
|
(define-key map "r" #'flan-lower-refresh-section)
|
||||||
|
(define-key map "q" #'quit-window)
|
||||||
|
map)
|
||||||
|
"Keys in `flan-lower-mode'.")
|
||||||
|
|
||||||
|
(flan-evil-own-keys 'flan-lower-mode-map)
|
||||||
|
|
||||||
|
(define-derived-mode flan-lower-mode special-mode "flan-lower"
|
||||||
|
"Every lowering of one Flan function, in foldable sections.
|
||||||
|
|
||||||
|
\\{flan-lower-mode-map}"
|
||||||
|
(setq buffer-read-only t)
|
||||||
|
(setq-local truncate-lines t)
|
||||||
|
;; Set before the minor mode goes on, because that is when it reads them.
|
||||||
|
(setq-local outline-regexp "[▸▾] ")
|
||||||
|
(setq-local outline-level (lambda () 1))
|
||||||
|
(outline-minor-mode 1)
|
||||||
|
;; Minor-mode bindings take precedence over this mode's map. Outline owns
|
||||||
|
;; TAB by default, so give this buffer its intended folding keys back
|
||||||
|
;; without changing Outline's bindings anywhere else.
|
||||||
|
(let ((map (copy-keymap outline-minor-mode-map)))
|
||||||
|
(define-key map (kbd "TAB") #'flan-lower-toggle)
|
||||||
|
(define-key map [backtab] #'flan-lower-cycle-all)
|
||||||
|
(setq-local minor-mode-overriding-map-alist
|
||||||
|
(cons (cons 'outline-minor-mode map)
|
||||||
|
(assq-delete-all 'outline-minor-mode
|
||||||
|
minor-mode-overriding-map-alist))))
|
||||||
|
(add-hook 'kill-buffer-hook #'flan-lower--clean nil t))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun flan-lowering (name &optional file)
|
||||||
|
"Show every lowering of NAME in FILE: the IR, -O0, -O2, and the x86 backend.
|
||||||
|
|
||||||
|
FILE defaults to the file the current buffer is visiting. NAME is the Flan
|
||||||
|
one -- `step', not `flan.step' -- and a packaged function is written the way
|
||||||
|
the program names it, `sim/settle'.
|
||||||
|
|
||||||
|
What this shows is what FILE compiles to today, which is not the same claim
|
||||||
|
as `flan-disassemble' (\\[flan-disassemble]): that one asks the running program what the body
|
||||||
|
it is calling for a name actually came out as, and only the daemon can
|
||||||
|
answer it. The two cannot be merged, because the daemon has the installed
|
||||||
|
body's IR and its object and has never run either `llc -O2' or the x86
|
||||||
|
backend over it.
|
||||||
|
|
||||||
|
Which sections are open is remembered for the session, by section rather
|
||||||
|
than by function: asking for a different name leaves whichever of the four
|
||||||
|
was being read open."
|
||||||
|
(interactive
|
||||||
|
(list (or (thing-at-point 'symbol t)
|
||||||
|
(completing-read
|
||||||
|
"Lowerings of: "
|
||||||
|
(flan--compiled-names)
|
||||||
|
nil nil nil nil
|
||||||
|
(and (fboundp 'flan-current-defun-name)
|
||||||
|
(flan-current-defun-name))))
|
||||||
|
(when current-prefix-arg
|
||||||
|
(read-file-name "Lowerings from file: " nil nil t))))
|
||||||
|
(let ((src (or file buffer-file-name)))
|
||||||
|
(unless src
|
||||||
|
(user-error "flan: no file to compile; visit one or give it a file"))
|
||||||
|
(with-current-buffer (get-buffer-create flan-lower-buffer)
|
||||||
|
(unless (derived-mode-p 'flan-lower-mode) (flan-lower-mode))
|
||||||
|
;; A new name means new intermediates only if the file changed; the
|
||||||
|
;; narrowing is done here, so the same file's IR is reused across names.
|
||||||
|
(unless (equal flan-lower--file (expand-file-name src))
|
||||||
|
(flan-lower--clean))
|
||||||
|
(setq flan-lower--file (expand-file-name src)
|
||||||
|
flan-lower--name name
|
||||||
|
flan-lower--flags flan-lower-flags
|
||||||
|
flan-lower--texts nil)
|
||||||
|
(flan-lower--gather (mapcar #'car flan-lower--sections))
|
||||||
|
(flan-lower--draw)
|
||||||
|
(goto-char (point-min)))
|
||||||
|
(display-buffer flan-lower-buffer)))
|
||||||
|
|
||||||
|
(provide 'flan-lower)
|
||||||
|
;;; flan-lower.el ends here
|
||||||
+489
-62
@@ -1,5 +1,24 @@
|
|||||||
;;; flan-mode.el --- Major mode for Flan -*- lexical-binding: t; -*-
|
;;; flan-mode.el --- Major mode for Flan -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Author: Joseph Ferano <joseph@ferano.io>
|
||||||
|
;; Version: 0.1.0
|
||||||
|
;; Package-Requires: ((emacs "29.1"))
|
||||||
|
;; Keywords: languages, lisp, tools
|
||||||
|
|
||||||
|
;; The headers above are what make this directory installable. M-x
|
||||||
|
;; package-install-file on it reads them, and a file with no Version: is not a
|
||||||
|
;; package as far as package.el is concerned -- until now the client was
|
||||||
|
;; reachable only by adding it to load-path by hand, which is a thing to
|
||||||
|
;; explain to every person who wants to try it.
|
||||||
|
;;
|
||||||
|
;; 29.1 is the floor because it is the oldest Emacs any of this has been run
|
||||||
|
;; against, not because some function here is known to need it. dape, which
|
||||||
|
;; flan-dape drives, asks for 29.1 as well and is a soft dependency: it is
|
||||||
|
;; reached through declare-function, so the rest of the client loads and works
|
||||||
|
;; without it and it is deliberately not listed above. The compiler this talks
|
||||||
|
;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md
|
||||||
|
;; says what has to be on PATH.
|
||||||
|
|
||||||
;; Derived from `prog-mode', borrowing `lisp-mode''s machinery for the parts
|
;; Derived from `prog-mode', borrowing `lisp-mode''s machinery for the parts
|
||||||
;; that are simply s-expressions: sexp motion, paren matching and
|
;; that are simply s-expressions: sexp motion, paren matching and
|
||||||
;; `beginning-of-defun' already do the right thing.
|
;; `beginning-of-defun' already do the right thing.
|
||||||
@@ -52,48 +71,148 @@
|
|||||||
|
|
||||||
;; The keymap binds them, but do not load the client merely to edit a file.
|
;; The keymap binds them, but do not load the client merely to edit a file.
|
||||||
;; These must be real autoloads, not just `declare-function`s: otherwise a
|
;; These must be real autoloads, not just `declare-function`s: otherwise a
|
||||||
;; user who has loaded only flan-mode cannot invoke M-x flan-dev at all.
|
;; user who has loaded only flan-mode cannot invoke M-x flan at all.
|
||||||
(autoload 'flan-eval-defun "flan-dev" nil t)
|
(autoload 'flan-eval-defun "flan" nil t)
|
||||||
(autoload 'flan-eval-buffer "flan-dev" nil t)
|
(autoload 'flan-eval-buffer "flan" nil t)
|
||||||
(autoload 'flan-eval-last-sexp "flan-dev" nil t)
|
(autoload 'flan-eval-last-sexp "flan" nil t)
|
||||||
(autoload 'flan-connect "flan-dev" nil t)
|
(autoload 'flan-connect "flan" nil t)
|
||||||
(autoload 'flan-disconnect "flan-dev" nil t)
|
(autoload 'flan-disconnect "flan" nil t)
|
||||||
(autoload 'flan-describe "flan-dev" nil t)
|
(autoload 'flan-describe "flan" nil t)
|
||||||
(autoload 'flan-show-output "flan-dev" nil t)
|
(autoload 'flan-how-to-rebuild "flan" nil t)
|
||||||
(autoload 'flan-repl "flan-repl" nil t)
|
(autoload 'flan-repl "flan-repl" nil t)
|
||||||
(autoload 'flan-break "flan-dev" nil t)
|
(autoload 'flan-repl-clear "flan-repl" nil t)
|
||||||
|
(autoload 'flan-repl-clear-output "flan-repl" nil t)
|
||||||
|
(autoload 'flan-break "flan" nil t)
|
||||||
;; The two CIDER-shaped buffers. They reach the daemon through an indirection
|
;; The two CIDER-shaped buffers. They reach the daemon through an indirection
|
||||||
;; of their own so that fixtures can drive them, so autoloading is all the
|
;; of their own so that fixtures can drive them, so autoloading is all the
|
||||||
;; wiring they need.
|
;; wiring they need.
|
||||||
(autoload 'flan-inspect "flan-inspect" nil t)
|
(autoload 'flan-inspect "flan-inspect" nil t)
|
||||||
(autoload 'flan-cnr-show "flan-cnr" nil t)
|
(autoload 'flan-cnr-show "flan-cnr" nil t)
|
||||||
(autoload 'flan-doc "flan-dev" nil t)
|
(autoload 'flan-step-defun "flan" nil t)
|
||||||
(autoload 'flan-dev "flan-dev" nil t)
|
(autoload 'flan-doc "flan" nil t)
|
||||||
(autoload 'flan-dev-quit "flan-dev" nil t)
|
(autoload 'flan "flan" nil t)
|
||||||
(autoload 'flan-dev-restart-program "flan-dev" nil t)
|
(autoload 'flan-quit "flan" nil t)
|
||||||
|
;; The images: several at once, one current, and a list to pick from.
|
||||||
|
(autoload 'flan-switch-image "flan" nil t)
|
||||||
|
(autoload 'flan-list-images "flan" nil t)
|
||||||
|
(autoload 'flan-run "flan" nil t)
|
||||||
|
;; And the cheap counterpart, which needs an autoload for the reason above and
|
||||||
|
;; more than most: it is the command someone reaches for the moment a window
|
||||||
|
;; closes, which can be the first thing they ever ask the client to do.
|
||||||
|
(autoload 'flan-rerun "flan" nil t)
|
||||||
|
(autoload 'flan-interrupt "flan" nil t)
|
||||||
;; Bound below, like the rest, and it was the one missing an autoload.
|
;; Bound below, like the rest, and it was the one missing an autoload.
|
||||||
(autoload 'flan-disassemble "flan-dev" nil t)
|
(autoload 'flan-disassemble "flan" nil t)
|
||||||
|
;; The other question about the same function, and the reason it is a second
|
||||||
|
;; command rather than a fifth argument to the first: `flan-disassemble' asks
|
||||||
|
;; the running program, and this compiles the file.
|
||||||
|
(autoload 'flan-lowering "flan-lower" nil t)
|
||||||
;; C-c C-m and the half of it that is findable by name rather than by a
|
;; C-c C-m and the half of it that is findable by name rather than by a
|
||||||
;; modifier. Real autoloads for the reason stated above: a `declare-function'
|
;; modifier. Real autoloads for the reason stated above: a `declare-function'
|
||||||
;; would leave M-x with nothing to load.
|
;; would leave M-x with nothing to load.
|
||||||
(autoload 'flan-macroexpand "flan-dev" nil t)
|
(autoload 'flan-macroexpand "flan" nil t)
|
||||||
(autoload 'flan-macroexpand-all "flan-dev" nil t)
|
(autoload 'flan-macroexpand-all "flan" nil t)
|
||||||
|
|
||||||
(defgroup flan nil
|
(defgroup flan nil
|
||||||
"Editing and evaluating Flan."
|
"Editing and evaluating Flan."
|
||||||
:group 'languages
|
:group 'languages
|
||||||
:prefix "flan-")
|
:prefix "flan-")
|
||||||
|
|
||||||
|
;; Both lists are read off `Parse.decl' and `Parse.form' (lib/parse.ml), which
|
||||||
|
;; are where the two questions are actually decided: a head `decl' has an arm
|
||||||
|
;; for introduces a name, and a head `form' has an arm for is never a call.
|
||||||
|
;; Kept whole rather than topped up one name at a time — the list that is
|
||||||
|
;; patched only when somebody notices a gap is the list that is always a
|
||||||
|
;; release behind the parser.
|
||||||
(defconst flan--definers
|
(defconst flan--definers
|
||||||
'("defn" "defvar" "defconst" "defstruct" "defunion" "defenum" "defalias"
|
'("defn" "defn-" "defmacro" "def" "defonce" "defconst" "defstruct" "defdata" "defunion"
|
||||||
"declare" "import" "package")
|
"defenum" "defalias"
|
||||||
|
;; The object and dispatch heads (lib/parse.ml:1277-1334).
|
||||||
|
"defclass" "defgeneric" "defmulti" "defmethod"
|
||||||
|
"declare" "declare-c" "import" "package")
|
||||||
"Forms that introduce a top-level name.")
|
"Forms that introduce a top-level name.")
|
||||||
|
|
||||||
(defconst flan--special
|
(defconst flan--special
|
||||||
'("let" "if" "do" "while" "until" "dotimes" "loop" "match" "set" "return"
|
'("quote" "do" "let" "if" "if-let" "when" "cond" "and" "or"
|
||||||
"defer" "some" "none" "try" "zeroed" "uninit" "slice" "at" "len" "addr"
|
"while" "until" "break" "continue" "return" "set"
|
||||||
"bytes" "cast" "true" "false" "nil" "print" "println")
|
"array" "array-fill" "array-gen" "the" "match" "fn" "dotimes" "loop" "recur"
|
||||||
"Forms with meaning to the checker.")
|
"defer" "some" "try" "signal" "error"
|
||||||
|
"handler-bind" "handler-case" "restart-case" "invoke-restart")
|
||||||
|
"The heads `Parse.form' dispatches on — the forms with a meaning of their own.
|
||||||
|
|
||||||
|
Not functions, which is the line this list draws: `and' does not evaluate its
|
||||||
|
second argument unless it has to and `quote' evaluates none of its, while
|
||||||
|
everything in `flan--builtins' below is an ordinary call. They used to be one
|
||||||
|
list and were drawn alike, which said they were the same kind of thing.
|
||||||
|
|
||||||
|
Two groups of real heads are deliberately left out. `quasiquote', `unquote'
|
||||||
|
and `unquote-splicing' are never written as words — the reader makes them out
|
||||||
|
of \=`, ~ and ~@, and the sigils are not symbols for a keyword rule to reach.
|
||||||
|
`find-restart', `compute-restarts', `errdefer' and `await' the parser
|
||||||
|
recognises only in order to refuse them, and drawing those as keywords would
|
||||||
|
advertise four forms that cannot be used.
|
||||||
|
|
||||||
|
`until' is a macro in the prelude and not a head of `Parse.form'. It stays
|
||||||
|
here because it is control flow a reader takes for `while', which is what this
|
||||||
|
face says.")
|
||||||
|
|
||||||
|
(defconst flan--builtins
|
||||||
|
'(;; arithmetic, comparison, bits
|
||||||
|
"+" "-" "*" "/" "%" "=" "!=" "<" "<=" ">" ">=" "not"
|
||||||
|
"bit-and" "bit-or" "bit-xor" "bit-not" "&&" "||" "^^" "<<" ">>"
|
||||||
|
"rotate-left" "rotate-right" "popcount" "leading-zeros" "trailing-zeros"
|
||||||
|
"min" "max"
|
||||||
|
;; the fill patterns
|
||||||
|
"zeroed" "filled" "dead-beef"
|
||||||
|
;; allocators
|
||||||
|
"make-allocator" "allocator-from" "allocator" "heap-allocator"
|
||||||
|
"arena-new" "arena-destroy" "free-all" "free-temp" "can-free" "can-free-all"
|
||||||
|
"alloc-epoch" "alloc-id" "alloc-budget" "set-alloc-budget"
|
||||||
|
"alloc-live-blocks" "with-allocator"
|
||||||
|
;; Vec
|
||||||
|
"vec-new" "reserve" "free" "clone"
|
||||||
|
;; String
|
||||||
|
"string-new" "bytes->string" "append" "runes"
|
||||||
|
"char-count" "byte-length" "char-at" "byte-at" "byte-slice"
|
||||||
|
;; Map
|
||||||
|
"map-new" "map-next"
|
||||||
|
;; collections
|
||||||
|
"put" "get" "remove" "remove-at" "insert" "pop" "pop-front" "remove-last" "clear" "copy" "fill"
|
||||||
|
;; dyn
|
||||||
|
"class-of" "type-of" "keyword"
|
||||||
|
;; compile time
|
||||||
|
"embed" "embed-dir" "compile-error"
|
||||||
|
;; files
|
||||||
|
"slurp" "barf" "delete-file" "make-directory" "rename-file"
|
||||||
|
;; containers and memory
|
||||||
|
"length" "at" "slice" "slice-from" "addr" "deref"
|
||||||
|
;; options, bytes, the host
|
||||||
|
"Some" "bytes" "bytes-view" "str" "char"
|
||||||
|
"bytes->f64" "bytes->i64" "f64->bytes" "i64->bytes"
|
||||||
|
"write-stdout" "print" "prin" "exit" "argv")
|
||||||
|
"The functions the compiler provides, from `lib/check.ml''s `builtins' table.
|
||||||
|
|
||||||
|
Ordinary calls — nothing here is special to the parser — so they are drawn as
|
||||||
|
builtins and not as keywords. `str' and `char' are in this list and in the
|
||||||
|
type rule below and mean a different thing in each: `(str b)' converts and a
|
||||||
|
bare `str' names a type, which the rules tell apart by the paren.
|
||||||
|
|
||||||
|
`destructure~nth' is in the table and not here: the compiler writes it into a
|
||||||
|
destructuring `let' and nobody types it.
|
||||||
|
|
||||||
|
The randomness functions, the string and sequence functions and everything
|
||||||
|
else in `lib/prelude.ml' are deliberately absent. They are ordinary Flan
|
||||||
|
written in Flan, the running program answers for them by name, and listing
|
||||||
|
them here would be a second copy of the prelude to keep in step.")
|
||||||
|
|
||||||
|
(defconst flan--constants
|
||||||
|
'("true" "false" "nil" "None" "context/allocator" "context/temp" "uninit")
|
||||||
|
"Names that stand for themselves rather than being called.
|
||||||
|
|
||||||
|
Matched as bare symbols, which is how they are written: nobody types `(true)',
|
||||||
|
so a paren-anchored rule would never see one. `uninit' is here for the same
|
||||||
|
reason and is the odd one — it is legal only as the last item of a `def' or a
|
||||||
|
`defonce', where it says the storage is left as it was found.")
|
||||||
|
|
||||||
(defvar flan-font-lock-keywords
|
(defvar flan-font-lock-keywords
|
||||||
`((,(concat "(" (regexp-opt flan--definers t) "\\_>"
|
`((,(concat "(" (regexp-opt flan--definers t) "\\_>"
|
||||||
@@ -101,21 +220,66 @@
|
|||||||
(1 font-lock-keyword-face)
|
(1 font-lock-keyword-face)
|
||||||
(2 font-lock-function-name-face nil t))
|
(2 font-lock-function-name-face nil t))
|
||||||
(,(concat "(" (regexp-opt flan--special t) "\\_>") 1 font-lock-keyword-face)
|
(,(concat "(" (regexp-opt flan--special t) "\\_>") 1 font-lock-keyword-face)
|
||||||
|
;; The builtins are deliberately not drawn. clojure-mode leaves `map',
|
||||||
|
;; `filter' and the rest of the core library plain and spends
|
||||||
|
;; `font-lock-builtin-face' only on the earmuffed dynamic variables, and a
|
||||||
|
;; buffer reads better for it: `at', `push' and `print' are the ordinary
|
||||||
|
;; vocabulary of a program, and colouring the ordinary leaves nothing for
|
||||||
|
;; the unusual. `flan--builtins' is still the list completion and the
|
||||||
|
;; dynamic rules check against, so nothing else has to know this.
|
||||||
|
;;
|
||||||
|
;; Ahead of the qualified-name rule below, which would otherwise take
|
||||||
|
;; `context/' in `context/allocator' for a package alias. It is not one:
|
||||||
|
;; there is no package called `context', and the slash is part of the name.
|
||||||
|
(,(concat "\\_<" (regexp-opt flan--constants t) "\\_>")
|
||||||
|
1 font-lock-constant-face)
|
||||||
;; A keyword resolves against an enum at the call site, so it reads as a
|
;; A keyword resolves against an enum at the call site, so it reads as a
|
||||||
;; constant rather than as a string.
|
;; constant rather than as a string. `:where', the one key a `defn''s
|
||||||
|
;; constraint map accepts, is covered by the same rule.
|
||||||
("\\_<:\\(?:\\sw\\|\\s_\\)+" . font-lock-constant-face)
|
("\\_<:\\(?:\\sw\\|\\s_\\)+" . font-lock-constant-face)
|
||||||
;; A field. The label in a struct literal — `{.x 1.0}' — and the accessor
|
;; A field — the label in `{.x 1.0}' and the accessor in `(.x v)' — is left
|
||||||
;; `(.x v)' are the same name and are drawn the same way. Without this
|
;; plain, for the reason the builtins are: it is part of reading the
|
||||||
;; rule every field label in the corpus is unfontified, which is what the
|
;; program, not part of reading the language. clojure-mode draws Java
|
||||||
;; colon-to-dot change left behind: the keyword rule above used to cover
|
;; interop the same way.
|
||||||
;; them and no longer does, because the colon belongs to keywords now.
|
;;
|
||||||
("\\_<\\.\\(?:\\sw\\|\\s_\\)+" . font-lock-constant-face)
|
;; The package half of a qualified name — the `rl/' of `rl/draw-text'.
|
||||||
;; The machine types, which are ordinary symbols but never anything else.
|
;; Drawn as a type the way clojure-mode draws a namespace, so the eye can
|
||||||
("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|string\\|Unit\\|Never\\|Ptr\\|Option\\)\\_>"
|
;; split the package from the name without reading either. The leading
|
||||||
|
;; letter keeps `:foo/bar' keywords and a bare `/' out of it. It sits
|
||||||
|
;; after the constants rule above on purpose: `context/allocator' has a
|
||||||
|
;; slash and is not a qualified name — there is no package called
|
||||||
|
;; `context' — and font-lock leaves text that is already drawn alone.
|
||||||
|
("\\_<\\([a-zA-Z][a-zA-Z0-9!?*+=<>._-]*/\\)" 1 font-lock-type-face)
|
||||||
|
;; The types the compiler knows without being told: every primitive in
|
||||||
|
;; `Types.primitive_names', plus the four applied ones the checker
|
||||||
|
;; resolves and the two function types, `Fn' and `CFn'. `dyn' is
|
||||||
|
;; lowercase on purpose — it is a primitive beside `i64' and `bool', not
|
||||||
|
;; a container over something.
|
||||||
|
;; `int' and `float' are builtin aliases for `i32' and `f32'. `const'
|
||||||
|
;; is the reserved word of the read-only slice type, `[const u8]', and is
|
||||||
|
;; drawn as part of the type it spells.
|
||||||
|
;;
|
||||||
|
;; `Unit' is deliberately absent, though `Types.primitive_names' has it.
|
||||||
|
;; The resolver answers to the name because `Cimport' builds one for C's
|
||||||
|
;; void, but nothing anyone writes reaches that: `Parse.texpr' refuses the
|
||||||
|
;; word outright — unit is spelled `()'. Drawing it as a valid type would
|
||||||
|
;; advertise a spelling the parser rejects, which is the same reason
|
||||||
|
;; `find-restart' and `await' are left out of `flan--special'.
|
||||||
|
("\\_<\\(?:[iu]\\(?:8\\|16\\|32\\|64\\)\\|f\\(?:32\\|64\\)\\|bool\\|char\\|str\\|dyn\\|const\\|int\\|float\\|Never\\|Allocator\\|String\\|Ptr\\|Option\\|Vec\\|Map\\|C?Fn\\)\\_>"
|
||||||
. font-lock-type-face)
|
. font-lock-type-face)
|
||||||
("\\_<\\(?:0x[0-9a-fA-F]+\\|-?[0-9]+\\(?:\\.[0-9]+\\)?\\)\\_>"
|
;; A type variable, `$t', which is what a generic `defn' names its
|
||||||
. font-lock-constant-face))
|
;; parameter types with and what `{:where (is-ordered $t)}' constrains.
|
||||||
"Font lock for `flan-mode'.")
|
("\\_<\\$\\(?:\\sw\\|\\s_\\)*" . font-lock-type-face))
|
||||||
|
;; A number is not drawn. clojure-mode has no rule for one either: a
|
||||||
|
;; literal is already unmistakable by shape, and a colour on every integer
|
||||||
|
;; in a program full of indices is noise.
|
||||||
|
"Font lock for `flan-mode'.
|
||||||
|
Every rule here is about the language itself, so a file that has never been
|
||||||
|
near a running program is drawn completely. What a *particular program*
|
||||||
|
defines is a separate question, and `flan.el' answers it — see
|
||||||
|
`flan-font-lock-dynamically' — by adding rules after these ones. After, and
|
||||||
|
never over: a name that is a special form or a builtin keeps the face these
|
||||||
|
rules gave it whatever the program happens to call its own functions.")
|
||||||
|
|
||||||
(defconst flan--name-re "\\(\\(?:\\sw\\|\\s_\\)+\\)"
|
(defconst flan--name-re "\\(\\(?:\\sw\\|\\s_\\)+\\)"
|
||||||
"A Flan name, as one group.
|
"A Flan name, as one group.
|
||||||
@@ -127,14 +291,34 @@ below — and not again here.")
|
|||||||
;; `defn' nested inside a `let' is not a definition of anything, and a match
|
;; `defn' nested inside a `let' is not a definition of anything, and a match
|
||||||
;; that ignored the column would offer one.
|
;; that ignored the column would offer one.
|
||||||
(defvar flan-imenu-generic-expression
|
(defvar flan-imenu-generic-expression
|
||||||
`(("Functions" ,(concat "^(defn\\s-+" flan--name-re) 1)
|
;; `defgeneric', `defmulti' and `defmethod' are here with `defn': all four
|
||||||
("Types" ,(concat "^(def\\(?:struct\\|union\\|enum\\|alias\\)\\s-+"
|
;; introduce something you call, and which of them declared a name is not
|
||||||
flan--name-re)
|
;; the question an index is being asked. A method is listed by the generic
|
||||||
|
;; it implements, which is the name in the same place, so a file of several
|
||||||
|
;; methods shows that name several times — the honest answer, and better
|
||||||
|
;; than listing none of them as it did.
|
||||||
|
`(("Functions" ,(concat "^(def\\(?:n-?\\|generic\\|multi\\|method\\)\\s-+"
|
||||||
|
flan--name-re)
|
||||||
1)
|
1)
|
||||||
("Variables" ,(concat "^(def\\(?:var\\|const\\)\\s-+" flan--name-re) 1)
|
;; Its own heading rather than a second `Functions' entry: a macro runs at
|
||||||
|
;; compile time and a function at run time, and an index that drew them
|
||||||
|
;; alike would be hiding the one difference that matters about them.
|
||||||
|
("Macros" ,(concat "^(defmacro\\s-+" flan--name-re) 1)
|
||||||
|
;; `defclass' with the other type declarations: it names a shape, and a
|
||||||
|
;; reader looking for where `Sprite' is defined does not first have to
|
||||||
|
;; decide whether it was spelled as a struct or as a class.
|
||||||
|
("Types"
|
||||||
|
,(concat "^(def\\(?:struct\\|data\\|union\\|enum\\|alias\\|class\\)\\s-+"
|
||||||
|
flan--name-re)
|
||||||
|
1)
|
||||||
|
;; `def', `defonce' and `defconst'. `def' has to be matched as itself —
|
||||||
|
;; `\_>' keeps it from swallowing every other definer's prefix.
|
||||||
|
("Variables" ,(concat "^(def\\(?:once\\|const\\)?\\_>\\s-+" flan--name-re) 1)
|
||||||
;; A forward declaration is not a definition, and a file with both would
|
;; A forward declaration is not a definition, and a file with both would
|
||||||
;; otherwise show the same name twice with nothing to tell them apart.
|
;; otherwise show the same name twice with nothing to tell them apart.
|
||||||
("Declared" ,(concat "^(declare\\s-+" flan--name-re) 1))
|
;; `declare-c' as well as `declare': it declares a name the same way and
|
||||||
|
;; differs only in generating the C shim that reaches it.
|
||||||
|
("Declared" ,(concat "^(declare\\(?:-c\\)?\\s-+" flan--name-re) 1))
|
||||||
"Imenu index for `flan-mode', by what each form introduces.")
|
"Imenu index for `flan-mode', by what each form introduces.")
|
||||||
|
|
||||||
(defun flan-current-defun-name ()
|
(defun flan-current-defun-name ()
|
||||||
@@ -157,6 +341,18 @@ line is off screen."
|
|||||||
(modify-syntax-entry ?/ "_" table)
|
(modify-syntax-entry ?/ "_" table)
|
||||||
(modify-syntax-entry ?. "_" table)
|
(modify-syntax-entry ?. "_" table)
|
||||||
(modify-syntax-entry ?- "_" table)
|
(modify-syntax-entry ?- "_" table)
|
||||||
|
;; `$t' is a type variable and `&' is the rest marker in an array pattern.
|
||||||
|
;; The reader's rule is that a name is anything up to a delimiter (see
|
||||||
|
;; `is_delimiter' in `lib/reader.ml'), and neither of these is one, so both
|
||||||
|
;; are part of the name they sit in and `M-.' on `$t' should not stop at
|
||||||
|
;; the sigil.
|
||||||
|
(modify-syntax-entry ?$ "_" table)
|
||||||
|
(modify-syntax-entry ?& "_" table)
|
||||||
|
;; A comma is whitespace, exactly as it is in Clojure and for the same
|
||||||
|
;; reason: `lib/reader.ml' skips it wherever a space would go, so `[a 1, b
|
||||||
|
;; 2]' and `[a 1 b 2]' are the same vector. Saying so here is what lets
|
||||||
|
;; sexp motion and the indenter step over one without a case for it.
|
||||||
|
(modify-syntax-entry ?, " " table)
|
||||||
;; [ ] and { } are brackets, not symbol characters: every binding list and
|
;; [ ] and { } are brackets, not symbol characters: every binding list and
|
||||||
;; every type is written with them.
|
;; every type is written with them.
|
||||||
(modify-syntax-entry ?\[ "(]" table)
|
(modify-syntax-entry ?\[ "(]" table)
|
||||||
@@ -166,16 +362,114 @@ line is off screen."
|
|||||||
table)
|
table)
|
||||||
"Syntax table for `flan-mode'.")
|
"Syntax table for `flan-mode'.")
|
||||||
|
|
||||||
(defvar flan-mode-map
|
;;; The discard reader macro
|
||||||
|
|
||||||
|
;; `#_' reads the form after it and throws it away (lib/reader.ml:16-24,
|
||||||
|
;; 202-262), which is how a form is commented out without counting its closing
|
||||||
|
;; parens. The table above knows nothing about it — it comes from
|
||||||
|
;; `lisp-mode-syntax-table', and Common Lisp has no such construct — so a
|
||||||
|
;; discarded form used to render as ordinary code, which is the one thing it
|
||||||
|
;; must not look like.
|
||||||
|
;;
|
||||||
|
;; The fix is `clojure-mode's, which has the same reader macro and the same
|
||||||
|
;; problem: a `syntax-propertize-function' that gives the span the comment
|
||||||
|
;; syntax class. Font lock then draws it as a comment with no rule of its own,
|
||||||
|
;; and every other thing that reads syntax classes — `forward-comment',
|
||||||
|
;; `comment-only-p', a package that skips comments — agrees for free.
|
||||||
|
;;
|
||||||
|
;; Generic comment fences (the `!' class) rather than a line comment, because a
|
||||||
|
;; discarded form is a region and may be one line or twenty. The `#' is the
|
||||||
|
;; opening fence and the last character of the form is the closing one, so
|
||||||
|
;; everything in between is inside a comment and is no longer read as
|
||||||
|
;; structure. That is the reader's own answer, and it leaves the *enclosing*
|
||||||
|
;; list's parens alone: only the discarded form's own last delimiter changes
|
||||||
|
;; class, so `(a #_(b c) d)' still balances.
|
||||||
|
|
||||||
|
(defun flan--discard-end (pos)
|
||||||
|
"Where the discard whose form starts at POS ends, or nil.
|
||||||
|
|
||||||
|
The reader's rule rather than a count: a discard reads *a form*, and reading
|
||||||
|
one skips leading discards of its own, so `#_#_ a b' throws away both a and b
|
||||||
|
with nothing ever counting to two (lib/reader.ml:202-262). Written as the
|
||||||
|
loop that recursion amounts to — every `#_' seen owes one more form — since
|
||||||
|
the walk over the buffer is the same either way.
|
||||||
|
|
||||||
|
Nil when a form is unfinished, which is every buffer halfway through being
|
||||||
|
typed: nothing is propertized then, rather than `#_(' greying out the rest of
|
||||||
|
the file while the parenthesis is still open."
|
||||||
|
(let ((owed 1)
|
||||||
|
;; The scan must not consult the properties it is being run to
|
||||||
|
;; compute: with `parse-sexp-lookup-properties' on, `forward-sexp'
|
||||||
|
;; would ask for the syntax of positions this pass has not reached.
|
||||||
|
;; The table alone is enough — the nesting is counted here, and
|
||||||
|
;; strings and escapes are the table's own business.
|
||||||
|
(parse-sexp-lookup-properties nil))
|
||||||
|
(ignore-errors
|
||||||
|
(save-excursion
|
||||||
|
(goto-char pos)
|
||||||
|
(while (> owed 0)
|
||||||
|
(forward-comment (buffer-size))
|
||||||
|
(if (looking-at-p "#_")
|
||||||
|
(progn (forward-char 2) (setq owed (1+ owed)))
|
||||||
|
(forward-sexp)
|
||||||
|
(setq owed (1- owed))))
|
||||||
|
;; `forward-sexp' at the end of the buffer stays put rather than
|
||||||
|
;; signalling, so a trailing `#_' with nothing after it would otherwise
|
||||||
|
;; come back as a span covering only itself — a two-character comment
|
||||||
|
;; drawn over the reader's one real discard error. It is unfinished
|
||||||
|
;; like any other, and answers nil like any other.
|
||||||
|
(and (> (point) pos) (point))))))
|
||||||
|
|
||||||
|
(defun flan--syntax-propertize (start end)
|
||||||
|
"Mark every `#_' discard between START and END as a comment.
|
||||||
|
For `syntax-propertize-function'."
|
||||||
|
(goto-char start)
|
||||||
|
(while (search-forward "#_" end t)
|
||||||
|
;; Both ends of the match are read off point before anything else runs, and
|
||||||
|
;; the `syntax-ppss' below is wrapped: it moves point and clobbers the
|
||||||
|
;; match data, so asking it first and reading the match afterwards is how
|
||||||
|
;; this would come to scan from the `#' instead of from the form — and how
|
||||||
|
;; a `#_' it declined would be found again, forever, at the same place.
|
||||||
|
(let* ((beg (- (point) 2))
|
||||||
|
(from (point))
|
||||||
|
;; `#_' written inside a string, or inside a `;' comment, is text
|
||||||
|
;; and not a reader macro. One inside a span an earlier discard
|
||||||
|
;; already covers is not reached at all: that discard's own scan
|
||||||
|
;; consumed it, and point jumps past the whole span below.
|
||||||
|
(quoted (save-excursion (nth 8 (syntax-ppss beg))))
|
||||||
|
(fin (and (not quoted) (flan--discard-end from))))
|
||||||
|
(when fin
|
||||||
|
(put-text-property beg (1+ beg)
|
||||||
|
'syntax-table (string-to-syntax "!"))
|
||||||
|
(put-text-property (1- fin) fin
|
||||||
|
'syntax-table (string-to-syntax "!"))
|
||||||
|
;; So that a change *inside* a discarded form re-propertizes from the
|
||||||
|
;; `#_' rather than from the line it was typed on; the other half is
|
||||||
|
;; `syntax-propertize-multiline' in the mode body.
|
||||||
|
(put-text-property beg fin 'syntax-multiline t))
|
||||||
|
;; Past the span when there was one, and past the `#_' when there was
|
||||||
|
;; not. Either way forward, which is the whole of why this terminates.
|
||||||
|
(goto-char (or fin from)))))
|
||||||
|
|
||||||
|
;; The keys both syntaxes share: everything that talks to the running program
|
||||||
|
;; about a name, a value or the session rather than about a piece of the text.
|
||||||
|
;; The keys that pick text out of the buffer -- which form C-c C-c means --
|
||||||
|
;; are each child mode's own, because what a form is differs between them.
|
||||||
|
(defvar flan-base-mode-map
|
||||||
(let ((map (make-sparse-keymap)))
|
(let ((map (make-sparse-keymap)))
|
||||||
;; Autoloaded from flan-dev.el, so the client loads on first use.
|
;; Autoloaded from flan.el, so the client loads on first use.
|
||||||
(define-key map (kbd "C-c C-c") #'flan-eval-defun)
|
|
||||||
(define-key map (kbd "C-c C-k") #'flan-eval-buffer)
|
(define-key map (kbd "C-c C-k") #'flan-eval-buffer)
|
||||||
(define-key map (kbd "C-x C-e") #'flan-eval-last-sexp)
|
;; The stepper: the defn at point, installed to stop before each form.
|
||||||
|
(define-key map (kbd "C-c C-s") #'flan-step-defun)
|
||||||
(define-key map (kbd "C-c C-z") #'flan-connect)
|
(define-key map (kbd "C-c C-z") #'flan-connect)
|
||||||
(define-key map (kbd "C-c C-q") #'flan-disconnect)
|
(define-key map (kbd "C-c C-q") #'flan-disconnect)
|
||||||
(define-key map (kbd "C-c C-d") #'flan-describe)
|
(define-key map (kbd "C-c C-d") #'flan-describe)
|
||||||
(define-key map (kbd "C-c C-o") #'flan-show-output)
|
;; The REPL's two clears, reachable from the file being edited: results
|
||||||
|
;; land in *flan-repl* whichever buffer the send came from, so the keys
|
||||||
|
;; that take them down belong here too. CIDER's pair: C-c C-o for the
|
||||||
|
;; last send's output, C-c M-o for the whole transcript.
|
||||||
|
(define-key map (kbd "C-c C-o") #'flan-repl-clear-output)
|
||||||
|
(define-key map (kbd "C-c M-o") #'flan-repl-clear)
|
||||||
(define-key map (kbd "C-c C-r") #'flan-repl)
|
(define-key map (kbd "C-c C-r") #'flan-repl)
|
||||||
;; C-c C-b opens the buffer rather than the minibuffer prompt: it shows the
|
;; C-c C-b opens the buffer rather than the minibuffer prompt: it shows the
|
||||||
;; same restarts plus the condition and the stack, and — the reason it
|
;; same restarts plus the condition and the stack, and — the reason it
|
||||||
@@ -195,35 +489,77 @@ line is off screen."
|
|||||||
;; IR it was built from. C-u for the IR rather than a second key: it is
|
;; IR it was built from. C-u for the IR rather than a second key: it is
|
||||||
;; the same question asked of the same body.
|
;; the same question asked of the same body.
|
||||||
(define-key map (kbd "C-c C-a") #'flan-disassemble)
|
(define-key map (kbd "C-c C-a") #'flan-disassemble)
|
||||||
|
;; Every lowering of the name at point -- the IR, `llc' at -O0 and at -O2,
|
||||||
|
;; and the hand-written x86 backend -- in one buffer of folding sections.
|
||||||
|
;; Beside C-c C-a and not under it: that one answers for the program that
|
||||||
|
;; is running, this one for the file on disk, and no prefix argument can
|
||||||
|
;; make one of those into the other.
|
||||||
|
(define-key map (kbd "C-c C-l") #'flan-lowering)
|
||||||
;; What the macro call before point expands to. CIDER's key, and `C-u' for
|
;; What the macro call before point expands to. CIDER's key, and `C-u' for
|
||||||
;; the fixpoint rather than a second one — the same question asked of the
|
;; the fixpoint rather than a second one — the same question asked of the
|
||||||
;; same form, which is the rule `C-c C-a' above already follows. One step
|
;; same form, which is the rule `C-c C-a' above already follows. One step
|
||||||
;; is the bare key because it is the one that can name the macro that ran:
|
;; is the bare key because it is the one that can name the macro that ran:
|
||||||
;; a full expansion is stamped with the outermost name only.
|
;; a full expansion is stamped with the outermost name only.
|
||||||
(define-key map (kbd "C-c C-m") #'flan-macroexpand)
|
(define-key map (kbd "C-c C-m") #'flan-macroexpand)
|
||||||
;; The way out when a reload is refused: rebuild, relaunch, reconnect.
|
;; Run the image's `main' again, in the process that is already there,
|
||||||
(define-key map (kbd "C-c C-x") #'flan-dev-restart-program)
|
;; with the globals as the finished run left them.
|
||||||
|
(define-key map (kbd "C-c C-M-x") #'flan-rerun)
|
||||||
|
;; Stop the running image where it is (SLIME's interrupt). C-c C-b is the
|
||||||
|
;; conditions buffer here, so the interrupt sits with the other C-M keys.
|
||||||
|
(define-key map (kbd "C-c C-M-i") #'flan-interrupt)
|
||||||
|
;; An image has no file of its own to rebuild from, so this key only says
|
||||||
|
;; how a rebuild is done. Bound rather than left free, because hands that
|
||||||
|
;; learned it would otherwise get "C-c C-x is undefined" and nothing more.
|
||||||
|
(define-key map (kbd "C-c C-x") #'flan-how-to-rebuild)
|
||||||
|
map)
|
||||||
|
"Keymap for every Flan source buffer, `flan-mode' and `flan-fln-mode'.")
|
||||||
|
|
||||||
|
(defvar flan-mode-map
|
||||||
|
(let ((map (make-sparse-keymap)))
|
||||||
|
(set-keymap-parent map flan-base-mode-map)
|
||||||
|
(define-key map (kbd "C-c C-c") #'flan-eval-defun)
|
||||||
|
;; The same command on the binding SLIME and CIDER put it on. Emacs binds
|
||||||
|
;; C-M-x to eval-defun only in `emacs-lisp-mode-map', so a mode derived
|
||||||
|
;; from `lisp-mode' inherits nothing and the key is undefined — which
|
||||||
|
;; reads as the client being broken rather than as the key being free.
|
||||||
|
(define-key map (kbd "C-M-x") #'flan-eval-defun)
|
||||||
|
(define-key map (kbd "C-x C-e") #'flan-eval-last-sexp)
|
||||||
map)
|
map)
|
||||||
"Keymap for `flan-mode'.")
|
"Keymap for `flan-mode'.")
|
||||||
|
|
||||||
|
;; The parent of both source modes. Everything the dev loop asks of a buffer
|
||||||
|
;; -- is this Flan, set up eldoc and completion, draw the program's names,
|
||||||
|
;; paint watched values -- asks it of this mode, so a .fln buffer gets it the
|
||||||
|
;; same way a .flan buffer does. What each syntax reads as a form is its
|
||||||
|
;; child's business.
|
||||||
|
(define-derived-mode flan-base-mode prog-mode "Flan"
|
||||||
|
"Parent mode of the Flan source modes, `flan-mode' and `flan-fln-mode'."
|
||||||
|
(setq-local comment-start ";")
|
||||||
|
(setq-local comment-start-skip ";+ *")
|
||||||
|
(setq-local comment-add 1)
|
||||||
|
;; Spaces. The whole corpus is written with them, and alignment that is
|
||||||
|
;; correct here is alignment under a specific *column* — a tab makes that
|
||||||
|
;; depend on a setting the file cannot carry. In a .fln file a tab in the
|
||||||
|
;; indentation is an error besides.
|
||||||
|
(setq-local indent-tabs-mode nil))
|
||||||
|
|
||||||
;;;###autoload
|
;;;###autoload
|
||||||
(define-derived-mode flan-mode prog-mode "Flan"
|
(define-derived-mode flan-mode flan-base-mode "Flan"
|
||||||
"Major mode for editing Flan.
|
"Major mode for editing Flan.
|
||||||
|
|
||||||
\\{flan-mode-map}"
|
\\{flan-mode-map}"
|
||||||
:syntax-table flan-mode-syntax-table
|
:syntax-table flan-mode-syntax-table
|
||||||
(setq-local comment-start ";")
|
|
||||||
(setq-local comment-start-skip ";+ *")
|
|
||||||
(setq-local comment-add 1)
|
|
||||||
(setq-local font-lock-defaults '(flan-font-lock-keywords))
|
(setq-local font-lock-defaults '(flan-font-lock-keywords))
|
||||||
(setq-local indent-line-function #'lisp-indent-line)
|
(setq-local indent-line-function #'lisp-indent-line)
|
||||||
;; Spaces. The whole corpus is written with them, and alignment that is
|
|
||||||
;; correct here is alignment under a specific *column* — a tab makes that
|
|
||||||
;; depend on a setting the file cannot carry.
|
|
||||||
(setq-local indent-tabs-mode nil)
|
|
||||||
(setq-local lisp-indent-function #'flan-indent-function)
|
(setq-local lisp-indent-function #'flan-indent-function)
|
||||||
(setq-local outline-regexp ";;;;+[ \t]*")
|
(setq-local outline-regexp ";;;;+[ \t]*")
|
||||||
(setq-local imenu-generic-expression flan-imenu-generic-expression)
|
(setq-local imenu-generic-expression flan-imenu-generic-expression)
|
||||||
|
;; `#_' — see the section above the syntax table.
|
||||||
|
(setq-local syntax-propertize-function #'flan--syntax-propertize)
|
||||||
|
;; A discarded form spans as many lines as it likes, so the region handed to
|
||||||
|
;; the propertizer has to be widened back to the `#_' that owns it.
|
||||||
|
(add-hook 'syntax-propertize-extend-region-functions
|
||||||
|
#'syntax-propertize-multiline nil t)
|
||||||
;; Buffer-locally, because this answers for Flan and nothing else.
|
;; Buffer-locally, because this answers for Flan and nothing else.
|
||||||
(add-hook 'which-func-functions #'flan-current-defun-name nil t))
|
(add-hook 'which-func-functions #'flan-current-defun-name nil t))
|
||||||
|
|
||||||
@@ -244,11 +580,20 @@ line is off screen."
|
|||||||
("let" . 1)
|
("let" . 1)
|
||||||
("loop" . 1)
|
("loop" . 1)
|
||||||
("dotimes" . 1)
|
("dotimes" . 1)
|
||||||
|
;; An anonymous function: the parameter vector, then the body. `defn'
|
||||||
|
;; without the name, and it indents like `let' rather than like `defn'
|
||||||
|
;; because there is no optional return type to be vague about.
|
||||||
|
("fn" . 1)
|
||||||
;; The clause vector, then the protected body. Same shape as `let'.
|
;; The clause vector, then the protected body. Same shape as `let'.
|
||||||
("handler-bind" . 1)
|
("handler-bind" . 1)
|
||||||
|
;; `handler-case' is the other way round — the body first and the clause
|
||||||
|
;; vector after it — but the entry is the same number, because what it
|
||||||
|
;; says is that one argument is special and the rest indent as a body,
|
||||||
|
;; and that is true of both orders.
|
||||||
("handler-case" . 1)
|
("handler-case" . 1)
|
||||||
;; Test first, body after.
|
;; Test first, body after.
|
||||||
("if" . 1)
|
("if" . 1)
|
||||||
|
("if-let" . 1)
|
||||||
("when" . 1)
|
("when" . 1)
|
||||||
("unless" . 1)
|
("unless" . 1)
|
||||||
("while" . 1)
|
("while" . 1)
|
||||||
@@ -260,6 +605,9 @@ line is off screen."
|
|||||||
;; on the head's line — `(restart-case (middle n)' — would drag every
|
;; on the head's line — `(restart-case (middle n)' — would drag every
|
||||||
;; clause out to align under it.
|
;; clause out to align under it.
|
||||||
("restart-case" . 1)
|
("restart-case" . 1)
|
||||||
|
;; The condition, then the struct literal that carries its fields.
|
||||||
|
("signal" . 1)
|
||||||
|
("error" . 1)
|
||||||
;; All body.
|
;; All body.
|
||||||
("do" . 0)
|
("do" . 0)
|
||||||
("cond" . 0)
|
("cond" . 0)
|
||||||
@@ -269,17 +617,54 @@ line is off screen."
|
|||||||
;; the parameters and the body is optional; a count would have to know
|
;; the parameters and the body is optional; a count would have to know
|
||||||
;; whether one is there, and `:defn' does not care.
|
;; whether one is there, and `:defn' does not care.
|
||||||
("defn" . :defn)
|
("defn" . :defn)
|
||||||
|
("defn-" . :defn)
|
||||||
;; `(declare-c NAME [params] RET "CSymbol")'. The name is the one special
|
;; `(declare-c NAME [params] RET "CSymbol")'. The name is the one special
|
||||||
;; argument; everything after it is written down the page in one column.
|
;; argument; everything after it is written down the page in one column.
|
||||||
("declare" . 1)
|
("declare" . 1)
|
||||||
("declare-c" . 1))
|
("declare-c" . 1))
|
||||||
"How each form indents, by name.
|
"How each form indents, by name.
|
||||||
Anything not named here that begins with `def' is treated as `:defn' by
|
A qualified name falls back to the entry for its unqualified part. Anything
|
||||||
`flan-indent-function'; anything else indents as a function call.")
|
still unnamed that begins with `def' (but not `default') or `with-' indents as
|
||||||
|
`:defn' in `flan-indent-function'; anything else indents as a function call.")
|
||||||
|
|
||||||
(defun flan--indent-spec (name)
|
(defun flan--indent-spec (name)
|
||||||
"The indent spec for the form called NAME, or nil."
|
"The indent spec for the form called NAME, or nil.
|
||||||
(and name (cdr (assoc name flan-indent-specs))))
|
A qualified name falls back to its unqualified part, so `rl/when' would find
|
||||||
|
the entry for `when' — `clojure--get-indent-method' does the same."
|
||||||
|
(and name
|
||||||
|
(cdr (or (assoc name flan-indent-specs)
|
||||||
|
(and (string-match "/\\([^/]+\\)\\'" name)
|
||||||
|
(assoc (match-string 1 name) flan-indent-specs))))))
|
||||||
|
|
||||||
|
(defun flan--definer-p (name)
|
||||||
|
"Non-nil if NAME indents as a definition or a `with-' form.
|
||||||
|
Either may be qualified: `rl/with-drawing' is a `with-' form. This is
|
||||||
|
`clojure-indent-function''s fallback for a head with no spec, regexp and all;
|
||||||
|
`default…' is excluded there because it is not a definer, and here too."
|
||||||
|
(and name
|
||||||
|
(string-match "\\`\\(?:\\S +/\\)?\\(def[a-z]*\\|with-\\)" name)
|
||||||
|
(not (string-match-p "\\`default" (match-string 1 name)))))
|
||||||
|
|
||||||
|
(defconst flan--labelled-forms '("dotimes" "while" "until")
|
||||||
|
"Loops that may carry a label, which `break' and `continue' name.
|
||||||
|
`loop' is deliberately not here: it refuses a label, because a loop answers
|
||||||
|
with the value of its body and there is nothing for a jump out of one to
|
||||||
|
give. See `lib/parse.ml'.")
|
||||||
|
|
||||||
|
(defun flan--label-p (name)
|
||||||
|
"Non-nil if the form called NAME, at point, carries a label.
|
||||||
|
Point is on the head. A label is a keyword written where the binding vector
|
||||||
|
or the test would otherwise go — `(dotimes :outer [i 3] …)' — and it pushes
|
||||||
|
everything after it along by one, so the count of special arguments has to
|
||||||
|
know about it. Without this a labelled loop indented its body under its own
|
||||||
|
binding vector, which is where `test/programs/loops.flan' would have said so
|
||||||
|
if anything had been indenting it."
|
||||||
|
(and (member name flan--labelled-forms)
|
||||||
|
(save-excursion
|
||||||
|
(ignore-errors
|
||||||
|
(flan--forward-sexp 1) ; over the head
|
||||||
|
(skip-chars-forward " \t\n\r")
|
||||||
|
(eq (char-after) ?:)))))
|
||||||
|
|
||||||
(defun flan--non-logical-sexp-p ()
|
(defun flan--non-logical-sexp-p ()
|
||||||
"Non-nil if what follows point is read but produces no form.
|
"Non-nil if what follows point is read but produces no form.
|
||||||
@@ -421,12 +806,15 @@ decision to `calculate-lisp-indent'."
|
|||||||
(head-column (1- (current-column))))
|
(head-column (1- (current-column))))
|
||||||
(cond
|
(cond
|
||||||
((integerp method)
|
((integerp method)
|
||||||
(flan--count-indent method indent-point last-sexp head-column))
|
(flan--count-indent (if (flan--label-p name) (1+ method) method)
|
||||||
|
indent-point last-sexp head-column))
|
||||||
((eq method :defn) (+ lisp-body-indent head-column))
|
((eq method :defn) (+ lisp-body-indent head-column))
|
||||||
;; No spec. Anything else spelled `def…' is a definition and indents
|
;; No spec. Anything else spelled `def…' is a definition and indents
|
||||||
;; like one, which covers `defstruct', `defunion', `defenum', `defvar',
|
;; like one, which covers `defstruct', `defdata', `defunion',
|
||||||
;; `defconst' and `defalias' without naming them.
|
;; `defenum', `defonce', `defconst' and `defalias' without naming
|
||||||
((and name (string-match-p "\\`def" name))
|
;; them. A `with-' form is a body too — `rl/with-drawing',
|
||||||
|
;; `rl/with-mode-2d camera' — whatever it takes before the body.
|
||||||
|
((flan--definer-p name)
|
||||||
(+ lisp-body-indent head-column))
|
(+ lisp-body-indent head-column))
|
||||||
;; A clause: `(name [params] body…)'. `handler-bind', `handler-case'
|
;; A clause: `(name [params] body…)'. `handler-bind', `handler-case'
|
||||||
;; and `restart-case' all write their clauses this way, and the head is
|
;; and `restart-case' all write their clauses this way, and the head is
|
||||||
@@ -445,6 +833,45 @@ decision to `calculate-lisp-indent'."
|
|||||||
|
|
||||||
;;;###autoload
|
;;;###autoload
|
||||||
(add-to-list 'auto-mode-alist '("\\.flan\\'" . flan-mode))
|
(add-to-list 'auto-mode-alist '("\\.flan\\'" . flan-mode))
|
||||||
|
;; The indented syntax's mode lives in its own file; a buffer of it is the first
|
||||||
|
;; thing that loads it.
|
||||||
|
;;;###autoload
|
||||||
|
(autoload 'flan-fln-mode "flan-fln-mode" nil t)
|
||||||
|
;;;###autoload
|
||||||
|
(add-to-list 'auto-mode-alist '("\\.fln\\'" . flan-fln-mode))
|
||||||
|
|
||||||
|
;;; The other Flan buffers under Evil
|
||||||
|
|
||||||
|
;; Evil's normal state binds most single keys — the digits, RET, TAB, n, p, q,
|
||||||
|
;; g — above any major mode's map, so in a buffer of Flan's own a key its mode
|
||||||
|
;; binds would move point, start a count or record a macro instead. Each such
|
||||||
|
;; buffer's mode gives the keys its own map binds to Evil's normal and motion
|
||||||
|
;; states, so they do the same thing under Evil as without it. Only those
|
||||||
|
;; keys: the maps inherit `special-mode-map', and making one an overriding map
|
||||||
|
;; would carry h, SPC, < and - over from there as well. Every key a mode does
|
||||||
|
;; not bind itself stays Evil's.
|
||||||
|
|
||||||
|
(declare-function evil-define-key* "evil-core" (state keymap key def &rest bindings))
|
||||||
|
|
||||||
|
(defun flan-evil-own-keys (name)
|
||||||
|
"Give the keys the map named NAME binds itself to Evil's states.
|
||||||
|
Normal and motion. Takes effect when Evil is loaded, or at once if it
|
||||||
|
already is.
|
||||||
|
|
||||||
|
The map is passed by name because `eval-after-load' drops a function
|
||||||
|
`equal' to one it already holds, and two maps with the same bindings are
|
||||||
|
`equal': given the maps, only the first of them would be set up."
|
||||||
|
(with-eval-after-load 'evil
|
||||||
|
(when (fboundp 'evil-define-key*)
|
||||||
|
;; Collected first, and without the parent's bindings, because
|
||||||
|
;; `evil-define-key*' writes into the map being walked.
|
||||||
|
(let ((map (symbol-value name))
|
||||||
|
(own nil))
|
||||||
|
(map-keymap-internal (lambda (key def)
|
||||||
|
(when (commandp def) (push (cons key def) own)))
|
||||||
|
map)
|
||||||
|
(dolist (b own)
|
||||||
|
(evil-define-key* '(normal motion) map (vector (car b)) (cdr b)))))))
|
||||||
|
|
||||||
(provide 'flan-mode)
|
(provide 'flan-mode)
|
||||||
;;; flan-mode.el ends here
|
;;; flan-mode.el ends here
|
||||||
+312
-28
@@ -1,5 +1,24 @@
|
|||||||
;;; flan-repl.el --- A prompt for a running Flan program -*- lexical-binding: t; -*-
|
;;; flan-repl.el --- A prompt for a running Flan program -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Author: Joseph Ferano <joseph@ferano.io>
|
||||||
|
;; Version: 0.1.0
|
||||||
|
;; Package-Requires: ((emacs "29.1"))
|
||||||
|
;; Keywords: languages, lisp, tools
|
||||||
|
|
||||||
|
;; The headers above are what make this directory installable. M-x
|
||||||
|
;; package-install-file on it reads them, and a file with no Version: is not a
|
||||||
|
;; package as far as package.el is concerned -- until now the client was
|
||||||
|
;; reachable only by adding it to load-path by hand, which is a thing to
|
||||||
|
;; explain to every person who wants to try it.
|
||||||
|
;;
|
||||||
|
;; 29.1 is the floor because it is the oldest Emacs any of this has been run
|
||||||
|
;; against, not because some function here is known to need it. dape, which
|
||||||
|
;; flan-dape drives, asks for 29.1 as well and is a soft dependency: it is
|
||||||
|
;; reached through declare-function, so the rest of the client loads and works
|
||||||
|
;; without it and it is deliberately not listed above. The compiler this talks
|
||||||
|
;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md
|
||||||
|
;; says what has to be on PATH.
|
||||||
|
|
||||||
;; A buffer to type expressions at, sent to the program `flan dev' is running
|
;; A buffer to type expressions at, sent to the program `flan dev' is running
|
||||||
;; and answered with the value they had *there*. It adds no protocol and no
|
;; and answered with the value they had *there*. It adds no protocol and no
|
||||||
;; compiler support: every line goes through the same `eval-expr' request that
|
;; compiler support: every line goes through the same `eval-expr' request that
|
||||||
@@ -18,31 +37,68 @@
|
|||||||
;; for it, because the file says which package it belongs to; a prompt has no
|
;; for it, because the file says which package it belongs to; a prompt has no
|
||||||
;; file and nothing to derive it from.
|
;; file and nothing to derive it from.
|
||||||
;;
|
;;
|
||||||
;; - **A value and the program's output are different things** and arrive by
|
;; - **A value and the program's output are different things**, and both are
|
||||||
;; different routes. The value of the expression appears at the prompt;
|
;; here. The value of the expression appears at the prompt; anything the
|
||||||
;; anything the program printed while evaluating it goes to *flan-output*,
|
;; program printed while evaluating it — riding along on the same reply —
|
||||||
;; riding along on the same reply. Showing them in one place would be
|
;; is inserted above it, output first, then the value, the way a terminal
|
||||||
;; convenient and wrong.
|
;; REPL reads. The daemon's buffer (*flan: NAME*) mirrors the output, so it is
|
||||||
|
;; still somewhere when no prompt is open.
|
||||||
|
;;
|
||||||
|
;; When a compile fails, the prompt gets one line — "1 error — see
|
||||||
|
;; *flan-diagnostics*" — and the message itself goes to the diagnostics
|
||||||
|
;; list, which pops up. The full Elm-style error is worth a buffer with
|
||||||
|
;; navigation; the prompt is not that buffer.
|
||||||
|
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(require 'comint)
|
(require 'comint)
|
||||||
(require 'flan-mode)
|
(require 'flan-mode)
|
||||||
(require 'flan-dev)
|
(require 'flan-fln-mode)
|
||||||
|
(require 'flan)
|
||||||
|
|
||||||
(defcustom flan-repl-buffer "*flan-repl*"
|
(defcustom flan-repl-buffer "*flan-repl*"
|
||||||
"Name of the Flan REPL buffer."
|
"Name of the Flan REPL buffer.
|
||||||
|
Each image has its own, named after it: \"*flan-repl: NAME*\"."
|
||||||
:type 'string
|
:type 'string
|
||||||
:group 'flan)
|
:group 'flan)
|
||||||
|
|
||||||
|
(defcustom flan-repl-history-file (locate-user-emacs-file "flan-repl-history")
|
||||||
|
"File the prompt's input history is kept in between sessions.
|
||||||
|
`locate-user-emacs-file' rather than a path of this file's own choosing: it
|
||||||
|
follows `user-emacs-directory', which is what `no-littering' and anyone who
|
||||||
|
has moved their state elsewhere have already redirected. nil keeps history
|
||||||
|
for the session only."
|
||||||
|
:type '(choice file (const :tag "Do not keep history between sessions" nil))
|
||||||
|
:group 'flan)
|
||||||
|
|
||||||
|
(defcustom flan-repl-history-size 500
|
||||||
|
"How many inputs the prompt remembers."
|
||||||
|
:type 'integer
|
||||||
|
:group 'flan)
|
||||||
|
|
||||||
|
(defconst flan-repl--history-separator "\n\f\n"
|
||||||
|
"What separates two entries in the history file.
|
||||||
|
Comint separates them with a newline, which is also what is *inside* a form
|
||||||
|
typed over several lines: written that way, one such form comes back as
|
||||||
|
several broken ones. A form feed alone on a line cannot occur inside a form,
|
||||||
|
so the file survives the round trip.
|
||||||
|
Let-bound around each call rather than set in the buffer, because
|
||||||
|
`comint-write-input-ring' reads this variable inside a temporary buffer where
|
||||||
|
a buffer-local value is not visible.")
|
||||||
|
|
||||||
(defvar flan-repl-prompt "flan> "
|
(defvar flan-repl-prompt "flan> "
|
||||||
"Prompt shown in `flan-repl-mode'.")
|
"Prompt shown in `flan-repl-mode'.")
|
||||||
|
|
||||||
(defvar flan-repl-mode-map
|
(defvar flan-repl-mode-map
|
||||||
(let ((map (make-sparse-keymap)))
|
(let ((map (make-sparse-keymap)))
|
||||||
(define-key map (kbd "C-c C-o") #'flan-show-output)
|
;; The two clears, on CIDER's keys: C-c C-o takes down what the last send
|
||||||
|
;; printed, C-c M-o takes the whole transcript.
|
||||||
|
(define-key map (kbd "C-c C-o") #'flan-repl-clear-output)
|
||||||
|
(define-key map (kbd "C-c M-o") #'flan-repl-clear)
|
||||||
(define-key map (kbd "C-c C-d") #'flan-describe)
|
(define-key map (kbd "C-c C-d") #'flan-describe)
|
||||||
(define-key map (kbd "C-c C-q") #'flan-disconnect)
|
(define-key map (kbd "C-c C-q") #'flan-disconnect)
|
||||||
|
(define-key map (kbd "<up>") #'flan-repl-previous-input)
|
||||||
|
(define-key map (kbd "<down>") #'flan-repl-next-input)
|
||||||
map)
|
map)
|
||||||
"Keymap for `flan-repl-mode'.")
|
"Keymap for `flan-repl-mode'.")
|
||||||
|
|
||||||
@@ -50,7 +106,7 @@
|
|||||||
"Type expressions; they are evaluated in the running program.
|
"Type expressions; they are evaluated in the running program.
|
||||||
|
|
||||||
\\{flan-repl-mode-map}"
|
\\{flan-repl-mode-map}"
|
||||||
:syntax-table flan-mode-syntax-table
|
:syntax-table flan-fln-mode-syntax-table
|
||||||
(setq-local comint-prompt-regexp (concat "^" (regexp-quote flan-repl-prompt)))
|
(setq-local comint-prompt-regexp (concat "^" (regexp-quote flan-repl-prompt)))
|
||||||
(setq-local comint-prompt-read-only t)
|
(setq-local comint-prompt-read-only t)
|
||||||
(setq-local comint-input-sender #'flan-repl--send)
|
(setq-local comint-input-sender #'flan-repl--send)
|
||||||
@@ -59,15 +115,134 @@
|
|||||||
;; The prompt gets completion, eldoc and M-. for the same names a buffer
|
;; The prompt gets completion, eldoc and M-. for the same names a buffer
|
||||||
;; does, and against the same program: they read the client's cache, which
|
;; does, and against the same program: they read the client's cache, which
|
||||||
;; is program-scoped, which is exactly what a prompt is.
|
;; is program-scoped, which is exactly what a prompt is.
|
||||||
(flan-dev-setup)
|
(flan-setup)
|
||||||
(setq-local font-lock-defaults '(flan-font-lock-keywords)))
|
(setq-local font-lock-defaults '(flan-fln-font-lock-keywords))
|
||||||
|
(setq-local comint-input-ring-size flan-repl-history-size)
|
||||||
|
(setq-local comint-input-ring-file-name
|
||||||
|
(and flan-repl-history-file
|
||||||
|
(expand-file-name flan-repl-history-file)))
|
||||||
|
;; comint made the ring before this body ran, sized from the global value.
|
||||||
|
(setq-local comint-input-ring (make-ring comint-input-ring-size))
|
||||||
|
(let ((comint-input-ring-separator flan-repl--history-separator))
|
||||||
|
;; Silent: a first session has no file yet, and saying so is not news.
|
||||||
|
(comint-read-input-ring t))
|
||||||
|
(add-hook 'kill-buffer-hook #'flan-repl--save-history nil t))
|
||||||
|
|
||||||
|
;;; History
|
||||||
|
|
||||||
|
(defun flan-repl--history-entries (file)
|
||||||
|
"How many entries FILE holds.
|
||||||
|
Counted rather than trusted to the ring, because the file may have been
|
||||||
|
written by another Emacs since this buffer read it."
|
||||||
|
(if (not (file-readable-p file))
|
||||||
|
0
|
||||||
|
(with-temp-buffer
|
||||||
|
(insert-file-contents file)
|
||||||
|
(let ((n 0))
|
||||||
|
(goto-char (point-min))
|
||||||
|
(while (search-forward flan-repl--history-separator nil t)
|
||||||
|
(setq n (1+ n)))
|
||||||
|
n))))
|
||||||
|
|
||||||
|
(defun flan-repl--save-history ()
|
||||||
|
"Write this buffer's input ring to `comint-input-ring-file-name'.
|
||||||
|
Refused in the two cases where writing loses more than it keeps: a ring with
|
||||||
|
nothing in it, which would empty the file, and a ring shorter than the file
|
||||||
|
already is, which is what a second Emacs having saved a longer history since
|
||||||
|
this buffer started looks like. A write replaces the file whole, so either
|
||||||
|
would throw away somebody's session."
|
||||||
|
(when (and comint-input-ring-file-name
|
||||||
|
(ring-p comint-input-ring)
|
||||||
|
(not (ring-empty-p comint-input-ring))
|
||||||
|
(>= (ring-length comint-input-ring)
|
||||||
|
(flan-repl--history-entries comint-input-ring-file-name)))
|
||||||
|
(let ((comint-input-ring-separator flan-repl--history-separator))
|
||||||
|
(comint-write-input-ring))))
|
||||||
|
|
||||||
|
(defun flan-repl--save-all-history ()
|
||||||
|
"Save every REPL buffer's history.
|
||||||
|
`kill-buffer-hook' does not run for a buffer Emacs is exiting out from under,
|
||||||
|
so quitting without killing the prompt first would otherwise lose the day."
|
||||||
|
(dolist (buf (buffer-list))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(when (derived-mode-p 'flan-repl-mode)
|
||||||
|
(flan-repl--save-history)))))
|
||||||
|
|
||||||
|
;; Not in batch. A batch Emacs exits through `kill-emacs' like any other, and
|
||||||
|
;; the prompt a test opened is nobody's session: the sweep would write the
|
||||||
|
;; person running the test their own history file, out of a ring made of
|
||||||
|
;; fixtures.
|
||||||
|
(unless noninteractive
|
||||||
|
(add-hook 'kill-emacs-hook #'flan-repl--save-all-history))
|
||||||
|
|
||||||
|
;;; Recall
|
||||||
|
|
||||||
|
;; `<up>' at a prompt means history to nearly everyone who has used a shell,
|
||||||
|
;; and `M-p' means it to nearly nobody who has not used Emacs. But the text
|
||||||
|
;; above the prompt is a transcript people scroll back through, and a blunt
|
||||||
|
;; binding would make that impossible — so the key is history only where there
|
||||||
|
;; is input for it to replace, and plain line motion everywhere else. Inside a
|
||||||
|
;; form typed over several lines it still moves between them, and reaches
|
||||||
|
;; history from the first one.
|
||||||
|
;;
|
||||||
|
;; The search is prefix-filtered by what is already typed, which is comint's
|
||||||
|
;; `...-from-input' pair and the same thing a shell's up-arrow does.
|
||||||
|
|
||||||
|
(defun flan-repl--input-start ()
|
||||||
|
"Where the text being typed begins, or nil if there is no process."
|
||||||
|
(let ((proc (get-buffer-process (current-buffer))))
|
||||||
|
(and proc (marker-position (process-mark proc)))))
|
||||||
|
|
||||||
|
(defun flan-repl--on-first-input-line-p ()
|
||||||
|
"Is point on the first line of the input, with history above it?"
|
||||||
|
(let ((start (flan-repl--input-start)))
|
||||||
|
;; `forward-line' rather than `line-beginning-position': the prompt is a
|
||||||
|
;; field, and field-constrained motion answers this question by accident
|
||||||
|
;; rather than by the rule meant here.
|
||||||
|
(and start (<= start (point))
|
||||||
|
(<= (save-excursion (forward-line 0) (point)) start))))
|
||||||
|
|
||||||
|
(defun flan-repl--on-last-input-line-p ()
|
||||||
|
"Is point on the last line of the input?"
|
||||||
|
(let ((start (flan-repl--input-start)))
|
||||||
|
(and start (<= start (point))
|
||||||
|
(save-excursion (forward-line 1) (eobp)))))
|
||||||
|
|
||||||
|
(defun flan-repl-previous-input (n)
|
||||||
|
"Recall the previous matching input, or move up a line above the input."
|
||||||
|
(interactive "p")
|
||||||
|
(if (flan-repl--on-first-input-line-p)
|
||||||
|
(progn
|
||||||
|
;; comint tells a continued search from a fresh one by looking at
|
||||||
|
;; `last-command' for its own name, which a wrapper's press never
|
||||||
|
;; leaves there: without the hand-off the second `<up>' searches again
|
||||||
|
;; from the entry the first one inserted and never moves.
|
||||||
|
(setq this-command 'comint-previous-matching-input-from-input)
|
||||||
|
(comint-previous-matching-input-from-input n))
|
||||||
|
;; Same reason in the other direction: `line-move' keeps the column it is
|
||||||
|
;; aiming for only while the line-motion commands follow each other.
|
||||||
|
(setq this-command 'previous-line)
|
||||||
|
;; `previous-line' and not `forward-line': the byte compiler's advice
|
||||||
|
;; against it is for code moving over text, and this is a keypress asking
|
||||||
|
;; for what the key does everywhere else — visual lines, kept column.
|
||||||
|
(with-no-warnings (previous-line n))))
|
||||||
|
|
||||||
|
(defun flan-repl-next-input (n)
|
||||||
|
"Recall the next matching input, or move down a line above the input."
|
||||||
|
(interactive "p")
|
||||||
|
(if (flan-repl--on-last-input-line-p)
|
||||||
|
(progn
|
||||||
|
(setq this-command 'comint-next-matching-input-from-input)
|
||||||
|
(comint-next-matching-input-from-input n))
|
||||||
|
(setq this-command 'next-line)
|
||||||
|
(with-no-warnings (next-line n))))
|
||||||
|
|
||||||
(defun flan-repl--complete-p (text)
|
(defun flan-repl--complete-p (text)
|
||||||
"Is TEXT a whole form?
|
"Is TEXT a whole form?
|
||||||
Parens balanced and not inside a string or comment. RET on a half-typed form
|
Parens balanced and not inside a string or comment. RET on a half-typed form
|
||||||
should open a line, not send something the reader will reject."
|
should open a line, not send something the reader will reject."
|
||||||
(let ((state (with-temp-buffer
|
(let ((state (with-temp-buffer
|
||||||
(set-syntax-table flan-mode-syntax-table)
|
(set-syntax-table flan-fln-mode-syntax-table)
|
||||||
(insert text)
|
(insert text)
|
||||||
(parse-partial-sexp (point-min) (point-max)))))
|
(parse-partial-sexp (point-min) (point-max)))))
|
||||||
(and (<= (nth 0 state) 0) ; depth
|
(and (<= (nth 0 state) 0) ; depth
|
||||||
@@ -79,23 +254,109 @@ should open a line, not send something the reader will reject."
|
|||||||
(let ((proc (get-buffer-process (current-buffer))))
|
(let ((proc (get-buffer-process (current-buffer))))
|
||||||
(comint-output-filter proc (concat text "\n" flan-repl-prompt))))
|
(comint-output-filter proc (concat text "\n" flan-repl-prompt))))
|
||||||
|
|
||||||
|
(defun flan-repl--insert-output (text)
|
||||||
|
"Insert TEXT, the program's own output, before the prompt.
|
||||||
|
Two moments call this and the same rule serves both. During a send there
|
||||||
|
is no prompt yet — the process mark sits at the end of the input just sent —
|
||||||
|
so the text goes at the mark, before the value and the prompt that follow.
|
||||||
|
Between sends the mark sits after the prompt, and the text goes above the
|
||||||
|
prompt's line, so the prompt and whatever is being typed at it do not move."
|
||||||
|
(let ((proc (get-buffer-process (current-buffer))))
|
||||||
|
(when (process-live-p proc)
|
||||||
|
(let ((mark (process-mark proc))
|
||||||
|
(text (if (string-suffix-p "\n" text) text (concat text "\n")))
|
||||||
|
(inhibit-read-only t))
|
||||||
|
(save-excursion
|
||||||
|
(goto-char mark)
|
||||||
|
(forward-line 0)
|
||||||
|
(let ((at (point)))
|
||||||
|
(insert text)
|
||||||
|
;; Inserting at the mark itself leaves the mark *before* the
|
||||||
|
;; text — a plain marker does not advance — and the value the
|
||||||
|
;; reply carries would then land above the output it caused.
|
||||||
|
(when (>= at (marker-position mark))
|
||||||
|
(set-marker mark (point)))))
|
||||||
|
(flan--trim-lines)))))
|
||||||
|
|
||||||
|
(defun flan-repl--buffer ()
|
||||||
|
"The REPL buffer, for the two clear commands, from wherever they are run.
|
||||||
|
From a source buffer, the current image's."
|
||||||
|
(let ((buf (if (derived-mode-p 'flan-repl-mode)
|
||||||
|
(current-buffer)
|
||||||
|
(get-buffer (flan--repl-buffer-name)))))
|
||||||
|
(unless (buffer-live-p buf)
|
||||||
|
(user-error "flan: no REPL buffer; C-c C-r opens one"))
|
||||||
|
buf))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun flan-repl-clear ()
|
||||||
|
"Erase the whole REPL transcript and leave a fresh prompt.
|
||||||
|
The input history is untouched: it is the screen that goes, not the ring."
|
||||||
|
(interactive)
|
||||||
|
(with-current-buffer (flan-repl--buffer)
|
||||||
|
(let ((proc (get-buffer-process (current-buffer)))
|
||||||
|
(inhibit-read-only t))
|
||||||
|
(erase-buffer)
|
||||||
|
(when (process-live-p proc)
|
||||||
|
(set-marker (process-mark proc) (point-max))
|
||||||
|
(comint-output-filter proc flan-repl-prompt)))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun flan-repl-clear-output ()
|
||||||
|
"Erase what the last send produced — output, value or error line.
|
||||||
|
The input that produced it stays, and so does the prompt; this is for a
|
||||||
|
send whose output buried the transcript, not for starting over — that is
|
||||||
|
`flan-repl-clear'."
|
||||||
|
(interactive)
|
||||||
|
(with-current-buffer (flan-repl--buffer)
|
||||||
|
(let* ((proc (get-buffer-process (current-buffer)))
|
||||||
|
(mark (and (process-live-p proc) (process-mark proc)))
|
||||||
|
(start (and (marker-position comint-last-input-end)
|
||||||
|
(marker-position comint-last-input-end)))
|
||||||
|
(end (and mark (save-excursion (goto-char mark)
|
||||||
|
(forward-line 0) (point))))
|
||||||
|
(inhibit-read-only t))
|
||||||
|
(if (not (and start end (< start end)))
|
||||||
|
(message "flan: nothing to clear")
|
||||||
|
(delete-region start end)))))
|
||||||
|
|
||||||
(defun flan-repl--send (_proc text)
|
(defun flan-repl--send (_proc text)
|
||||||
"Evaluate TEXT in the running program and show what it was."
|
"Evaluate TEXT in the running program and show what it was.
|
||||||
|
An image's REPL is that image's prompt, so sending from it makes its image
|
||||||
|
the current one first."
|
||||||
(let ((code (string-trim text)))
|
(let ((code (string-trim text)))
|
||||||
(cond
|
(cond
|
||||||
((string-empty-p code) (flan-repl--output ""))
|
((string-empty-p code) (flan-repl--output ""))
|
||||||
(t
|
(t
|
||||||
(let ((reply (condition-case err
|
(let ((reply (condition-case err
|
||||||
(flan-dev--request
|
(progn
|
||||||
(list :op "eval-expr" :code code :file "<repl>"))
|
;; The REPL of an image that has stopped refuses
|
||||||
(error (list :status "error"
|
;; rather than sending to whichever image is current.
|
||||||
|
(flan--use-image flan--buffer-image)
|
||||||
|
(flan--request
|
||||||
|
(list :op "eval-expr" :code code :file "<repl>"
|
||||||
|
:syntax "indented")))
|
||||||
|
;; :client marks a failure of the *connection* — no
|
||||||
|
;; daemon, no reply — which is not a compiler message
|
||||||
|
;; and has no place in the diagnostics list.
|
||||||
|
(error (list :status "error" :client t
|
||||||
:message (error-message-string err))))))
|
:message (error-message-string err))))))
|
||||||
(flan-repl--output
|
(cond
|
||||||
(if (equal (plist-get reply :status) "ok")
|
((equal (plist-get reply :status) "ok")
|
||||||
(or (plist-get reply :value) "")
|
(flan-repl--output (or (plist-get reply :value) "")))
|
||||||
(concat "error: " (or (plist-get reply :message) "rejected")
|
((plist-get reply :client)
|
||||||
(let ((loc (plist-get reply :loc)))
|
(flan-repl--output
|
||||||
(if loc (concat " (" loc ")") ""))))))))))
|
(concat "error: " (or (plist-get reply :message) "rejected"))))
|
||||||
|
(t
|
||||||
|
;; A rejection. The message goes where every compiler message
|
||||||
|
;; goes — the diagnostics list, which `flan--record-diagnostic'
|
||||||
|
;; shows — and the prompt gets the one-line pointer.
|
||||||
|
(ignore-errors
|
||||||
|
(flan--record-diagnostic (plist-get reply :loc)
|
||||||
|
(or (plist-get reply :message)
|
||||||
|
"rejected")))
|
||||||
|
(flan-repl--output
|
||||||
|
(format "1 error — see %s" flan-diagnostics-buffer)))))))))
|
||||||
|
|
||||||
(defun flan-repl-return ()
|
(defun flan-repl-return ()
|
||||||
"Send the input if it is a whole form, otherwise open a line."
|
"Send the input if it is a whole form, otherwise open a line."
|
||||||
@@ -104,22 +365,45 @@ should open a line, not send something the reader will reject."
|
|||||||
(process-mark (get-buffer-process (current-buffer)))
|
(process-mark (get-buffer-process (current-buffer)))
|
||||||
(point-max))))
|
(point-max))))
|
||||||
(if (flan-repl--complete-p input)
|
(if (flan-repl--complete-p input)
|
||||||
(comint-send-input)
|
(progn
|
||||||
|
;; `comint-send-input' sends the process mark to *point*, and
|
||||||
|
;; `comint-eol-on-send' carries it no further than the end of one
|
||||||
|
;; line. Completeness above was judged over the whole input, so the
|
||||||
|
;; whole input is what goes: otherwise RET in the middle of a form
|
||||||
|
;; typed over several lines, or on one just recalled — history leaves
|
||||||
|
;; point where the typing stopped — sends a fragment the reader will
|
||||||
|
;; reject.
|
||||||
|
(goto-char (point-max))
|
||||||
|
(comint-send-input))
|
||||||
(insert "\n"))))
|
(insert "\n"))))
|
||||||
|
|
||||||
(define-key flan-repl-mode-map (kbd "RET") #'flan-repl-return)
|
(define-key flan-repl-mode-map (kbd "RET") #'flan-repl-return)
|
||||||
|
|
||||||
;;;###autoload
|
;;;###autoload
|
||||||
(defun flan-repl ()
|
(defun flan-repl ()
|
||||||
"Open a prompt on the program `flan dev' is running.
|
"Open the current image's prompt.
|
||||||
Connects first if it has to."
|
With no image, start one: `flan' opens its REPL when it is ready."
|
||||||
(interactive)
|
(interactive)
|
||||||
(unless (and flan-dev--connection (process-live-p flan-dev--connection))
|
(if (null flan--image)
|
||||||
(call-interactively #'flan-connect))
|
(call-interactively #'flan)
|
||||||
(let ((buf (get-buffer-create flan-repl-buffer)))
|
(unless (process-live-p flan--connection)
|
||||||
|
(flan--live-connection))
|
||||||
|
(flan-repl--open)))
|
||||||
|
|
||||||
|
(defun flan-repl--open ()
|
||||||
|
"Show the current image's REPL buffer, making it if there is none."
|
||||||
|
(let ((buf (get-buffer-create (flan--repl-buffer-name flan--image)))
|
||||||
|
(image flan--image))
|
||||||
(with-current-buffer buf
|
(with-current-buffer buf
|
||||||
|
;; On every open, not only the first: a new image started where a
|
||||||
|
;; stopped one was has its name, and so this buffer.
|
||||||
|
(setq flan--buffer-image image)
|
||||||
(unless (derived-mode-p 'flan-repl-mode)
|
(unless (derived-mode-p 'flan-repl-mode)
|
||||||
(flan-repl-mode)
|
(flan-repl-mode)
|
||||||
|
(setq flan--buffer-image image)
|
||||||
|
;; Killing an image's REPL asks, and a yes stops that image.
|
||||||
|
(add-hook 'kill-buffer-query-functions
|
||||||
|
#'flan--query-kill-image-buffer nil t)
|
||||||
;; comint wants a process to hang a prompt and a process mark off.
|
;; comint wants a process to hang a prompt and a process mark off.
|
||||||
;; There is nothing to run, so this one does nothing and is never
|
;; There is nothing to run, so this one does nothing and is never
|
||||||
;; written to; every request goes over the daemon's socket instead.
|
;; written to; every request goes over the daemon's socket instead.
|
||||||
|
|||||||
@@ -0,0 +1,417 @@
|
|||||||
|
;;; flan-step.el --- The stepper, shown in the source -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; `C-c C-s' installs a defn so that each call stops before each form of its
|
||||||
|
;; body. A step stop is not a condition anybody has to answer, so it does not
|
||||||
|
;; open *flan-conditions*: the form about to run is highlighted where it is
|
||||||
|
;; written, point goes there, the value of the form that just ran is shown
|
||||||
|
;; after it (CIDER's "=> 42"), and the keys are edebug's: `flan-step-mode' is on
|
||||||
|
;; in the stopped source buffer only, binds n/i/o/c/q (and e, l) there, and
|
||||||
|
;; lists them in the buffer's header line. Every other key, and every other
|
||||||
|
;; buffer, is untouched, so the conditions buffer and the REPL work while
|
||||||
|
;; stopped. The buffer is read-only while the mode is on, as edebug's is, so
|
||||||
|
;; that a plain letter can be a command. `C-c C-b' goes back to the stop.
|
||||||
|
;;
|
||||||
|
;; The daemon half: the stop's frame, place and value ride on the `break'
|
||||||
|
;; reply (`:step-frame', `:step-fn', `:step-loc', `:step-value',
|
||||||
|
;; `:step-value-at', `:step-gen'); `step-into' installs a callee to step for one
|
||||||
|
;; call; `unstep' installs every stepped function plain again.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'flan)
|
||||||
|
(require 'flan-cnr)
|
||||||
|
|
||||||
|
(defface flan-step-face '((t :inherit secondary-selection :extend nil))
|
||||||
|
"The form the stepper is stopped before: a quiet background, no underline,
|
||||||
|
from the theme's own face so it suits a light and a dark theme."
|
||||||
|
:group 'flan)
|
||||||
|
|
||||||
|
(defface flan-step-value-face '((t :inherit shadow :slant italic))
|
||||||
|
"The value of the form that just ran, shown after it."
|
||||||
|
:group 'flan)
|
||||||
|
|
||||||
|
(defface flan-step-key-face '((t :inherit help-key-binding))
|
||||||
|
"A key in the stepper's header line."
|
||||||
|
:group 'flan)
|
||||||
|
|
||||||
|
(defcustom flan-step-wait 1.0
|
||||||
|
"Seconds a step waits for the program to stop again.
|
||||||
|
A step that runs off the end of the stepped call stops nowhere until the next
|
||||||
|
call steps, and the marks come down when this runs out; they go up again at
|
||||||
|
that stop."
|
||||||
|
:type 'number
|
||||||
|
:group 'flan)
|
||||||
|
|
||||||
|
(defconst flan-step-condition "StepPoint"
|
||||||
|
"The condition a step stop reports: `lib/prelude.fln''s `step-point'.")
|
||||||
|
|
||||||
|
(defvar flan-step--stop nil
|
||||||
|
"The `break' reply of the step shown now, or nil.")
|
||||||
|
|
||||||
|
(defvar flan-step--image nil
|
||||||
|
"The image the step shown now stopped in. The keys act on it,
|
||||||
|
whichever image is current when they are pressed.")
|
||||||
|
|
||||||
|
(defvar flan-step--source nil
|
||||||
|
"The buffer `flan-step-mode' is on for the step shown now, or nil.")
|
||||||
|
|
||||||
|
(defvar flan-step--overlays nil
|
||||||
|
"The form and value overlays the step shown now put up.")
|
||||||
|
|
||||||
|
;;; Showing a stop
|
||||||
|
|
||||||
|
(defun flan-step--clear ()
|
||||||
|
(mapc #'delete-overlay flan-step--overlays)
|
||||||
|
(setq flan-step--overlays nil)
|
||||||
|
(when (buffer-live-p flan-step--source)
|
||||||
|
(with-current-buffer flan-step--source (flan-step-mode -1)))
|
||||||
|
(setq flan-step--source nil))
|
||||||
|
|
||||||
|
(defun flan-step--fln-p ()
|
||||||
|
(or (derived-mode-p 'flan-fln-mode)
|
||||||
|
(and buffer-file-name (string-suffix-p ".fln" buffer-file-name))))
|
||||||
|
|
||||||
|
(defun flan-step--form-end (pos)
|
||||||
|
"Where the form starting at POS ends: its closing paren, or in .fln the end
|
||||||
|
of its first line, which is the statement a step runs."
|
||||||
|
(save-excursion
|
||||||
|
(goto-char pos)
|
||||||
|
(if (flan-step--fln-p)
|
||||||
|
(progn (end-of-line) (skip-chars-backward " \t") (max pos (point)))
|
||||||
|
(or (ignore-errors (forward-sexp) (point))
|
||||||
|
(line-end-position)))))
|
||||||
|
|
||||||
|
(defun flan-step--value-end (start next)
|
||||||
|
"Where to show the value of the form at START, which ran before NEXT.
|
||||||
|
The end of the form in parens. In .fln, the end of the last line of code
|
||||||
|
before NEXT, which is the form's last line: the two are siblings in one body."
|
||||||
|
(save-excursion
|
||||||
|
(if (not (flan-step--fln-p))
|
||||||
|
(progn (goto-char start)
|
||||||
|
(min next (or (ignore-errors (forward-sexp) (point)) next)))
|
||||||
|
(goto-char next)
|
||||||
|
(if (<= (line-beginning-position) start)
|
||||||
|
(progn (skip-chars-backward " \t") (point))
|
||||||
|
(forward-line -1)
|
||||||
|
(while (and (> (point) start)
|
||||||
|
(looking-at-p "[ \t]*\\(;.*\\)?$"))
|
||||||
|
(forward-line -1))
|
||||||
|
(end-of-line)
|
||||||
|
(max start (point))))))
|
||||||
|
|
||||||
|
(defun flan-step--truncate (s)
|
||||||
|
(let ((w (max 20 (- (window-width) 20))))
|
||||||
|
(if (> (length s) w) (concat (substring s 0 (1- w)) "…") s)))
|
||||||
|
|
||||||
|
(defun flan-step--keep-p (win)
|
||||||
|
"Whether WIN is one the source must not take: the REPL's, the conditions
|
||||||
|
buffer's or another side or dedicated window."
|
||||||
|
(let ((b (window-buffer win)))
|
||||||
|
(or (with-current-buffer b (derived-mode-p (quote flan-cnr-mode)))
|
||||||
|
(window-dedicated-p win)
|
||||||
|
(window-parameter win 'window-side)
|
||||||
|
(with-current-buffer b (derived-mode-p 'flan-repl-mode)))))
|
||||||
|
|
||||||
|
(defun flan-step--display (buf _alist)
|
||||||
|
"A `display-buffer' action: BUF in a window that is not the REPL's or the
|
||||||
|
conditions buffer's, the selected one first; else a new window."
|
||||||
|
(let ((win (seq-find (lambda (w) (not (flan-step--keep-p w)))
|
||||||
|
(cons (selected-window)
|
||||||
|
(window-list nil 'nomini)))))
|
||||||
|
(if win
|
||||||
|
(progn (set-window-buffer win buf) win)
|
||||||
|
(display-buffer-pop-up-window buf nil))))
|
||||||
|
|
||||||
|
(defun flan-step--buffer (file)
|
||||||
|
"The buffer visiting FILE, visited when it is not, shown and selected.
|
||||||
|
Never in the REPL's window, which is where a person is often typing."
|
||||||
|
(let* ((buf (or (flan--buffer-visiting file) (find-file-noselect file)))
|
||||||
|
(win (display-buffer buf '((display-buffer-reuse-window
|
||||||
|
flan-step--display)))))
|
||||||
|
(when (and win (not (flan-step--keep-p win))) (select-window win))
|
||||||
|
buf))
|
||||||
|
|
||||||
|
(defun flan-step--show (stop)
|
||||||
|
"Put STOP, a `break' reply at a step, into its source."
|
||||||
|
(flan-step--clear)
|
||||||
|
(setq flan-step--stop stop
|
||||||
|
flan-step--image (and (boundp 'flan--image) flan--image))
|
||||||
|
(let ((parts (ignore-errors
|
||||||
|
(flan--visitable-loc (plist-get stop :step-loc) "the step"))))
|
||||||
|
(when parts
|
||||||
|
(with-current-buffer (flan-step--buffer (nth 0 parts))
|
||||||
|
(flan-step-mode 1)
|
||||||
|
(setq flan-step--source (current-buffer))
|
||||||
|
(let* ((pos (flan--position (nth 1 parts) (nth 2 parts)))
|
||||||
|
(form (make-overlay pos (flan-step--form-end pos))))
|
||||||
|
(overlay-put form 'face 'flan-step-face)
|
||||||
|
(overlay-put form 'priority 60)
|
||||||
|
(overlay-put form 'flan-step t)
|
||||||
|
(push form flan-step--overlays)
|
||||||
|
(goto-char pos)
|
||||||
|
(let ((win (get-buffer-window (current-buffer))))
|
||||||
|
(when win (set-window-point win pos)))
|
||||||
|
(let ((value (plist-get stop :step-value))
|
||||||
|
(at (flan--parse-loc (plist-get stop :step-value-at))))
|
||||||
|
(when (and value at)
|
||||||
|
(let* ((start (flan--position (nth 1 at) (nth 2 at)))
|
||||||
|
(end (flan-step--value-end start pos))
|
||||||
|
(ov (make-overlay end end)))
|
||||||
|
(overlay-put ov 'flan-step t)
|
||||||
|
(overlay-put ov 'after-string
|
||||||
|
(propertize
|
||||||
|
(concat " => " (flan-step--truncate value))
|
||||||
|
'face 'flan-step-value-face))
|
||||||
|
(push ov flan-step--overlays)))))))))
|
||||||
|
|
||||||
|
(defun flan-step--fetch ()
|
||||||
|
"The `break' reply when the program is stopped at a step, else nil."
|
||||||
|
(let ((r (flan--request '(:op "break"))))
|
||||||
|
(and (equal (plist-get r :status) "ok")
|
||||||
|
(plist-get r :stopped)
|
||||||
|
(equal (plist-get r :condition) flan-step-condition)
|
||||||
|
(plist-get r :step-loc)
|
||||||
|
r)))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun flan-step-on-stop ()
|
||||||
|
"The program stopped at a step: show it, with the keys on in its source.
|
||||||
|
Called by `flan--auto-break' on the stop's edge, and by a step that waited
|
||||||
|
for the next one. A stop already shown is shown again only if it moved."
|
||||||
|
(let ((stop (flan-step--fetch)))
|
||||||
|
(when stop
|
||||||
|
(unless (and flan-step--stop
|
||||||
|
(equal (plist-get stop :step-gen)
|
||||||
|
(plist-get flan-step--stop :step-gen))
|
||||||
|
flan-step--overlays)
|
||||||
|
(flan-step--show stop)))))
|
||||||
|
|
||||||
|
;;; Taking a step
|
||||||
|
|
||||||
|
(defun flan-step--gen () (plist-get flan-step--stop :step-gen))
|
||||||
|
|
||||||
|
(defun flan-step--use-image ()
|
||||||
|
"Make the image the step stopped in current, for one of the stepper's keys."
|
||||||
|
(if (and flan-step--image (memq flan-step--image flan--images))
|
||||||
|
(flan--use-image flan-step--image)
|
||||||
|
(setq flan-step--image nil)))
|
||||||
|
|
||||||
|
(defun flan-step--need-stop ()
|
||||||
|
(flan-step--use-image)
|
||||||
|
(unless (and flan--stopped (equal flan--stopped flan-step-condition)
|
||||||
|
flan-step--stop)
|
||||||
|
(user-error "flan: the program is not stopped at a step")))
|
||||||
|
|
||||||
|
(defun flan-step--take (restart)
|
||||||
|
"Take the stepper's RESTART and wait for the next step."
|
||||||
|
(flan-step--need-stop)
|
||||||
|
(let ((was (flan-step--gen))
|
||||||
|
(r (flan--request (list :op "restart" :name restart))))
|
||||||
|
(unless (equal (plist-get r :status) "ok")
|
||||||
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
||||||
|
(flan-step--wait was)))
|
||||||
|
|
||||||
|
(defun flan-step--wait (was)
|
||||||
|
"Wait for the stop after the one numbered WAS, and show it.
|
||||||
|
Answers whether the program stopped at a step again. A stop on a condition
|
||||||
|
ends the wait at once and is left to the conditions buffer; no stop at all
|
||||||
|
means it is running, and the marks come down either way."
|
||||||
|
(setq flan--stopped nil)
|
||||||
|
(flan--forget-break-stack)
|
||||||
|
(let ((deadline (+ (float-time) flan-step-wait))
|
||||||
|
(stop nil) (other nil))
|
||||||
|
(while (and (null stop) (null other) (< (float-time) deadline))
|
||||||
|
(sleep-for 0.02)
|
||||||
|
(let* ((d (flan--request '(:op "describe")))
|
||||||
|
(c (and (plist-get d :stopped) (plist-get d :condition))))
|
||||||
|
(cond
|
||||||
|
((equal c flan-step-condition)
|
||||||
|
(let ((b (flan-step--fetch)))
|
||||||
|
(when (and b (not (equal (plist-get b :step-gen) was)))
|
||||||
|
(setq stop b))))
|
||||||
|
(c (setq other c)))))
|
||||||
|
(force-mode-line-update t)
|
||||||
|
(if stop
|
||||||
|
(progn (flan-step--show stop) t)
|
||||||
|
(flan-step--clear)
|
||||||
|
(setq flan-step--stop nil)
|
||||||
|
(if other
|
||||||
|
(message "flan: stopped on %s — C-c C-b to choose a restart" other)
|
||||||
|
(message "flan: running; the next call of a stepped function steps again"))
|
||||||
|
nil)))
|
||||||
|
|
||||||
|
(defun flan-step-next ()
|
||||||
|
"Run the form the stepper is stopped before, and stop before the next."
|
||||||
|
(interactive)
|
||||||
|
(flan-step--take "next"))
|
||||||
|
|
||||||
|
(defun flan-step--name-at-point ()
|
||||||
|
"The function named at point, when point is on the form about to run."
|
||||||
|
(let ((form (seq-find (lambda (o) (overlay-get o 'face)) flan-step--overlays))
|
||||||
|
(sym (thing-at-point 'symbol t)))
|
||||||
|
(and form sym
|
||||||
|
(eq (overlay-buffer form) (current-buffer))
|
||||||
|
(<= (overlay-start form) (point) (overlay-end form))
|
||||||
|
(equal (nth 1 (assoc sym flan--defs)) "fn")
|
||||||
|
sym)))
|
||||||
|
|
||||||
|
(defun flan-step-in ()
|
||||||
|
"Step into the call the form about to run makes.
|
||||||
|
The function named at point when point is on that form, else the first call
|
||||||
|
it enters. The callee is installed to step for that one call, and only its
|
||||||
|
own entry can take it."
|
||||||
|
(interactive)
|
||||||
|
(flan-step--need-stop)
|
||||||
|
(let* ((name (flan-step--name-at-point))
|
||||||
|
(r (flan--request (append '(:op "step-into")
|
||||||
|
(and name (list :name name))))))
|
||||||
|
(unless (equal (plist-get r :status) "ok")
|
||||||
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
||||||
|
;; The daemon took `enter' itself, with the callee's id.
|
||||||
|
(flan-step--wait (flan-step--gen))))
|
||||||
|
|
||||||
|
(defun flan-step-out ()
|
||||||
|
"Run the rest of this call, and stop in the caller if it is stepping."
|
||||||
|
(interactive)
|
||||||
|
(flan-step--take "out"))
|
||||||
|
|
||||||
|
(defun flan-step-continue ()
|
||||||
|
"Run on. The next call of a stepped function steps again."
|
||||||
|
(interactive)
|
||||||
|
(flan-step--take-and-go "continue"))
|
||||||
|
|
||||||
|
(defun flan-step--take-and-go (restart)
|
||||||
|
(flan-step--need-stop)
|
||||||
|
(let ((r (flan--request (list :op "restart" :name restart))))
|
||||||
|
(unless (equal (plist-get r :status) "ok")
|
||||||
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
||||||
|
(setq flan--stopped nil)
|
||||||
|
(flan--forget-break-stack)
|
||||||
|
(force-mode-line-update t)
|
||||||
|
(flan-step--clear)
|
||||||
|
(setq flan-step--stop nil)))
|
||||||
|
|
||||||
|
(defun flan-step-quit ()
|
||||||
|
"Stop stepping: install every stepped function plain, and run on."
|
||||||
|
(interactive)
|
||||||
|
(flan-step--use-image)
|
||||||
|
;; Before the request, which signals when nothing is listening: the keys
|
||||||
|
;; and the read-only buffer must not outlive a stop nobody can end.
|
||||||
|
(flan-step--clear)
|
||||||
|
(let ((r (flan--request '(:op "unstep"))))
|
||||||
|
(unless (equal (plist-get r :status) "ok")
|
||||||
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
||||||
|
;; The marks C-c C-s put over each stepped defn.
|
||||||
|
(dolist (b (buffer-list))
|
||||||
|
(with-current-buffer b
|
||||||
|
(when (derived-mode-p 'flan-mode 'flan-fln-mode)
|
||||||
|
(remove-overlays (point-min) (point-max) 'flan-step t))))
|
||||||
|
(if (and flan--stopped (equal flan--stopped flan-step-condition))
|
||||||
|
(flan-step--take-and-go "continue")
|
||||||
|
(flan-step--clear))
|
||||||
|
(if (plist-get r :none)
|
||||||
|
(message "flan: nothing is stepping")
|
||||||
|
(message "flan: stepping off; %s installed plain"
|
||||||
|
(mapconcat #'identity (plist-get r :names) ", ")))))
|
||||||
|
|
||||||
|
(defun flan-step-eval (code)
|
||||||
|
"Evaluate CODE in the stepped frame and show its value."
|
||||||
|
(interactive (list (read-string "Eval in frame: ")))
|
||||||
|
(flan-step--need-stop)
|
||||||
|
(let ((r (flan--request (list :op "eval-expr" :code code
|
||||||
|
:frame (plist-get flan-step--stop :step-frame)))))
|
||||||
|
(unless (equal (plist-get r :status) "ok")
|
||||||
|
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
||||||
|
(message "=> %s" (or (plist-get r :value) (plist-get r :note) ""))))
|
||||||
|
|
||||||
|
(defun flan-step-locals ()
|
||||||
|
"Show the stepped frame's locals in *flan-conditions*, beside the source.
|
||||||
|
`i' there opens the inspector on one."
|
||||||
|
(interactive)
|
||||||
|
(flan-step--need-stop)
|
||||||
|
(let ((frame (plist-get flan-step--stop :step-frame)))
|
||||||
|
(save-selected-window
|
||||||
|
(with-current-buffer (flan-cnr-show)
|
||||||
|
(setq flan-cnr--open nil)
|
||||||
|
(goto-char (point-min))
|
||||||
|
(while (and (not (eobp))
|
||||||
|
(not (eql (get-text-property (point) 'flan-cnr-frame) frame)))
|
||||||
|
(forward-line 1))
|
||||||
|
(unless (eobp) (flan-cnr-toggle-frame))))))
|
||||||
|
|
||||||
|
;;; The keys
|
||||||
|
|
||||||
|
(defconst flan-step--keys
|
||||||
|
'(("n" "next") ("i" "into") ("o" "out") ("c" "continue") ("q" "quit")
|
||||||
|
("e" "eval") ("l" "locals"))
|
||||||
|
"The keys of `flan-step-mode', in the order its header line lists them.")
|
||||||
|
|
||||||
|
(defun flan-step--header ()
|
||||||
|
"The header line of the stopped source: its keys, then where it is stopped."
|
||||||
|
(let ((s flan-step--stop))
|
||||||
|
(concat
|
||||||
|
" "
|
||||||
|
(mapconcat (lambda (k)
|
||||||
|
(concat (propertize (car k) 'face 'flan-step-key-face)
|
||||||
|
" " (cadr k)))
|
||||||
|
flan-step--keys " ")
|
||||||
|
(when s
|
||||||
|
(let ((at (flan--parse-loc (plist-get s :step-loc))))
|
||||||
|
(format " | %s, line %s" (plist-get s :step-fn)
|
||||||
|
(if at (nth 1 at) "?")))))))
|
||||||
|
|
||||||
|
(defvar flan-step-mode-map
|
||||||
|
(let ((map (make-sparse-keymap)))
|
||||||
|
(define-key map "n" #'flan-step-next)
|
||||||
|
(define-key map "i" #'flan-step-in)
|
||||||
|
(define-key map "o" #'flan-step-out)
|
||||||
|
(define-key map "c" #'flan-step-continue)
|
||||||
|
(define-key map "q" #'flan-step-quit)
|
||||||
|
(define-key map "e" #'flan-step-eval)
|
||||||
|
(define-key map "l" #'flan-step-locals)
|
||||||
|
map)
|
||||||
|
"Keymap of `flan-step-mode'.")
|
||||||
|
|
||||||
|
;; Evil's normal state would otherwise take n, i, o, c and q before this map
|
||||||
|
;; saw them; its own per-state bindings in the map come first.
|
||||||
|
(declare-function evil-define-key* "evil-core"
|
||||||
|
(state keymap key def &rest bindings))
|
||||||
|
(with-eval-after-load 'evil
|
||||||
|
(dolist (k flan-step--keys)
|
||||||
|
(evil-define-key* '(normal motion) flan-step-mode-map
|
||||||
|
(car k) (lookup-key flan-step-mode-map (car k)))))
|
||||||
|
|
||||||
|
(defvar-local flan-step--saved nil
|
||||||
|
"The read-only flag and header line this buffer had before `flan-step-mode'.")
|
||||||
|
|
||||||
|
(define-minor-mode flan-step-mode
|
||||||
|
"Edebug's model for the stepper: single keys in the stopped source buffer.
|
||||||
|
On only in the buffer a step is stopped in, read-only while it is, with its
|
||||||
|
keys in the header line.
|
||||||
|
|
||||||
|
\{flan-step-mode-map}"
|
||||||
|
:lighter " Step"
|
||||||
|
:keymap flan-step-mode-map
|
||||||
|
(cond
|
||||||
|
(flan-step-mode
|
||||||
|
(setq flan-step--saved (list buffer-read-only header-line-format))
|
||||||
|
(setq buffer-read-only t
|
||||||
|
header-line-format '(:eval (flan-step--header)))
|
||||||
|
(when (fboundp 'evil-normalize-keymaps) (evil-normalize-keymaps)))
|
||||||
|
(flan-step--saved
|
||||||
|
(setq buffer-read-only (nth 0 flan-step--saved)
|
||||||
|
header-line-format (nth 1 flan-step--saved)
|
||||||
|
flan-step--saved nil)
|
||||||
|
(when (fboundp 'evil-normalize-keymaps) (evil-normalize-keymaps)))))
|
||||||
|
|
||||||
|
;;;###autoload
|
||||||
|
(defun flan-step-menu ()
|
||||||
|
"Go to the step the program is stopped at, with the stepper's keys on.
|
||||||
|
`C-c C-b' calls this at a step; the keys are those of `flan-step-mode'."
|
||||||
|
(interactive)
|
||||||
|
(let ((stop (flan-step--fetch)))
|
||||||
|
(unless stop (user-error "flan: the program is not stopped at a step"))
|
||||||
|
(flan-step--show stop)))
|
||||||
|
|
||||||
|
(provide 'flan-step)
|
||||||
|
;;; flan-step.el ends here
|
||||||
+133
-139
@@ -1,5 +1,24 @@
|
|||||||
;;; flan-watch.el --- Watched values, in a pinned buffer or inline -*- lexical-binding: t; -*-
|
;;; flan-watch.el --- Watched values, in a pinned buffer or inline -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Author: Joseph Ferano <joseph@ferano.io>
|
||||||
|
;; Version: 0.1.0
|
||||||
|
;; Package-Requires: ((emacs "29.1"))
|
||||||
|
;; Keywords: languages, lisp, tools
|
||||||
|
|
||||||
|
;; The headers above are what make this directory installable. M-x
|
||||||
|
;; package-install-file on it reads them, and a file with no Version: is not a
|
||||||
|
;; package as far as package.el is concerned -- until now the client was
|
||||||
|
;; reachable only by adding it to load-path by hand, which is a thing to
|
||||||
|
;; explain to every person who wants to try it.
|
||||||
|
;;
|
||||||
|
;; 29.1 is the floor because it is the oldest Emacs any of this has been run
|
||||||
|
;; against, not because some function here is known to need it. dape, which
|
||||||
|
;; flan-dape drives, asks for 29.1 as well and is a soft dependency: it is
|
||||||
|
;; reached through declare-function, so the rest of the client loads and works
|
||||||
|
;; without it and it is deliberately not listed above. The compiler this talks
|
||||||
|
;; to is not an Emacs package and cannot be listed here either -- emacs/MANUAL.md
|
||||||
|
;; says what has to be on PATH.
|
||||||
|
|
||||||
;; A HUD for a running Flan program: a buffer that always shows the current
|
;; A HUD for a running Flan program: a buffer that always shows the current
|
||||||
;; frame's values and nothing else. Ported from the author's Clojure
|
;; frame's values and nothing else. Ported from the author's Clojure
|
||||||
;; `clj-watch', with one thing kept and one thing inverted.
|
;; `clj-watch', with one thing kept and one thing inverted.
|
||||||
@@ -28,38 +47,36 @@
|
|||||||
;; halves are cheap for opposite reasons, and two things fall out that a poll
|
;; halves are cheap for opposite reasons, and two things fall out that a poll
|
||||||
;; could not have given:
|
;; could not have given:
|
||||||
;;
|
;;
|
||||||
;; the values update at *frame rate* rather than at the timer's rate — the
|
;; the values update at *frame rate* rather than at the repaint rate — the
|
||||||
;; timer only decides how often the picture is repainted, not how fresh it
|
;; interval only decides how often the picture is repainted, not how fresh
|
||||||
;; is;
|
;; it is;
|
||||||
;;
|
;;
|
||||||
;; and the last frame's values are still there while the program is
|
;; and the last frame's values are still there while the program is
|
||||||
;; *stopped*. A break loop is precisely when no thunk can run at a frame
|
;; *stopped*. A break loop is precisely when no thunk can run at a frame
|
||||||
;; boundary, because there are no more frames, and precisely when you want to
|
;; boundary, because there are no more frames, and precisely when you want to
|
||||||
;; see what the last one held.
|
;; see what the last one held.
|
||||||
;;
|
;;
|
||||||
;; Also kept from the original, and for its stated reasons: the request is
|
;; The daemon reads the table and sends it on the editor's connection, as it
|
||||||
;; **async**, because a synchronous call on a timer blocks Emacs's UI every
|
;; sends the program's output, so Emacs never waits on a timer for it. The
|
||||||
;; tick; and the paint is `replace-buffer-contents' rather than erase-and-
|
;; paint is `replace-buffer-contents' rather than erase-and-insert, because it
|
||||||
;; insert, because it diffs, so point and scroll survive a repaint instead of
|
;; diffs, so point and scroll survive a repaint instead of being yanked to the
|
||||||
;; being yanked to the top five times a second.
|
;; top five times a second.
|
||||||
;;
|
;;
|
||||||
;; What a program writes today, with no compiler change:
|
;; What a program writes:
|
||||||
;;
|
|
||||||
;; (declare-c watch-i64 [name string x i64] i32 "flan_dev_watch_i64")
|
|
||||||
;; (declare-c watch-f64 [name string x f64] i32 "flan_dev_watch_f64")
|
|
||||||
;;
|
;;
|
||||||
;; (defn step [] i64
|
;; (defn step [] i64
|
||||||
;; (set ticks (+ ticks 1))
|
;; (set ticks (+ ticks 1))
|
||||||
;; (watch-i64 "ticks" ticks)
|
;; (watch "ticks" ticks)
|
||||||
|
;; (watch "player" player)
|
||||||
;; ticks)
|
;; ticks)
|
||||||
;;
|
;;
|
||||||
;; Scalars only, so far. A struct or a slice needs a compile-time walk over
|
;; `watch' renders any value the way `print' does — a struct, a slice, a dyn
|
||||||
;; its type — a `(watch "hp" hp)' form in the checker — and that is a file this
|
;; value — into the table. The scalar entry points underneath it,
|
||||||
;; change does not own. See BUILT.md.
|
;; `flan_dev_watch_i64' and the rest, are reachable through `declare-c' too.
|
||||||
|
|
||||||
;;; Code:
|
;;; Code:
|
||||||
|
|
||||||
(require 'flan-dev)
|
(require 'flan)
|
||||||
(require 'subr-x)
|
(require 'subr-x)
|
||||||
|
|
||||||
(defgroup flan-watch nil
|
(defgroup flan-watch nil
|
||||||
@@ -75,19 +92,17 @@
|
|||||||
"Seconds between repaints.
|
"Seconds between repaints.
|
||||||
|
|
||||||
This is the *repaint* rate, not the watch rate. The program writes its values
|
This is the *repaint* rate, not the watch rate. The program writes its values
|
||||||
every frame whatever this is; all this decides is how often the picture is
|
every frame whatever this is; all this decides is how often the daemon sends
|
||||||
refreshed, which is why a slow value here costs freshness and nothing else."
|
the table, which is why a slow value here costs freshness and nothing else.
|
||||||
|
Taken when the table is armed, so a change applies from the next `flan-watch'."
|
||||||
:type 'number)
|
:type 'number)
|
||||||
|
|
||||||
(defvar flan-watch--timer nil)
|
|
||||||
(defvar flan-watch--pending nil
|
|
||||||
"Non-nil while a watch request is out and its reply has not been read.")
|
|
||||||
(defvar flan-watch--rows nil
|
(defvar flan-watch--rows nil
|
||||||
"The last table painted, as a list of (NAME . VALUE).")
|
"The last table painted, as a list of (NAME . VALUE).")
|
||||||
(defvar flan-watch--consumers nil
|
(defvar flan-watch--consumers nil
|
||||||
"Which pictures of the table are currently wanted: `buffer', `ghost', or both.
|
"Which pictures of the table are currently wanted: `buffer', `ghost', or both.
|
||||||
|
|
||||||
There is one table, one arming message and one timer, and more than one way to
|
There is one table, one arming message and one push, and more than one way to
|
||||||
look at what they produce. Holding the subscription here rather than in the
|
look at what they produce. Holding the subscription here rather than in the
|
||||||
watch buffer is what lets ghost text outlive that buffer being closed — the
|
watch buffer is what lets ghost text outlive that buffer being closed — the
|
||||||
original design made the buffer *be* the subscription, which was right when it
|
original design made the buffer *be* the subscription, which was right when it
|
||||||
@@ -99,11 +114,9 @@ was the only consumer and wrong the moment it was not.")
|
|||||||
"The buffer's text for ROWS. OVERFLOW means some name found no slot."
|
"The buffer's text for ROWS. OVERFLOW means some name found no slot."
|
||||||
(if (null rows)
|
(if (null rows)
|
||||||
(concat "nothing is being watched\n\n"
|
(concat "nothing is being watched\n\n"
|
||||||
"The program decides what is shown. Call into the watch table\n"
|
"The program decides what is shown. Write into the watch table\n"
|
||||||
"from your own loop:\n\n"
|
"from your own loop:\n\n"
|
||||||
" (declare-c watch-i64 [name string x i64] i32 \"flan_dev_watch_i64\")\n"
|
" (watch \"ticks\" ticks)\n")
|
||||||
" ...\n"
|
|
||||||
" (watch-i64 \"ticks\" ticks)\n")
|
|
||||||
(let ((w (apply #'max (mapcar (lambda (r) (length (car r))) rows))))
|
(let ((w (apply #'max (mapcar (lambda (r) (length (car r))) rows))))
|
||||||
(concat
|
(concat
|
||||||
(mapconcat (lambda (r)
|
(mapconcat (lambda (r)
|
||||||
@@ -153,9 +166,8 @@ was the only consumer and wrong the moment it was not.")
|
|||||||
;; both are painted from the same reply, in `flan-watch--absorb'.
|
;; both are painted from the same reply, in `flan-watch--absorb'.
|
||||||
;;
|
;;
|
||||||
;; WHERE A VALUE ATTACHES. The table carries a name and a rendered string and
|
;; WHERE A VALUE ATTACHES. The table carries a name and a rendered string and
|
||||||
;; no source location, and it is not going to grow one here — that needs a
|
;; no source location. A location is not actually missing: `(watch "hp" hp)'
|
||||||
;; `(watch ...)' form in the checker, which is a file this does not own. But a
|
;; or `(watch-i64 "hp" hp)' is *in the buffer*,
|
||||||
;; location is not actually missing: `(watch-i64 "hp" hp)' is *in the buffer*,
|
|
||||||
;; and the name in the table is the string literal in it. So the anchor is
|
;; and the name in the table is the string literal in it. So the anchor is
|
||||||
;; found by searching the text rather than by being told, which costs one
|
;; found by searching the text rather than by being told, which costs one
|
||||||
;; regexp scan per displayed buffer per repaint and needs nothing new from the
|
;; regexp scan per displayed buffer per repaint and needs nothing new from the
|
||||||
@@ -169,12 +181,11 @@ was the only consumer and wrong the moment it was not.")
|
|||||||
;; the string literal and not the head is what makes that safe: a name in the
|
;; the string literal and not the head is what makes that safe: a name in the
|
||||||
;; table came from one of these call sites by construction.
|
;; table came from one of these call sites by construction.
|
||||||
;;
|
;;
|
||||||
;; WHEN IT UPDATES. On the same timer, from the same reply. The two pictures
|
;; WHEN IT UPDATES. On the same push, from the same frame. The two pictures
|
||||||
;; therefore cannot disagree — they are one table read, painted twice — and
|
;; therefore cannot disagree — they are one table read, painted twice. As
|
||||||
;; there is no second `:op "watch"' in flight, which is the invariant
|
;; with the buffer, the push interval decides how often the picture is
|
||||||
;; `flan-dev-settle-hook' exists to keep. As with the buffer, the timer decides
|
;; repainted and not how fresh it is: the program writes every frame
|
||||||
;; how often the picture is repainted and not how fresh it is: the program
|
;; regardless.
|
||||||
;; writes every frame regardless.
|
|
||||||
;;
|
;;
|
||||||
;; Overlays are deleted and re-placed from scratch on every repaint rather than
|
;; Overlays are deleted and re-placed from scratch on every repaint rather than
|
||||||
;; being tracked across edits. That is the whole answer to the invalidation
|
;; being tracked across edits. That is the whole answer to the invalidation
|
||||||
@@ -211,9 +222,9 @@ Matched against the symbol after an open paren, with the watched name as a
|
|||||||
string literal after it. The default covers `watch', `watch-i64', `watch-f64',
|
string literal after it. The default covers `watch', `watch-i64', `watch-f64',
|
||||||
`watch-str' and the two-segment accumulator names `watch-num-i64' and
|
`watch-str' and the two-segment accumulator names `watch-num-i64' and
|
||||||
`watch-num-f64' — hence the `*\=' rather than a `?\=', which stopped at one
|
`watch-num-f64' — hence the `*\=' rather than a `?\=', which stopped at one
|
||||||
hyphenated segment and so found no site for a numeric watch at all. It is a setting because the Flan name is the program author's
|
hyphenated segment and so found no site for a numeric watch at all. It is a
|
||||||
own `declare-c' binding — only the C symbol behind it is fixed, and the editor
|
setting because the Flan name is the program author's own `declare-c' binding
|
||||||
never sees that."
|
— only the C symbol behind it is fixed, and the editor never sees that."
|
||||||
:type 'regexp)
|
:type 'regexp)
|
||||||
|
|
||||||
(defface flan-watch-ghost-face '((t :inherit shadow))
|
(defface flan-watch-ghost-face '((t :inherit shadow))
|
||||||
@@ -238,15 +249,19 @@ inline it has no modeline beside it to say so.")
|
|||||||
(let (bufs)
|
(let (bufs)
|
||||||
(dolist (w (window-list-1 nil 'nomini t))
|
(dolist (w (window-list-1 nil 'nomini t))
|
||||||
(let ((b (window-buffer w)))
|
(let ((b (window-buffer w)))
|
||||||
(when (and (eq (buffer-local-value 'major-mode b) 'flan-mode)
|
(when (and (provided-mode-derived-p (buffer-local-value 'major-mode b)
|
||||||
|
'flan-base-mode)
|
||||||
(not (memq b bufs)))
|
(not (memq b bufs)))
|
||||||
(push b bufs))))
|
(push b bufs))))
|
||||||
bufs))
|
bufs))
|
||||||
|
|
||||||
(defun flan-watch--ghost-sites ()
|
(defun flan-watch--ghost-sites ()
|
||||||
"Watch call sites in the current buffer, as a list of (NAME . END-OF-LINE)."
|
"Watch call sites in the current buffer, as a list of (NAME . END-OF-LINE)."
|
||||||
(let ((re (concat "(\\s-*" flan-watch-ghost-call-regexp
|
;; Either syntax: `(watch "name" v)' in a .flan file, `watch("name", v)' in
|
||||||
"\\s-+\"\\([^\"\n]*\\)\""))
|
;; a .fln one, where the call is the name glued to its parenthesis.
|
||||||
|
(let ((re (concat "\\(?:(\\s-*\\(?:" flan-watch-ghost-call-regexp "\\)\\s-+"
|
||||||
|
"\\|\\_<\\(?:" flan-watch-ghost-call-regexp "\\)(\\s-*\\)"
|
||||||
|
"\"\\([^\"\n]*\\)\""))
|
||||||
(sites nil))
|
(sites nil))
|
||||||
(save-excursion
|
(save-excursion
|
||||||
(goto-char (point-min))
|
(goto-char (point-min))
|
||||||
@@ -293,7 +308,7 @@ Guarded on the row's length so a short name cannot be claimed by accident."
|
|||||||
(defun flan-watch--ghost-paint (rows overflow)
|
(defun flan-watch--ghost-paint (rows overflow)
|
||||||
"Place inline overlays for ROWS. OVERFLOW means some name found no slot."
|
"Place inline overlays for ROWS. OVERFLOW means some name found no slot."
|
||||||
(flan-watch--ghost-clear)
|
(flan-watch--ghost-clear)
|
||||||
(let ((stale (and flan-dev--stopped t)))
|
(let ((stale (and flan--stopped t)))
|
||||||
(dolist (buf (flan-watch--ghost-buffers))
|
(dolist (buf (flan-watch--ghost-buffers))
|
||||||
(with-current-buffer buf
|
(with-current-buffer buf
|
||||||
(let* ((sites (flan-watch--ghost-sites))
|
(let* ((sites (flan-watch--ghost-sites))
|
||||||
@@ -321,10 +336,10 @@ Guarded on the row's length so a short name cannot be claimed by accident."
|
|||||||
(overlay-put ov 'flan-watch-ghost t)
|
(overlay-put ov 'flan-watch-ghost t)
|
||||||
(push ov flan-watch--ghost-overlays))))))))))
|
(push ov flan-watch--ghost-overlays))))))))))
|
||||||
|
|
||||||
;;; The tick
|
;;; The push
|
||||||
|
|
||||||
(defun flan-watch--absorb (reply)
|
(defun flan-watch--absorb (reply)
|
||||||
"Paint REPLY, a watch answer from the daemon."
|
"Paint REPLY, a watch table from the daemon."
|
||||||
(pcase (plist-get reply :status)
|
(pcase (plist-get reply :status)
|
||||||
("ok"
|
("ok"
|
||||||
(setq flan-watch--rows
|
(setq flan-watch--rows
|
||||||
@@ -343,103 +358,88 @@ Guarded on the row's length so a short name cannot be claimed by accident."
|
|||||||
(flan-watch--paint
|
(flan-watch--paint
|
||||||
(format "error:\n%s\n" (or (plist-get reply :message) "refused"))))))
|
(format "error:\n%s\n" (or (plist-get reply :message) "refused"))))))
|
||||||
|
|
||||||
(defun flan-watch--settle ()
|
;; The daemon sends the table on the connection every `flan-watch-interval'
|
||||||
"Collect an outstanding watch reply, blocking if it has not arrived.
|
;; while it is armed, changed or not, the same way it sends the program's
|
||||||
|
;; output. Nothing here sends a request on a timer, so nothing here can leave
|
||||||
|
;; a reply in flight for another request to read.
|
||||||
|
;;
|
||||||
|
;; Each push closes the numeric slots' accumulation window, so their count,
|
||||||
|
;; range and mean are "since the last push" rather than since the program
|
||||||
|
;; started — except while the program is stopped, when the window is left open
|
||||||
|
;; and the numbers from the moment it stopped stay on the screen. The daemon
|
||||||
|
;; decides that, since it knows whether the program is stopped when it reads
|
||||||
|
;; the table.
|
||||||
|
|
||||||
Hung on `flan-dev-settle-hook', so an ordinary request never reads the watch
|
(defun flan-watch--on-push (kind frame)
|
||||||
timer's reply as its own. Blocking here is fine and blocking in the tick is
|
"Paint FRAME when KIND says it is the watch table."
|
||||||
not: this runs inside something a person asked for, which already waits, and
|
(when (and (equal kind "watch") flan-watch--consumers)
|
||||||
what it waits for is a table read with nothing compiled behind it."
|
(flan-watch--absorb frame)))
|
||||||
(when flan-watch--pending
|
|
||||||
(setq flan-watch--pending nil)
|
|
||||||
(when-let* ((proc flan-dev--connection))
|
|
||||||
(when (process-live-p proc)
|
|
||||||
(ignore-errors (flan-watch--absorb (flan-dev--read-reply proc)))))))
|
|
||||||
|
|
||||||
(defun flan-watch--tick ()
|
(defun flan-watch--on-connect ()
|
||||||
"Collect the last reply if it has come, then ask again. Never blocks.
|
"Arm the table again on a new connection, if anything is watching.
|
||||||
|
A restarted daemon has a new program, and the new program's table is off."
|
||||||
|
(when flan-watch--consumers
|
||||||
|
(let ((r (ignore-errors (flan-watch--arm t))))
|
||||||
|
(unless (equal (plist-get r :status) "ok")
|
||||||
|
(flan-watch--paint
|
||||||
|
(format "error:\n%s\n"
|
||||||
|
(or (plist-get r :message) "the table could not be armed")))))))
|
||||||
|
|
||||||
Deliberately not `flan-dev--request', which waits for its answer: a
|
(defun flan-watch--on-disconnect ()
|
||||||
synchronous call on a 0.2s timer stalls Emacs's UI every tick, and a timer is
|
"Say that the table is no longer live."
|
||||||
the one caller that must not. So this takes whatever has already arrived and
|
(when flan-watch--consumers
|
||||||
sends the next question, leaving at most one request in flight — the invariant
|
(flan-watch--ghost-clear)
|
||||||
`flan-dev-settle-hook' exists to keep."
|
(flan-watch--paint "error:\nnot connected to a running program\n")))
|
||||||
(cond
|
|
||||||
;; Killing the buffer cancels the buffer's half of the subscription, and
|
(defun flan-watch--arm (on)
|
||||||
;; only that. When it was the only consumer this stops the timer and
|
"Ask the daemon to arm the table and push it, or to disarm it when ON is nil."
|
||||||
;; disarms the table, so a program nobody is watching is back to paying a
|
(flan--request (if on
|
||||||
;; load and a branch per watch call; when ghost text is also on, the table
|
`(:op "watch-enable" :on t :interval ,flan-watch-interval)
|
||||||
;; stays armed and the ticks carry on feeding it.
|
'(:op "watch-enable" :on nil))))
|
||||||
((and (memq 'buffer flan-watch--consumers)
|
|
||||||
(not (get-buffer flan-watch-buffer)))
|
|
||||||
(flan-watch--drop 'buffer))
|
|
||||||
((not (process-live-p flan-dev--connection))
|
|
||||||
(flan-watch--paint "error:\nnot connected to a running program\n")
|
|
||||||
(flan-watch-stop))
|
|
||||||
;; Something else owns the connection this instant — an evaluation is
|
|
||||||
;; mid-flight. Skipping is right: its `flan-dev-settle-hook' has already
|
|
||||||
;; taken any reply of ours, and the next tick is 0.2s away.
|
|
||||||
(flan-dev--busy nil)
|
|
||||||
(t
|
|
||||||
(when flan-watch--pending
|
|
||||||
(when-let* ((reply (flan-dev--take-reply flan-dev--connection)))
|
|
||||||
(setq flan-watch--pending nil)
|
|
||||||
(flan-watch--absorb reply)))
|
|
||||||
(unless flan-watch--pending
|
|
||||||
(condition-case nil
|
|
||||||
;; `:reset t' opens a new accumulation window for the numeric
|
|
||||||
;; slots, so their count, range and mean are "since the last tick"
|
|
||||||
;; rather than since the program started. That is the whole of the
|
|
||||||
;; accumulator decision as the editor sees it: a min and a max over
|
|
||||||
;; a session go dead within seconds of play, and this tool exists to
|
|
||||||
;; show a number while you drag the mouse. The reset happens after
|
|
||||||
;; the read, on the daemon's side, so this tick's numbers are the
|
|
||||||
;; last tick's window and nothing is lost between the two.
|
|
||||||
;;
|
|
||||||
;; Except while the program is stopped, when the read still happens
|
|
||||||
;; and the reset does not. A stopped program takes no samples, so
|
|
||||||
;; there is no window for a reset to close and none for it to open:
|
|
||||||
;; the runtime clears a slot lazily, on its next sample, which is
|
|
||||||
;; what keeps a paused program showing the numbers from the moment
|
|
||||||
;; you paused it — the whole reason to pause. Resetting anyway
|
|
||||||
;; would ask for a new window five times a second that nothing can
|
|
||||||
;; fill. The guard lives here rather than in the runtime because
|
|
||||||
;; "since you last looked" is the editor's policy, not the table's.
|
|
||||||
;; `flan-dev--stopped' is the one place that state is tracked, and
|
|
||||||
;; `flan-dev.el''s background poll keeps it current whether or not
|
|
||||||
;; anyone is evaluating.
|
|
||||||
(progn (flan-dev--send flan-dev--connection
|
|
||||||
(if flan-dev--stopped
|
|
||||||
'(:op "watch")
|
|
||||||
'(:op "watch" :reset t)))
|
|
||||||
(setq flan-watch--pending t))
|
|
||||||
(error (flan-watch-stop)))))))
|
|
||||||
|
|
||||||
;;; Commands
|
;;; Commands
|
||||||
|
|
||||||
|
(defvar flan-watch-mode-map
|
||||||
|
(let ((map (make-sparse-keymap)))
|
||||||
|
;; As `flan-doc-mode-map'.
|
||||||
|
(define-key map "q" #'quit-window)
|
||||||
|
map)
|
||||||
|
"Keys in `flan-watch-mode'.")
|
||||||
|
|
||||||
|
(flan-evil-own-keys 'flan-watch-mode-map)
|
||||||
|
|
||||||
(define-derived-mode flan-watch-mode special-mode "flan-watch"
|
(define-derived-mode flan-watch-mode special-mode "flan-watch"
|
||||||
"Major mode for the pinned watch buffer."
|
"Major mode for the pinned watch buffer."
|
||||||
(setq-local truncate-lines t))
|
(setq-local truncate-lines t)
|
||||||
|
;; Killing the buffer cancels the buffer's half of the subscription, and only
|
||||||
|
;; that. When it was the only consumer the table is disarmed, so a program
|
||||||
|
;; nobody is watching is back to paying a load and a branch per watch call;
|
||||||
|
;; when ghost text is also on, the table stays armed.
|
||||||
|
(add-hook 'kill-buffer-hook #'flan-watch--buffer-killed nil t))
|
||||||
|
|
||||||
|
(defun flan-watch--buffer-killed ()
|
||||||
|
"Drop the buffer consumer, the watch buffer being killed."
|
||||||
|
(when (memq 'buffer flan-watch--consumers)
|
||||||
|
(flan-watch--drop 'buffer)))
|
||||||
|
|
||||||
(defun flan-watch--subscribe (consumer)
|
(defun flan-watch--subscribe (consumer)
|
||||||
"Arm the table for CONSUMER and make sure the shared timer is running.
|
"Arm the table for CONSUMER.
|
||||||
|
|
||||||
Arming is a message, not something the daemon infers. The program is the
|
Arming is a message, not something the daemon infers. The program is the
|
||||||
writer, so it has to be told somebody is looking — and while nobody is, nothing
|
writer, so it has to be told somebody is looking — and while nobody is, nothing
|
||||||
writes the table at all, which is what makes a watch call in a program nobody is
|
writes the table at all, which is what makes a watch call in a program nobody is
|
||||||
debugging a load and a not-taken branch. It is sent once for the first
|
debugging a load and a not-taken branch. It is sent once for the first
|
||||||
consumer: two of them looking at one table is still one table."
|
consumer: two of them looking at one table is still one table."
|
||||||
(flan-dev--live-connection)
|
(flan--live-connection)
|
||||||
(unless flan-watch--consumers
|
(unless flan-watch--consumers
|
||||||
(let ((r (flan-dev--request '(:op "watch-enable" :on t))))
|
(let ((r (flan-watch--arm t)))
|
||||||
(unless (equal (plist-get r :status) "ok")
|
(unless (equal (plist-get r :status) "ok")
|
||||||
(user-error "flan: %s" (or (plist-get r :message) "watch refused")))))
|
(user-error "flan: %s" (or (plist-get r :message) "watch refused")))))
|
||||||
(unless (memq consumer flan-watch--consumers)
|
(unless (memq consumer flan-watch--consumers)
|
||||||
(push consumer flan-watch--consumers))
|
(push consumer flan-watch--consumers))
|
||||||
(add-hook 'flan-dev-settle-hook #'flan-watch--settle)
|
(add-hook 'flan-push-functions #'flan-watch--on-push)
|
||||||
(when flan-watch--timer (cancel-timer flan-watch--timer))
|
(add-hook 'flan-connected-hook #'flan-watch--on-connect)
|
||||||
(setq flan-watch--timer
|
(add-hook 'flan-disconnected-hook #'flan-watch--on-disconnect))
|
||||||
(run-with-timer 0 flan-watch-interval #'flan-watch--tick)))
|
|
||||||
|
|
||||||
(defun flan-watch--drop (consumer)
|
(defun flan-watch--drop (consumer)
|
||||||
"Stop painting CONSUMER, and tear everything down if it was the last one."
|
"Stop painting CONSUMER, and tear everything down if it was the last one."
|
||||||
@@ -454,7 +454,7 @@ consumer: two of them looking at one table is still one table."
|
|||||||
(flan-watch--subscribe 'buffer)
|
(flan-watch--subscribe 'buffer)
|
||||||
(with-current-buffer (get-buffer-create flan-watch-buffer)
|
(with-current-buffer (get-buffer-create flan-watch-buffer)
|
||||||
(unless (eq major-mode 'flan-watch-mode) (flan-watch-mode)))
|
(unless (eq major-mode 'flan-watch-mode) (flan-watch-mode)))
|
||||||
;; Painted before the first reply, rather than left blank until one arrives.
|
;; Painted before the first push, rather than left blank until one arrives.
|
||||||
;; An empty buffer is the same picture as a broken one, and the likeliest
|
;; An empty buffer is the same picture as a broken one, and the likeliest
|
||||||
;; reason for it here is the honest one — the program is not calling into the
|
;; reason for it here is the honest one — the program is not calling into the
|
||||||
;; table — which is worth saying in words rather than by showing nothing.
|
;; table — which is worth saying in words rather than by showing nothing.
|
||||||
@@ -488,21 +488,15 @@ Tears down both consumers. `flan-watch--drop' is the way to stop one of them."
|
|||||||
;; `flan-watch--drop' and back into here.
|
;; `flan-watch--drop' and back into here.
|
||||||
(setq flan-watch-ghost-mode nil)
|
(setq flan-watch-ghost-mode nil)
|
||||||
(flan-watch--ghost-clear)
|
(flan-watch--ghost-clear)
|
||||||
(when flan-watch--timer
|
(remove-hook 'flan-push-functions #'flan-watch--on-push)
|
||||||
(cancel-timer flan-watch--timer)
|
(remove-hook 'flan-connected-hook #'flan-watch--on-connect)
|
||||||
(setq flan-watch--timer nil))
|
(remove-hook 'flan-disconnected-hook #'flan-watch--on-disconnect)
|
||||||
;; Settle before disarming, or the disarm request reads the tick's reply.
|
;; Only on a connection that is already live. `flan--request' reconnects,
|
||||||
(flan-watch--settle)
|
;; which is right for something a person did and wrong here: there is
|
||||||
(remove-hook 'flan-dev-settle-hook #'flan-watch--settle)
|
;; nothing to disarm when the connection has gone, because the table went
|
||||||
;; Only on a connection that is already live, and this is the important half.
|
;; with the program.
|
||||||
;; `flan-dev--request' *reconnects* — which is right for something a person
|
(when (process-live-p flan--connection)
|
||||||
;; did and wrong here, because this is also called from the tick, and the
|
(ignore-errors (flan-watch--arm nil))))
|
||||||
;; reason the tick calls it is that the connection has gone. Reconnecting
|
|
||||||
;; from a timer would quietly erase the `lost' state that exists to be seen,
|
|
||||||
;; which `flan-dev.el' already forbids for its own poll timer. And there is
|
|
||||||
;; nothing to disarm anyway: the table went with the program.
|
|
||||||
(when (process-live-p flan-dev--connection)
|
|
||||||
(ignore-errors (flan-dev--request '(:op "watch-enable" :on nil)))))
|
|
||||||
|
|
||||||
;;; What ghost text still cannot show
|
;;; What ghost text still cannot show
|
||||||
|
|
||||||
@@ -527,13 +521,13 @@ Tears down both consumers. `flan-watch--drop' is the way to stop one of them."
|
|||||||
;; - The module in the running program can be older than the buffer. A site
|
;; - The module in the running program can be older than the buffer. A site
|
||||||
;; you have typed but not yet installed with `C-c C-c' has no row, and one
|
;; you have typed but not yet installed with `C-c C-c' has no row, and one
|
||||||
;; you deleted but not yet installed still writes. Deliberately unreported:
|
;; you deleted but not yet installed still writes. Deliberately unreported:
|
||||||
;; the stale-caller machinery in `flan-dev.el' already tracks what needs
|
;; the stale-caller machinery in `flan.el' already tracks what needs
|
||||||
;; re-evaluating, and a second opinion about it here would be a worse one.
|
;; re-evaluating, and a second opinion about it here would be a worse one.
|
||||||
;;
|
;;
|
||||||
;; Still genuinely blocked on the checker, and unchanged by any of this: a
|
;; Still genuinely blocked on the checker, and unchanged by any of this: a
|
||||||
;; **struct or a slice**. Rendering one is a compile-time walk over its type,
|
;; **struct or a slice**. Rendering one is a compile-time walk over its type,
|
||||||
;; the runtime has scalar entry points only, and no amount of searching the
|
;; the runtime has scalar entry points only, and no amount of searching the
|
||||||
;; buffer produces a value the table does not hold. See BUILT.md.
|
;; buffer produces a value the table does not hold. See docs/BUILT.md.
|
||||||
|
|
||||||
(provide 'flan-watch)
|
(provide 'flan-watch)
|
||||||
;;; flan-watch.el ends here
|
;;; flan-watch.el ends here
|
||||||
+4287
File diff suppressed because it is too large.
Load diff
+1512
-92
File diff suppressed because it is too large.
Load diff
File diff suppressed because it is too large.
Load diff
@@ -0,0 +1,460 @@
|
|||||||
|
;;; test-flan-fln-live.el --- The .fln keys against a real daemon -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Loaded by test-flan.el, near its end, with `flan-command' already the
|
||||||
|
;; compiler under test. test-flan-fln.el checks which text each key picks;
|
||||||
|
;; this checks the reader accepts that text as a whole form, on both backends:
|
||||||
|
;; an image of its own with a .fln file with no main loaded into it, once on
|
||||||
|
;; x86 and once on LLVM, each key sent at least once, and a pause mark the
|
||||||
|
;; daemon must find.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'flan-fln-mode)
|
||||||
|
|
||||||
|
(declare-function test-flan--check "test-flan" (name ok))
|
||||||
|
(declare-function test-flan--result "test-flan" ())
|
||||||
|
(defvar test-flan-fln-live-dir)
|
||||||
|
(defvar test-flan-fln-live-socket)
|
||||||
|
|
||||||
|
(defconst test-flan-fln-live--program
|
||||||
|
"fn fib(n: i64) -> i64
|
||||||
|
if n < 2
|
||||||
|
n
|
||||||
|
else
|
||||||
|
fib(n - 1) + fib(n - 2)
|
||||||
|
|
||||||
|
fn twice(n: i64) -> i64 = n * 2
|
||||||
|
|
||||||
|
fn total(n: i32) -> i32
|
||||||
|
let t = 0
|
||||||
|
for i in 0..n
|
||||||
|
t = t + i
|
||||||
|
t
|
||||||
|
|
||||||
|
fn sign(n: i64) -> i64
|
||||||
|
if n < 0
|
||||||
|
-1
|
||||||
|
elif n == 0
|
||||||
|
0
|
||||||
|
else
|
||||||
|
1
|
||||||
|
|
||||||
|
enum Dir
|
||||||
|
north
|
||||||
|
south
|
||||||
|
east
|
||||||
|
|
||||||
|
fn pick(d: Dir) -> i64
|
||||||
|
match d
|
||||||
|
:north -> 10
|
||||||
|
:south -> 20
|
||||||
|
:east -> 1 +
|
||||||
|
2
|
||||||
|
_ ->
|
||||||
|
twice(3)
|
||||||
|
|
||||||
|
fn sign2(k: i64)
|
||||||
|
if k < 0 then -1
|
||||||
|
elif k == 0 then 0
|
||||||
|
else 1
|
||||||
|
|
||||||
|
fn size(k: i64) -> i64
|
||||||
|
if k < 10
|
||||||
|
1
|
||||||
|
else 2
|
||||||
|
|
||||||
|
fn lam(k: i64) -> i64
|
||||||
|
let add = fn(a: i64, b: i64) -> i64 => a + b
|
||||||
|
let dbl = fn(a: i64) -> i64 =>
|
||||||
|
a * 2
|
||||||
|
add(dbl(k), 1)
|
||||||
|
|
||||||
|
fn app(x: i64, f: Fn(i64) -> i64) -> i64 = f(x)
|
||||||
|
|
||||||
|
fn lam2(k: i64) -> i64
|
||||||
|
let a = 1
|
||||||
|
let b = app(k, fn(x) =>
|
||||||
|
let y = x + a
|
||||||
|
y)
|
||||||
|
let c = fn(z: i64) -> i64 =>
|
||||||
|
z * 2
|
||||||
|
c(b)
|
||||||
|
|
||||||
|
fn rs() -> i64
|
||||||
|
restart-case
|
||||||
|
3
|
||||||
|
restart retry() \"Try again\"
|
||||||
|
4
|
||||||
|
|
||||||
|
fn t2(k: i64) -> i64
|
||||||
|
let a = 1
|
||||||
|
let b = 2
|
||||||
|
let c: i64 = 3
|
||||||
|
a + b + c + k
|
||||||
|
|
||||||
|
fn dir(d: Dir) -> i64
|
||||||
|
match d
|
||||||
|
Dir.north -> 7
|
||||||
|
_ -> 8
|
||||||
|
|
||||||
|
struct Oops :parent Error
|
||||||
|
code: i64
|
||||||
|
|
||||||
|
type Count = i64
|
||||||
|
|
||||||
|
let speed: i64 = 3
|
||||||
|
|
||||||
|
fn speed-of() -> i64 = speed
|
||||||
|
|
||||||
|
struct Pair(a: i64, b: i64)
|
||||||
|
|
||||||
|
fn pair-sum(p: Pair) -> i64 = p.a + p.b
|
||||||
|
|
||||||
|
class shape(w, h)
|
||||||
|
|
||||||
|
generic area(s) -> dyn
|
||||||
|
|
||||||
|
method area(s: shape) = get(s, :w) * get(s, :h)
|
||||||
|
|
||||||
|
multi kind(v) -> dyn = type-of(v)
|
||||||
|
|
||||||
|
method kind(v) when :int = 1
|
||||||
|
|
||||||
|
method kind(v) when :else
|
||||||
|
0
|
||||||
|
|
||||||
|
fn counted(n: Count) -> Count = n + 1
|
||||||
|
|
||||||
|
fn oops-code() -> i64
|
||||||
|
handler-case
|
||||||
|
error(Oops{.code 7})
|
||||||
|
on Oops(c)
|
||||||
|
c.code
|
||||||
|
|
||||||
|
macro dbl-of(x, ...more)
|
||||||
|
quote
|
||||||
|
~x + ~x
|
||||||
|
|
||||||
|
fn use-mac(k: i64) -> i64 = dbl-of(k)
|
||||||
|
|
||||||
|
fn gcd(a: i64, b: i64) -> i64
|
||||||
|
let x = a
|
||||||
|
let y = b
|
||||||
|
while y != 0
|
||||||
|
let r = x % y
|
||||||
|
x = y
|
||||||
|
y = r
|
||||||
|
x
|
||||||
|
|
||||||
|
fn sum-to(n: i64) -> i64
|
||||||
|
let i = 0
|
||||||
|
let acc = 0
|
||||||
|
until i > n
|
||||||
|
acc += i
|
||||||
|
i += 1
|
||||||
|
acc
|
||||||
|
|
||||||
|
comment():
|
||||||
|
if 1 < 2 and
|
||||||
|
3 < 4
|
||||||
|
twice(1)
|
||||||
|
elif 1 > 2 or
|
||||||
|
3 > 4
|
||||||
|
0
|
||||||
|
app(5, fn(a) =>
|
||||||
|
a * 3
|
||||||
|
)
|
||||||
|
if 2 < 1 then 5
|
||||||
|
elif 2 == 1 then 6
|
||||||
|
else 7
|
||||||
|
twice(4)
|
||||||
|
if 2 > 1
|
||||||
|
twice(2)
|
||||||
|
else
|
||||||
|
0
|
||||||
|
let x = 3
|
||||||
|
twice(x) + 1
|
||||||
|
|
||||||
|
fn grp(k: i64) -> i64
|
||||||
|
let a = k + 1
|
||||||
|
b = a * 2
|
||||||
|
a + b
|
||||||
|
|
||||||
|
comment():
|
||||||
|
let u = 2
|
||||||
|
v = u * 5
|
||||||
|
u + v
|
||||||
|
")
|
||||||
|
|
||||||
|
(defun test-flan-fln-live--run (backend args)
|
||||||
|
(let* ((file (expand-file-name (format "fln-live-%s.fln" backend)
|
||||||
|
test-flan-fln-live-dir))
|
||||||
|
(flan-daemon-args args)
|
||||||
|
(name (lambda (s) (format "%s: %s" backend s)))
|
||||||
|
(value (lambda (code)
|
||||||
|
(plist-get (flan--request
|
||||||
|
(list :op "eval-expr" :code code :file "<test>"))
|
||||||
|
:value)))
|
||||||
|
(goto (lambda (needle &optional after)
|
||||||
|
(goto-char (point-min))
|
||||||
|
(search-forward needle)
|
||||||
|
(unless after (goto-char (match-beginning 0)))))
|
||||||
|
(shows (lambda (v)
|
||||||
|
(let ((r (test-flan--result)))
|
||||||
|
(prog1 (and r (string-match-p (concat "=> " (regexp-quote v) "\\'")
|
||||||
|
(string-trim r)))
|
||||||
|
(flan-clear-result))))))
|
||||||
|
(with-temp-file file (insert test-flan-fln-live--program))
|
||||||
|
(flan test-flan-fln-live-dir)
|
||||||
|
(with-current-buffer (find-file-noselect file) (flan-eval-buffer))
|
||||||
|
(test-flan--check (funcall name "a .fln file loads into an image")
|
||||||
|
(process-live-p flan--connection))
|
||||||
|
(unwind-protect
|
||||||
|
(with-current-buffer (find-file-noselect file)
|
||||||
|
(test-flan--check (funcall name "which opens in flan-fln-mode")
|
||||||
|
(eq major-mode 'flan-fln-mode))
|
||||||
|
|
||||||
|
;; C-c C-c, from inside a fn changed in the buffer.
|
||||||
|
(funcall goto "n * 2")
|
||||||
|
(delete-char 5)
|
||||||
|
(insert "n * 3")
|
||||||
|
(flan-fln-eval-defun)
|
||||||
|
(test-flan--check (funcall name "C-c C-c installs the fn at point")
|
||||||
|
(equal (funcall value "(twice 7)") "21"))
|
||||||
|
|
||||||
|
;; C-x C-e at the end of a column-0 declaration.
|
||||||
|
(funcall goto "n * 3")
|
||||||
|
(delete-char 5)
|
||||||
|
(insert "n * 4")
|
||||||
|
(flan-fln-eval-last)
|
||||||
|
(test-flan--check (funcall name "C-x C-e at the end of a column-0 fn installs it")
|
||||||
|
(equal (funcall value "(twice 7)") "28"))
|
||||||
|
|
||||||
|
;; C-x C-e at the end of an inner statement: text from column 3.
|
||||||
|
(funcall goto "twice(4)" t)
|
||||||
|
(flan-fln-eval-last)
|
||||||
|
(test-flan--check (funcall name "C-x C-e sends the statement ending at point")
|
||||||
|
(funcall shows "16"))
|
||||||
|
|
||||||
|
;; ...and inside a line, the term before point.
|
||||||
|
(funcall goto "twice(4)")
|
||||||
|
(let ((at (point)))
|
||||||
|
(insert "fib(10) + ")
|
||||||
|
(goto-char (+ at (length "fib(10)")))
|
||||||
|
(flan-fln-eval-last)
|
||||||
|
(test-flan--check (funcall name "C-x C-e inside a line sends the term before point")
|
||||||
|
(funcall shows "55"))
|
||||||
|
(delete-region at (+ at (length "fib(10) + "))))
|
||||||
|
|
||||||
|
;; C-c C-e on a clause: the whole if, from column 3, clauses and all.
|
||||||
|
(funcall goto "else\n 0")
|
||||||
|
(flan-fln-eval-statement)
|
||||||
|
(test-flan--check (funcall name "C-c C-e on a clause sends its if, and it reads")
|
||||||
|
(funcall shows "8"))
|
||||||
|
|
||||||
|
;; A bare let: it and the rest of its block, which is its scope.
|
||||||
|
(funcall goto "let x = 3")
|
||||||
|
(flan-fln-eval-statement)
|
||||||
|
(test-flan--check (funcall name "C-c C-e on a bare let sends its scope with it")
|
||||||
|
(funcall shows "13"))
|
||||||
|
|
||||||
|
;; A let's bindings on the lines under it go with it, and read.
|
||||||
|
(funcall goto "v = u * 5")
|
||||||
|
(flan-fln-eval-statement)
|
||||||
|
(test-flan--check (funcall name "C-c C-e on a binding line sends its let's group and scope")
|
||||||
|
(funcall shows "12"))
|
||||||
|
|
||||||
|
;; A region of several statements reads as one (do ...).
|
||||||
|
(funcall goto "twice(4)")
|
||||||
|
(transient-mark-mode 1)
|
||||||
|
(set-mark (point))
|
||||||
|
(funcall goto "else\n 0" t)
|
||||||
|
(flan-fln-eval-statement)
|
||||||
|
(test-flan--check (funcall name "C-c C-e on a region of statements evaluates them in order")
|
||||||
|
(funcall shows "8"))
|
||||||
|
|
||||||
|
;; C-c C-n sends and moves on.
|
||||||
|
(funcall goto "twice(4)")
|
||||||
|
(flan-fln-eval-statement-and-next)
|
||||||
|
(test-flan--check (funcall name "C-c C-n sends the statement")
|
||||||
|
(funcall shows "16"))
|
||||||
|
(test-flan--check (funcall name "and moves to the next")
|
||||||
|
(looking-at "if 2 > 1"))
|
||||||
|
|
||||||
|
;; A one-line if with its clauses on the lines under it.
|
||||||
|
(funcall goto "if 2 < 1 then 5" t)
|
||||||
|
(flan-fln-eval-last)
|
||||||
|
(test-flan--check (funcall name "C-x C-e at the end of a one-line if that goes on evaluates the whole if")
|
||||||
|
(funcall shows "7"))
|
||||||
|
(funcall goto "elif 2 == 1")
|
||||||
|
(flan-fln-eval-statement)
|
||||||
|
(test-flan--check (funcall name "C-c C-e on a clause under a one-line if sends its if")
|
||||||
|
(funcall shows "7"))
|
||||||
|
;; The newer forms install from the buffer and run.
|
||||||
|
(pcase-dolist (`(,needle ,call ,want)
|
||||||
|
'(("fn sign2" "(sign2 0)" "0")
|
||||||
|
("fn size" "(size 20)" "2")
|
||||||
|
("fn lam" "(lam 3)" "7")
|
||||||
|
("fn lam2" "(lam2 3)" "8")
|
||||||
|
("fn rs" "(rs)" "3")
|
||||||
|
("fn dir" "(dir :north)" "7")
|
||||||
|
("struct Oops" "(oops-code)" "7")
|
||||||
|
("type Count" "(counted 1)" "2")
|
||||||
|
("struct Pair" "(pair-sum (Pair {.a 1 .b 2}))" "3")
|
||||||
|
("fn pair-sum" "(pair-sum (Pair {.a 1 .b 2}))" "3")
|
||||||
|
("class shape" "(i64 (area (shape 2 3)))" "6")
|
||||||
|
("generic area" "(i64 (area (shape 2 3)))" "6")
|
||||||
|
("method area" "(i64 (area (shape 2 3)))" "6")
|
||||||
|
("multi kind" "(i64 (kind 3))" "1")
|
||||||
|
("method kind(v) when :else" "(i64 (kind :x))" "0")
|
||||||
|
("fn counted" "(counted 1)" "2")
|
||||||
|
("fn oops-code" "(oops-code)" "7")
|
||||||
|
("macro dbl-of" "(use-mac 5)" "10")
|
||||||
|
("fn use-mac" "(use-mac 5)" "10")
|
||||||
|
("fn gcd" "(gcd 1071 462)" "21")
|
||||||
|
("fn sum-to" "(sum-to 4)" "10")))
|
||||||
|
(funcall goto needle)
|
||||||
|
(flan-fln-eval-defun)
|
||||||
|
(test-flan--check (funcall name (format "C-c C-c installs %s" needle))
|
||||||
|
(equal (funcall value call) want)))
|
||||||
|
|
||||||
|
;; A top-level let is a global, installed and re-run by C-c C-c.
|
||||||
|
(funcall goto "let speed: i64 = 3")
|
||||||
|
(end-of-line)
|
||||||
|
(delete-char -1)
|
||||||
|
(insert "9")
|
||||||
|
(flan-fln-eval-defun)
|
||||||
|
(test-flan--check (funcall name "C-c C-c on a top-level let installs the global")
|
||||||
|
(equal (funcall value "(speed-of)") "9"))
|
||||||
|
|
||||||
|
;; A macro changed in the buffer and installed again reaches the
|
||||||
|
;; function installed after it.
|
||||||
|
(funcall goto "~x + ~x")
|
||||||
|
(delete-char 7)
|
||||||
|
(insert "~x * 3")
|
||||||
|
(funcall goto "macro dbl-of")
|
||||||
|
(flan-fln-eval-defun)
|
||||||
|
(funcall goto "fn use-mac")
|
||||||
|
(flan-fln-eval-defun)
|
||||||
|
(test-flan--check (funcall name "C-c C-c on a changed macro takes effect")
|
||||||
|
(equal (funcall value "(use-mac 5)") "15"))
|
||||||
|
|
||||||
|
;; The pause mark. What is sent is a line and column, and the daemon
|
||||||
|
;; answers `:pause' only when a form the reader made starts exactly
|
||||||
|
;; there (`Ast.mark_pause'). Each kind of target once, and one position
|
||||||
|
;; a column off to show the answer can be no.
|
||||||
|
;; C-x C-e on an arm's value, and on a condition line.
|
||||||
|
(funcall goto ":south -> 20" t)
|
||||||
|
(flan-fln-eval-last)
|
||||||
|
(test-flan--check (funcall name "C-x C-e at the end of a match arm evaluates its value")
|
||||||
|
(funcall shows "20"))
|
||||||
|
(funcall goto ":east -> 1 +" t)
|
||||||
|
(flan-fln-eval-last)
|
||||||
|
(test-flan--check (funcall name "C-x C-e on an arm's wrapped value evaluates all of it")
|
||||||
|
(funcall shows "3"))
|
||||||
|
(funcall goto "if 1 < 2 and" t)
|
||||||
|
(flan-fln-eval-last)
|
||||||
|
(test-flan--check (funcall name "C-x C-e on a wrapped condition evaluates all of it")
|
||||||
|
(funcall shows "true"))
|
||||||
|
;; An error on the wrapped line of a condition or value cut out
|
||||||
|
;; mid-line is reported where it is in the buffer, column and all.
|
||||||
|
(let ((refused
|
||||||
|
(lambda (needle bad fix)
|
||||||
|
(funcall goto needle t)
|
||||||
|
(let ((line (1+ (line-number-at-pos))) col)
|
||||||
|
(save-excursion
|
||||||
|
(forward-line 1)
|
||||||
|
(search-forward fix (line-end-position))
|
||||||
|
(replace-match bad t t)
|
||||||
|
(setq col (1+ (- (point) (line-beginning-position)
|
||||||
|
(length (car (last (split-string bad " "))))))))
|
||||||
|
(prog1 (list (condition-case err (progn (flan-fln-eval-last) nil)
|
||||||
|
(user-error (error-message-string err)))
|
||||||
|
(format ":%d:%d)" line col))
|
||||||
|
(save-excursion
|
||||||
|
(goto-char (point-min))
|
||||||
|
(search-forward bad)
|
||||||
|
(replace-match fix t t)))))))
|
||||||
|
(pcase-dolist (`(,what ,needle ,bad ,fix)
|
||||||
|
'(("an if condition" "if 1 < 2 and" "3 < 4 4" "3 < 4")
|
||||||
|
("an elif condition" "elif 1 > 2 or" "3 > 4 4" "3 > 4")
|
||||||
|
("an arm's value" ":east -> 1 +" "2 2" "2")))
|
||||||
|
(let ((r (funcall refused needle bad fix)))
|
||||||
|
(test-flan--check
|
||||||
|
(funcall name (format "an error on the wrapped line of %s is reported at its column" what))
|
||||||
|
(and (car r) (string-suffix-p (cadr r) (car r))))
|
||||||
|
(unless (and (car r) (string-suffix-p (cadr r) (car r)))
|
||||||
|
(message " want ...%s\n got %S" (cadr r) (car r))))))
|
||||||
|
(flan-clear-errors)
|
||||||
|
;; A lambda's block inside a call's brackets: the call goes whole
|
||||||
|
;; from its header line, and reads.
|
||||||
|
(funcall goto "app(5")
|
||||||
|
(flan-fln-eval-statement)
|
||||||
|
(test-flan--check (funcall name "C-c C-e on a call with a block lambda sends it whole, and it reads")
|
||||||
|
(funcall shows "15"))
|
||||||
|
(funcall goto "app(5, fn(a) =>" t)
|
||||||
|
(flan-fln-eval-last)
|
||||||
|
(test-flan--check (funcall name "C-x C-e at the end of its header line too")
|
||||||
|
(funcall shows "15"))
|
||||||
|
(funcall goto "if 2 > 1" t)
|
||||||
|
(flan-fln-eval-last)
|
||||||
|
(test-flan--check (funcall name "C-x C-e at the end of an if line evaluates the condition")
|
||||||
|
(funcall shows "true"))
|
||||||
|
(dolist (c '(("n - 1)" "a call, from its name")
|
||||||
|
("elif n" "an elif, at its condition")
|
||||||
|
("else\n 1" "an else, at its block")
|
||||||
|
(":south -> 20" "a match arm, at its value")
|
||||||
|
("_ ->" "a match arm, at its block")
|
||||||
|
("n < 2" "an if statement")
|
||||||
|
("t = 0" "a let")
|
||||||
|
("i in 0..n" "a for")
|
||||||
|
("+ i" "an assignment")
|
||||||
|
("if k < 0 then" "a one-line if")
|
||||||
|
("elif k" "a one-line elif, at its condition")
|
||||||
|
("else 1" "a one-line else, at its value")
|
||||||
|
("else 2" "a one-line else after a block, at its value")
|
||||||
|
("a: i64, b" "a typed lambda, from its fn")
|
||||||
|
("a * 2" "a typed lambda's block")
|
||||||
|
("x) =>" "a block lambda in a call, from its fn")
|
||||||
|
("let y = x" "a statement in a block lambda's block")
|
||||||
|
("y)" "the block's last statement, less the call's closer")
|
||||||
|
("let b = app" "a merged let's call with a block lambda, at its value")
|
||||||
|
("let c = fn" "a merged let's block lambda, at its value")
|
||||||
|
("restart retry" "a restart with a report, at its block")
|
||||||
|
("Dir.north" "an enum member's arm, at its value")
|
||||||
|
("let b = 2" "a let the let above takes in, at its value")
|
||||||
|
("let c: i64" "a typed one, at its value")
|
||||||
|
("while y != 0" "a while, at its word")
|
||||||
|
("let r = x % y" "a while's block")
|
||||||
|
("until i > n" "an until, at its word")
|
||||||
|
("acc += i" "an until's block")
|
||||||
|
("b = a * 2" "a binding under a let, at its value")))
|
||||||
|
(funcall goto (car c))
|
||||||
|
(let ((reply (flan-fln-eval-defun '(4))))
|
||||||
|
(test-flan--check (funcall name (format "C-u C-c C-c marks %s where the reader starts it"
|
||||||
|
(cadr c)))
|
||||||
|
(plist-get reply :pause)))
|
||||||
|
(flan-fln-eval-defun))
|
||||||
|
(test-flan--check (funcall name "and a plain C-c C-c takes the mark down")
|
||||||
|
(null (flan--pause-overlays)))
|
||||||
|
(funcall goto "fib(n - 1)")
|
||||||
|
(let* ((b (flan-fln--toplevel-bounds (point)))
|
||||||
|
(off (condition-case nil
|
||||||
|
(plist-get (flan--eval (flan--text (car b) (cdr b)) "defn"
|
||||||
|
nil nil (cons (1+ (point)) (+ 3 (point))))
|
||||||
|
:pause)
|
||||||
|
(user-error nil))))
|
||||||
|
(test-flan--check (funcall name "a position one column off the call is not taken")
|
||||||
|
(null off)))
|
||||||
|
(flan-fln-eval-defun)
|
||||||
|
(set-buffer-modified-p nil)
|
||||||
|
(kill-buffer))
|
||||||
|
;; Stopped whatever happened above: a daemon this started is its own to end.
|
||||||
|
(flan-quit))
|
||||||
|
(ignore-errors (delete-file file))))
|
||||||
|
|
||||||
|
(message "\nthe .fln keys, against a daemon on each backend")
|
||||||
|
(test-flan-fln-live--run "x86" nil)
|
||||||
|
(test-flan-fln-live--run "llvm" '("--llvm"))
|
||||||
|
|
||||||
|
;;; test-flan-fln-live.el ends here
|
||||||
File diff suppressed because it is too large.
Load diff
+556
-14
@@ -111,15 +111,15 @@
|
|||||||
;; there.
|
;; there.
|
||||||
(test-flan-mode--check
|
(test-flan-mode--check
|
||||||
"a defn with a return type indents its body by two"
|
"a defn with a return type indents its body by two"
|
||||||
"(defn look [n i64 label string] i64
|
"(defn look [n i64 label str] i64
|
||||||
(print label)
|
(prin label)
|
||||||
n)")
|
n)")
|
||||||
|
|
||||||
(test-flan-mode--check
|
(test-flan-mode--check
|
||||||
"and a defn without one indents it the same"
|
"and a defn without one indents it the same"
|
||||||
"(defn show-trim [s string] ()
|
"(defn show-trim [s str] ()
|
||||||
(print s)
|
(prin s)
|
||||||
(println \"\"))")
|
(print \"\"))")
|
||||||
|
|
||||||
;; A parameter list that wraps is the binding-vector rule again: it is a
|
;; A parameter list that wraps is the binding-vector rule again: it is a
|
||||||
;; vector, so it aligns under its first element and not under its second.
|
;; vector, so it aligns under its first element and not under its second.
|
||||||
@@ -168,7 +168,7 @@
|
|||||||
;; one column.
|
;; one column.
|
||||||
(test-flan-mode--check
|
(test-flan-mode--check
|
||||||
"declare-c puts everything after the name in one column"
|
"declare-c puts everything after the name in one column"
|
||||||
"(declare-c mouse-button-pressed?
|
"(declare-c is-mouse-button-pressed
|
||||||
[button MouseButton] bool
|
[button MouseButton] bool
|
||||||
\"IsMouseButtonPressed\")")
|
\"IsMouseButtonPressed\")")
|
||||||
|
|
||||||
@@ -206,13 +206,180 @@
|
|||||||
"a discarded binding does not disturb the pairs around it"
|
"a discarded binding does not disturb the pairs around it"
|
||||||
"(let [#_a #_1 b 2
|
"(let [#_a #_1 b 2
|
||||||
c 3]
|
c 3]
|
||||||
(print c))")
|
(prin c))")
|
||||||
|
|
||||||
|
;; A labelled loop, from `test/programs/loops.flan'. The label is a keyword
|
||||||
|
;; written where the binding vector would otherwise go, so it pushes everything
|
||||||
|
;; along by one — and until the indenter was told, the body of a labelled loop
|
||||||
|
;; was dragged out under its own binding vector.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a labelled dotimes indents its body by two, not under its vector"
|
||||||
|
"(dotimes :outer [a 3]
|
||||||
|
(dotimes [b 3]
|
||||||
|
(when (= b 2) (break :outer))
|
||||||
|
(prin b) (print \"\")))")
|
||||||
|
|
||||||
|
;; `until' takes one on the same rule, and there the special argument is a test
|
||||||
|
;; rather than a vector — which is the case that shows the rule is about the
|
||||||
|
;; label and not about brackets.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"and so does a labelled until, whose special argument is a test"
|
||||||
|
"(until :count (> n 10)
|
||||||
|
(set n (+ n 1))
|
||||||
|
(when (= n 3) (break :count)))")
|
||||||
|
|
||||||
|
;; The unlabelled form must not have moved, which is the other half of the
|
||||||
|
;; same claim.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"an unlabelled dotimes is where it always was"
|
||||||
|
"(dotimes [b 3]
|
||||||
|
(prin b)
|
||||||
|
(print \"\"))")
|
||||||
|
|
||||||
|
;; `dotimes' binding vectors now hold up to four elements — name, start, stop,
|
||||||
|
;; step — and the indenter must not have learned a count. The vector is one
|
||||||
|
;; sexp whatever is in it, so the body is two in from the head in every arity,
|
||||||
|
;; and a vector that wraps aligns under its own first element. From
|
||||||
|
;; `test/programs/dotimes-range.flan'.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a three-element dotimes vector indents its body by two"
|
||||||
|
"(dotimes [i 2 5]
|
||||||
|
(prin i)
|
||||||
|
(print \"\"))")
|
||||||
|
|
||||||
|
(test-flan-mode--check
|
||||||
|
"and a four-element one, counting down, does the same"
|
||||||
|
"(dotimes [i 9 -1 -1]
|
||||||
|
(prin i)
|
||||||
|
(print \"\"))")
|
||||||
|
|
||||||
|
(test-flan-mode--check
|
||||||
|
"and a binding vector that wraps aligns under its first element"
|
||||||
|
"(dotimes [i 0
|
||||||
|
(length items)
|
||||||
|
2]
|
||||||
|
(prin i))")
|
||||||
|
|
||||||
|
;; The object and dispatch forms all begin `def', so they reach the `:defn'
|
||||||
|
;; fallback and indent their bodies by two. `defmethod' is the one with two
|
||||||
|
;; names before the parameter vector — the generic and the dispatch value —
|
||||||
|
;; which is exactly the case a count would have got wrong. From
|
||||||
|
;; `test/programs/dev-classes.flan'.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a defmethod indents its body by two, past generic and dispatch value"
|
||||||
|
"(defmethod area point [p]
|
||||||
|
(* (get p :x)
|
||||||
|
(get p :y)))")
|
||||||
|
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a defclass puts its slot vector in the body column"
|
||||||
|
"(defclass point
|
||||||
|
[x y])")
|
||||||
|
|
||||||
|
(test-flan-mode--check
|
||||||
|
"and a defmulti indents its body by two"
|
||||||
|
"(defmulti describe [thing] dyn
|
||||||
|
(class-of thing))")
|
||||||
|
|
||||||
|
;; `fn' is `defn' with no name and no return type: the parameter vector, then
|
||||||
|
;; the body. From `test/programs/higher-order.flan', written down the page.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"an fn indents its body under its parameters by two"
|
||||||
|
"(sort-by s (fn [a b]
|
||||||
|
(< a b)))")
|
||||||
|
|
||||||
|
;; A macro body indents by two like any `def…' form. It reaches that through
|
||||||
|
;; the `\\`def' fallback rather than through an entry, which is worth pinning:
|
||||||
|
;; the fallback is what covers every definer nobody listed.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a defmacro indents its body by two"
|
||||||
|
"(defmacro both [& args]
|
||||||
|
`(do ~@args))")
|
||||||
|
|
||||||
|
;; A macro's parameter list destructures now, so it holds names and a `&'
|
||||||
|
;; rest marker rather than one blob. It is still a vector, so a list that
|
||||||
|
;; wraps aligns name under name like every other vector here — and `&' is a
|
||||||
|
;; name character, so it does not split the marker off from what follows.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a wrapped destructuring parameter list aligns under its first parameter"
|
||||||
|
"(defmacro guard [test message
|
||||||
|
& body]
|
||||||
|
`(when ~test ~@body))")
|
||||||
|
|
||||||
|
;; A generic `defn' writes its constraint map between the return type and the
|
||||||
|
;; body — `test/programs/generic-map-reject.flan'. It is a brace, so it aligns
|
||||||
|
;; under its first element like every other brace, and the body after it is
|
||||||
|
;; still two in from `defn'.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a where clause sits in the body column and does not move the body"
|
||||||
|
"(defn is-seen [k $t] bool
|
||||||
|
{:where (is-hashable $t)}
|
||||||
|
(let [m (map-new t i32)]
|
||||||
|
(put m k 1)))")
|
||||||
|
|
||||||
|
;; A comma is whitespace, so a vector written with commas is the same vector
|
||||||
|
;; and lines up the same way. It reads as one now because the syntax table
|
||||||
|
;; says so; before, a comma was punctuation and sat in the middle of a name.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"commas between bindings change nothing"
|
||||||
|
"(let [vel 1.0,
|
||||||
|
y 2.0]
|
||||||
|
(prin y))")
|
||||||
|
|
||||||
|
;; A `with-' form is a body, qualified or not, whatever it takes on the head's
|
||||||
|
;; line — `clojure-indent-function''s fallback. From `examples/core-2d-camera.flan'.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a qualified with- form indents its body by two past an argument"
|
||||||
|
"(rl/with-mode-2d camera
|
||||||
|
(rl/draw-rectangle-rec player rl/red)
|
||||||
|
(rl/draw-grid 10 1.0))")
|
||||||
|
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a qualified def form indents its body by two"
|
||||||
|
"(m/defthing name
|
||||||
|
(body))")
|
||||||
|
|
||||||
|
;; A qualified name finds the spec of its unqualified part.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a qualified when keeps when's spec"
|
||||||
|
"(rl/when (ready?)
|
||||||
|
(go))")
|
||||||
|
|
||||||
|
;; `default…' begins with `def' and is not a definer.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a default-prefixed call aligns its arguments"
|
||||||
|
"(default-color a
|
||||||
|
b)")
|
||||||
|
|
||||||
|
;; A cond result on its own line sits under its test, not deeper.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a cond result on its own line aligns with its test"
|
||||||
|
"(cond
|
||||||
|
(= k 1)
|
||||||
|
(one)
|
||||||
|
:else
|
||||||
|
(other))")
|
||||||
|
|
||||||
|
(test-flan-mode--check
|
||||||
|
"a match result on its own line aligns with its pattern"
|
||||||
|
"(match v
|
||||||
|
(Int n) n
|
||||||
|
(List items)
|
||||||
|
(length items))")
|
||||||
|
|
||||||
|
;; A trailing argument of an ordinary call aligns under the first argument,
|
||||||
|
;; even when it is long; only a `with-', `def' or specced head gives a body.
|
||||||
|
(test-flan-mode--check
|
||||||
|
"an ordinary call's arguments align under the first one"
|
||||||
|
"(push missing
|
||||||
|
`(when (ok) (go)))")
|
||||||
|
|
||||||
|
|
||||||
;;; Font lock
|
;;; Font lock
|
||||||
|
|
||||||
;; The colon-to-dot change left every field label in the corpus unfontified:
|
;; What is drawn is the language; what is drawn plain is the program. A field
|
||||||
;; the keyword rule used to cover them, and the colon belongs to keywords now.
|
;; label, a builtin and a number are all part of reading a program and none of
|
||||||
|
;; them is coloured, which is how clojure-mode treats the same three.
|
||||||
|
|
||||||
(defun test-flan-mode--face-at (text needle)
|
(defun test-flan-mode--face-at (text needle)
|
||||||
"The face on the first character of NEEDLE in TEXT, under `flan-mode'."
|
"The face on the first character of NEEDLE in TEXT, under `flan-mode'."
|
||||||
@@ -226,14 +393,22 @@
|
|||||||
|
|
||||||
(message "\n-- font lock")
|
(message "\n-- font lock")
|
||||||
|
|
||||||
|
;; The keyword rule is what is left of the constants: an enum member resolves
|
||||||
|
;; against a type and is worth marking.
|
||||||
|
(test-flan--check "an enum member is a constant"
|
||||||
|
(eq (test-flan-mode--face-at
|
||||||
|
"(rl/is-mouse-button-down :mouse-left)" ":mouse-left")
|
||||||
|
'font-lock-constant-face))
|
||||||
|
|
||||||
(dolist (case '(("(rl/Vector2 {.x 1.0 .y 2.0})" ".x" "a struct literal's field label")
|
(dolist (case '(("(rl/Vector2 {.x 1.0 .y 2.0})" ".x" "a struct literal's field label")
|
||||||
("(rl/Vector2 {.x 1.0 .y 2.0})" ".y" "and the second one")
|
("(rl/Vector2 {.x 1.0 .y 2.0})" ".y" "and the second one")
|
||||||
("(set total (.bytes c))" ".bytes" "a field accessor")
|
("(set total (.bytes c))" ".bytes" "a field accessor")
|
||||||
;; The keyword rule is still there: an enum member is one.
|
("(put v 42)" "42" "a number")
|
||||||
("(rl/mouse-button-down? :left)" ":left" "an enum member")))
|
("(set mask 0xFF)" "0xFF" "a hex number")
|
||||||
(test-flan--check (format "%s is a constant" (nth 2 case))
|
("(put v x)" "put" "a builtin")
|
||||||
(eq (test-flan-mode--face-at (nth 0 case) (nth 1 case))
|
("(print (length xs))" "length" "and another")))
|
||||||
'font-lock-constant-face)))
|
(test-flan--check (format "%s is plain" (nth 2 case))
|
||||||
|
(null (test-flan-mode--face-at (nth 0 case) (nth 1 case)))))
|
||||||
|
|
||||||
;; A dot inside a number is not a label, and neither is the dot in a name that
|
;; A dot inside a number is not a label, and neither is the dot in a name that
|
||||||
;; has one in the middle.
|
;; has one in the middle.
|
||||||
@@ -242,5 +417,372 @@
|
|||||||
(test-flan--check "a dot inside a name does not start a label"
|
(test-flan--check "a dot inside a name does not start a label"
|
||||||
(null (test-flan-mode--face-at "(f alpha.beta)" ".beta")))
|
(null (test-flan-mode--face-at "(f alpha.beta)" ".beta")))
|
||||||
|
|
||||||
|
;; The pass over the static table. Each row is a piece of the corpus and the
|
||||||
|
;; face the name in it should carry; several of these were drawn as nothing at
|
||||||
|
;; all until the table was brought back into line with `lib/parse.ml' and
|
||||||
|
;; `lib/check.ml'.
|
||||||
|
(dolist (case '(;; A definer that was missing: the head was not a keyword and
|
||||||
|
;; the name after it was not a function name.
|
||||||
|
("(defmacro both [& args] `(do ~@args))" "defmacro"
|
||||||
|
font-lock-keyword-face "defmacro's head")
|
||||||
|
("(defmacro both [& args] `(do ~@args))" "both"
|
||||||
|
font-lock-function-name-face "and the macro's name")
|
||||||
|
("(declare-c mouse-down? [b i32] bool \"X\")" "declare-c"
|
||||||
|
font-lock-keyword-face "declare-c's head")
|
||||||
|
;; The defining forms that arrived with the object system and
|
||||||
|
;; with the def/defonce/defconst trio.
|
||||||
|
("(def ticks i64 0)" "def" font-lock-keyword-face "def's head")
|
||||||
|
("(def ticks i64 0)" "ticks" font-lock-function-name-face
|
||||||
|
"and the name it introduces")
|
||||||
|
("(defonce seed i64 1)" "defonce" font-lock-keyword-face
|
||||||
|
"defonce")
|
||||||
|
;; A private defn: the head as a whole, not `defn' and a
|
||||||
|
;; stray `-', and the name after it.
|
||||||
|
("(defn- mix [a i32] i32 a)" "defn-" font-lock-keyword-face
|
||||||
|
"defn-'s head")
|
||||||
|
("(defn- mix [a i32] i32 a)" "mix"
|
||||||
|
font-lock-function-name-face "and the private function's name")
|
||||||
|
("(defclass point [x y])" "defclass" font-lock-keyword-face
|
||||||
|
"defclass")
|
||||||
|
("(defgeneric area [self] dyn)" "defgeneric"
|
||||||
|
font-lock-keyword-face "defgeneric")
|
||||||
|
("(defmethod area point [p] 1)" "defmethod"
|
||||||
|
font-lock-keyword-face "defmethod")
|
||||||
|
;; `handler-case' is implemented now and is a keyword like the
|
||||||
|
;; other three condition forms.
|
||||||
|
("(handler-case (go) [(E [c] 1)])" "handler-case"
|
||||||
|
font-lock-keyword-face "handler-case")
|
||||||
|
;; Special forms the old list had never heard of.
|
||||||
|
("(cond (= a 1) 2)" "cond" font-lock-keyword-face "cond")
|
||||||
|
;; until is a prelude macro, drawn as the control flow it is.
|
||||||
|
("(until (> i 3) (go))" "until" font-lock-keyword-face "until")
|
||||||
|
("(and a b)" "and" font-lock-keyword-face "and")
|
||||||
|
("(handler-bind [(E [c] 1)] (go))" "handler-bind"
|
||||||
|
font-lock-keyword-face "handler-bind")
|
||||||
|
("(restart-case (go) (retry [] 1))" "restart-case"
|
||||||
|
font-lock-keyword-face "restart-case")
|
||||||
|
("(signal ArithError {.op 1})" "signal"
|
||||||
|
font-lock-keyword-face "signal")
|
||||||
|
("(dotimes [b 3] (break :outer))" "break"
|
||||||
|
font-lock-keyword-face "break")
|
||||||
|
;; The two array constructors, which the parser reads itself
|
||||||
|
;; because their dimensions are in brackets — see
|
||||||
|
;; `test/programs/array-fill.flan'.
|
||||||
|
("(array-fill [rows cols] 255)" "array-fill"
|
||||||
|
font-lock-keyword-face "array-fill")
|
||||||
|
("(array-gen [n] f)" "array-gen"
|
||||||
|
font-lock-keyword-face "array-gen")
|
||||||
|
;; A builtin is a call and not a form the parser knows, and it
|
||||||
|
;; is left plain — the rows for that are above, with the field
|
||||||
|
;; labels and the numbers.
|
||||||
|
;;
|
||||||
|
;; Types.
|
||||||
|
("(defn f [x dyn] dyn x)" "dyn" font-lock-type-face "dyn")
|
||||||
|
("(def v (Vec u8))" "Vec" font-lock-type-face "Vec")
|
||||||
|
("(declare apply [(Fn [i64] i64)] i64)" "Fn"
|
||||||
|
font-lock-type-face "Fn")
|
||||||
|
("(declare call [(CFn [i64] i64)] i64)" "CFn"
|
||||||
|
font-lock-type-face "CFn")
|
||||||
|
("(defn is-seen [k $t] bool 1)" "$t" font-lock-type-face
|
||||||
|
"a type variable")
|
||||||
|
;; The package alias of a qualified name, `clojure-mode''s
|
||||||
|
;; rule for a namespace.
|
||||||
|
("(rl/draw-text \"hi\" 1 2 3)" "rl" font-lock-type-face
|
||||||
|
"a package alias")
|
||||||
|
("(defn f [x int] float 1.0)" "int" font-lock-type-face
|
||||||
|
"int, the builtin alias")
|
||||||
|
("(defn f [s [const u8]] 1)" "const" font-lock-type-face
|
||||||
|
"const, in a read-only slice type")
|
||||||
|
;; Constants that stand for themselves.
|
||||||
|
("(set done true)" "true" font-lock-constant-face "true")
|
||||||
|
("(= o None)" "None" font-lock-constant-face "None")
|
||||||
|
("(set x nil)" "nil" font-lock-constant-face "nil")
|
||||||
|
("(def buf (Vec u8) uninit)" "uninit" font-lock-constant-face
|
||||||
|
"uninit, which is only ever written here")))
|
||||||
|
(test-flan--check (format "%s is drawn" (nth 3 case))
|
||||||
|
(eq (test-flan-mode--face-at (nth 0 case) (nth 1 case))
|
||||||
|
(nth 2 case))))
|
||||||
|
|
||||||
|
;; `Unit' is a name the resolver answers to and the parser refuses — unit is
|
||||||
|
;; written `()'. Drawing it as a type would advertise a spelling that does not
|
||||||
|
;; compile, which is the same rule that keeps `await' out of the keyword list.
|
||||||
|
(test-flan--check
|
||||||
|
"Unit is not drawn as a type, because the parser refuses the word"
|
||||||
|
(null (test-flan-mode--face-at "(defn f [] Unit 1)" "Unit")))
|
||||||
|
|
||||||
|
;; `context/allocator' has a slash in it and is not a qualified name: there is
|
||||||
|
;; no package called `context'. The constants rule runs first for exactly this
|
||||||
|
;; reason, and this is what would notice if it stopped.
|
||||||
|
(test-flan--check
|
||||||
|
"context/allocator is one constant and not an alias and a name"
|
||||||
|
(eq (test-flan-mode--face-at "(free-all (context/allocator))" "context/")
|
||||||
|
'font-lock-constant-face))
|
||||||
|
|
||||||
|
;; The name after a package alias is left for the running program to speak for
|
||||||
|
;; — see the dynamic section below. With no program it is undrawn, and that is
|
||||||
|
;; the state a file opened on its own is in.
|
||||||
|
(test-flan--check
|
||||||
|
"the name after the alias is left alone"
|
||||||
|
(null (test-flan-mode--face-at "(rl/draw-text \"hi\" 1 2 3)" "draw-text")))
|
||||||
|
|
||||||
|
|
||||||
|
;;; Font lock from the running program
|
||||||
|
|
||||||
|
;; `flan.el' adds a second set of rules that draw what the program *defines* —
|
||||||
|
;; a macro as a macro, a function as a function — and everything below drives
|
||||||
|
;; them from a fixture `flan--defs' rather than from a daemon. The live half,
|
||||||
|
;; where an evaluation is accepted and the name lights up without anyone asking
|
||||||
|
;; for it, is in test-flan.el, which has a program to evaluate against.
|
||||||
|
|
||||||
|
(require 'flan)
|
||||||
|
|
||||||
|
(defconst test-flan-mode--defs
|
||||||
|
;; The shape `Dev.defs' answers with: (NAME KIND SIGNATURE LOC DOC).
|
||||||
|
'(("settle" "fn" "settle [i32 i32] ()" "sand.flan:3" "")
|
||||||
|
("ticks" "var" "ticks i64" "" "")
|
||||||
|
("gravity" "const" "gravity f32" "" "")
|
||||||
|
("with-retry" "macro" "with-retry [args] Form" "" "")
|
||||||
|
("Pixel" "struct" "Pixel" "" "")
|
||||||
|
("Shape" "data" "Shape [Empty (Dot [x f64 y f64])]" "" "")
|
||||||
|
("Shape.Empty" "case" "Shape.Empty" "" "")
|
||||||
|
("Shape.Dot" "case" "(Shape.Dot [x f64 y f64])" "" "")
|
||||||
|
("point" "class" "point [x y]" "sand.flan:20:1" "")
|
||||||
|
("Key" "enum" "Key" "" "")
|
||||||
|
("sim/step" "fn" "sim/step [] ()" "sand.flan:9" "")
|
||||||
|
("a/draw" "fn" "a/draw [] ()" "" "")
|
||||||
|
("b/draw" "fn" "b/draw [] ()" "" "")
|
||||||
|
;; The program is allowed to define a name the language already uses. It
|
||||||
|
;; does not get to repaint it.
|
||||||
|
("length" "fn" "length [i32] i32" "" "")
|
||||||
|
("if" "fn" "if [i32] i32" "" "")
|
||||||
|
;; And a kind this editor has never heard of, which the daemon is allowed
|
||||||
|
;; to add.
|
||||||
|
("somenewthing" "sigil" "somenewthing" "" ""))
|
||||||
|
"A `defs' reply to draw against.")
|
||||||
|
|
||||||
|
(defun test-flan-mode--dyn-face (text needle &optional defs)
|
||||||
|
"The face on NEEDLE in TEXT with DEFS as what the program defines."
|
||||||
|
(let ((flan--defs (if (eq defs 'none) nil (or defs test-flan-mode--defs))))
|
||||||
|
(flan--dynamic-rebuild)
|
||||||
|
(with-temp-buffer
|
||||||
|
(insert text)
|
||||||
|
(flan-mode)
|
||||||
|
(flan--dynamic-install)
|
||||||
|
(font-lock-ensure)
|
||||||
|
(goto-char (point-min))
|
||||||
|
(search-forward needle)
|
||||||
|
(get-text-property (- (point) (length needle)) 'face))))
|
||||||
|
|
||||||
|
(message "\n-- font lock from the program")
|
||||||
|
|
||||||
|
;; `flan-font-lock-dynamically' is a list of kinds and defaults to macros
|
||||||
|
;; alone, so a macro is drawn and everything else the program defines is not.
|
||||||
|
;; A macro is the one kind a reader cannot work out from the call, because its
|
||||||
|
;; arguments are not evaluated; a function drawn as a function says only that
|
||||||
|
;; the name exists. cider-mode's default is the same shape.
|
||||||
|
(test-flan--check
|
||||||
|
"a macro the program defines is drawn as one"
|
||||||
|
(eq (test-flan-mode--dyn-face "(with-retry (go))" "with-retry")
|
||||||
|
'flan-macro-face))
|
||||||
|
|
||||||
|
(dolist (case '(("(settle 1 2)" "settle" "a function")
|
||||||
|
("(set ticks 0)" "ticks" "a global")
|
||||||
|
("(prin gravity)" "gravity" "a constant")
|
||||||
|
("(def p (Vec Pixel))" "Pixel" "a struct")
|
||||||
|
("(defn f [s Shape] () 1)" "Shape" "a data type")
|
||||||
|
("(def k Key)" "Key" "an enum")))
|
||||||
|
(test-flan--check
|
||||||
|
(format "%s the program defines is left plain" (nth 2 case))
|
||||||
|
(null (test-flan-mode--dyn-face (nth 0 case) (nth 1 case)))))
|
||||||
|
|
||||||
|
;; Asked for by name, the other kinds still draw: the default is a default and
|
||||||
|
;; not a removal.
|
||||||
|
(test-flan--check
|
||||||
|
"a function is drawn when the setting asks for one"
|
||||||
|
(let ((flan-font-lock-dynamically '(macro fn)))
|
||||||
|
(eq (test-flan-mode--dyn-face "(settle 1 2)" "settle")
|
||||||
|
'flan-function-face)))
|
||||||
|
|
||||||
|
(test-flan--check
|
||||||
|
"and t still draws every kind"
|
||||||
|
(let ((flan-font-lock-dynamically t))
|
||||||
|
(eq (test-flan-mode--dyn-face "(set ticks 0)" "ticks")
|
||||||
|
'flan-global-face)))
|
||||||
|
|
||||||
|
;; A macro and a function must not look alike — the whole point — so this is
|
||||||
|
;; asserted as a difference and not only as two faces.
|
||||||
|
(test-flan--check
|
||||||
|
"a macro and a function are not drawn the same"
|
||||||
|
(let ((flan-font-lock-dynamically '(macro fn)))
|
||||||
|
(not (eq (test-flan-mode--dyn-face "(with-retry (go))" "with-retry")
|
||||||
|
(test-flan-mode--dyn-face "(settle 1 2)" "settle")))))
|
||||||
|
|
||||||
|
;; A macro is compiled, so it has a body to disassemble and to lower — and the
|
||||||
|
;; lists that offer "a thing with a body" used to filter on kind `fn' alone.
|
||||||
|
;; Giving macros a kind of their own would have quietly dropped them out of
|
||||||
|
;; `flan-disassemble', `flan-disassemble-ir' and `flan-lowering' unless every
|
||||||
|
;; one of those learned the second word.
|
||||||
|
(test-flan--check
|
||||||
|
"a macro is offered by the completion table for a compiled body"
|
||||||
|
(let ((flan--defs test-flan-mode--defs))
|
||||||
|
(and (member "with-retry" (flan--compiled-names))
|
||||||
|
(member "settle" (flan--compiled-names)))))
|
||||||
|
|
||||||
|
(test-flan--check
|
||||||
|
"and a global is not, because it has no body"
|
||||||
|
(let ((flan--defs test-flan-mode--defs))
|
||||||
|
(not (member "ticks" (flan--compiled-names)))))
|
||||||
|
|
||||||
|
;; A constructor is `Type.Case' and is one symbol. The daemon lists each
|
||||||
|
;; case under that name, so the whole symbol is drawn, and it is drawn when
|
||||||
|
;; the data type is: a case is part of its type, not a kind to ask for apart.
|
||||||
|
(test-flan--check
|
||||||
|
"a constructor is drawn whole, case half included"
|
||||||
|
(let ((flan-font-lock-dynamically '(data)))
|
||||||
|
(eq (test-flan-mode--dyn-face "(match s (Shape.Dot) 1)" ".Dot")
|
||||||
|
'flan-type-face)))
|
||||||
|
|
||||||
|
(test-flan--check
|
||||||
|
"and not when data types are not asked for"
|
||||||
|
(null (test-flan-mode--dyn-face "(match s (Shape.Dot) 1)" "Shape.Dot")))
|
||||||
|
|
||||||
|
(test-flan--check
|
||||||
|
"a case the program does not have draws only its type half"
|
||||||
|
(let ((flan-font-lock-dynamically t))
|
||||||
|
(and (eq (test-flan-mode--dyn-face "(match s (Shape.Nope) 1)" "Shape")
|
||||||
|
'flan-type-face)
|
||||||
|
(null (test-flan-mode--dyn-face "(match s (Shape.Nope) 1)" ".Nope")))))
|
||||||
|
|
||||||
|
(test-flan--check
|
||||||
|
"a class the program defines is drawn when classes are asked for"
|
||||||
|
(let ((flan-font-lock-dynamically '(class)))
|
||||||
|
(eq (test-flan-mode--dyn-face "(point 1 2)" "point") 'flan-type-face)))
|
||||||
|
|
||||||
|
(test-flan--check
|
||||||
|
"a name the program has never heard of is left alone"
|
||||||
|
(null (test-flan-mode--dyn-face "(never-defined 1)" "never-defined")))
|
||||||
|
|
||||||
|
(test-flan--check
|
||||||
|
"and so is a kind this editor does not know"
|
||||||
|
(null (test-flan-mode--dyn-face "(somenewthing)" "somenewthing")))
|
||||||
|
|
||||||
|
;; The static rules win. `length' is not the test it once was — a builtin is
|
||||||
|
;; drawn plain now, so both answers are plain and the row proves nothing — so
|
||||||
|
;; the claim rests on `if', which the language draws and the program may not
|
||||||
|
;; repaint. Asked for every kind, so the program's own rule is live.
|
||||||
|
(test-flan--check
|
||||||
|
"a program function named if is still drawn as the special form"
|
||||||
|
(let ((flan-font-lock-dynamically t))
|
||||||
|
(eq (test-flan-mode--dyn-face "(if a 1 2)" "if") 'font-lock-keyword-face)))
|
||||||
|
|
||||||
|
;; A buffer inside a package writes `step' for what the program calls
|
||||||
|
;; `sim/step'. One package offers it, so it resolves — the rule `flan--lookup'
|
||||||
|
;; already follows for eldoc and `M-.'.
|
||||||
|
(test-flan--check
|
||||||
|
"an unqualified name that one package offers is drawn"
|
||||||
|
(let ((flan-font-lock-dynamically '(macro fn)))
|
||||||
|
(eq (test-flan-mode--dyn-face "(step)" "step") 'flan-function-face)))
|
||||||
|
|
||||||
|
(test-flan--check
|
||||||
|
"and one that two packages offer is not, because that would be a guess"
|
||||||
|
(let ((flan-font-lock-dynamically '(macro fn)))
|
||||||
|
(null (test-flan-mode--dyn-face "(draw)" "draw"))))
|
||||||
|
|
||||||
|
;; A number is never a name, even when a definition's last segment is one
|
||||||
|
;; (a closure's environment, `env/fn/lam/0').
|
||||||
|
(test-flan--check
|
||||||
|
"a literal number does not resolve to a definition ending in it"
|
||||||
|
(let ((flan--defs '(("env/fn/lam/0" "struct" "env/fn/lam/0" "" ""))))
|
||||||
|
(and (null (flan--lookup "0")) (null (flan--lookup "-0")) (null (flan--ambiguous "0"))
|
||||||
|
(flan--lookup "env/fn/lam/0"))))
|
||||||
|
|
||||||
|
;; With no session there is nothing to say, and the buffer has to be drawn
|
||||||
|
;; exactly as `flan-mode' alone draws it.
|
||||||
|
(test-flan--check
|
||||||
|
"with no session a program name is undrawn"
|
||||||
|
(null (test-flan-mode--dyn-face "(settle 1 2)" "settle" 'none)))
|
||||||
|
|
||||||
|
(test-flan--check
|
||||||
|
"and the language is drawn as it always was"
|
||||||
|
(eq (test-flan-mode--dyn-face "(let [a 1] a)" "let" 'none)
|
||||||
|
'font-lock-keyword-face))
|
||||||
|
|
||||||
|
;; Whole-buffer, because "nothing changes" is a claim about every character and
|
||||||
|
;; not about one name: a corpus file drawn with no session must come out
|
||||||
|
;; character for character and face for face as it did before any of this.
|
||||||
|
(defun test-flan-mode--faces (text &optional defs)
|
||||||
|
"Every (POS . FACE) in TEXT, with DEFS as what the program defines."
|
||||||
|
(let ((flan--defs (if (eq defs 'none) nil defs)))
|
||||||
|
(flan--dynamic-rebuild)
|
||||||
|
(with-temp-buffer
|
||||||
|
(insert text)
|
||||||
|
(flan-mode)
|
||||||
|
(flan--dynamic-install)
|
||||||
|
(font-lock-ensure)
|
||||||
|
(let (acc)
|
||||||
|
(dotimes (i (1- (point-max)))
|
||||||
|
(push (get-text-property (1+ i) 'face) acc))
|
||||||
|
(nreverse acc)))))
|
||||||
|
|
||||||
|
;; The text carries a macro call, because the default draws macros and nothing
|
||||||
|
;; else: a body of plain functions and globals is the same picture either way
|
||||||
|
;; and the last of the three claims below would be asserting nothing.
|
||||||
|
(let ((text "(defn settle [row i32] ()\n (let [vel gravity]\n (with-retry (set ticks vel))))\n"))
|
||||||
|
(test-flan--check
|
||||||
|
"a buffer with no session is drawn exactly as the mode alone draws it"
|
||||||
|
(equal (test-flan-mode--faces text 'none)
|
||||||
|
(let ((flan-font-lock-dynamically nil))
|
||||||
|
(test-flan-mode--faces text test-flan-mode--defs))))
|
||||||
|
;; ...and turning the setting off with a session up is the same picture,
|
||||||
|
;; which is what makes it an off switch rather than a reconnect.
|
||||||
|
(test-flan--check
|
||||||
|
"and turning the option off gives that same picture back"
|
||||||
|
(equal (test-flan-mode--faces text 'none)
|
||||||
|
(let ((flan-font-lock-dynamically nil))
|
||||||
|
(test-flan-mode--faces text test-flan-mode--defs))))
|
||||||
|
(test-flan--check
|
||||||
|
"while with one it is drawn differently"
|
||||||
|
(not (equal (test-flan-mode--faces text 'none)
|
||||||
|
(test-flan-mode--faces text test-flan-mode--defs)))))
|
||||||
|
|
||||||
|
;; Installing twice must not leave two copies of the rule behind: a refresh
|
||||||
|
;; happens after every accepted evaluation, and a rule added each time would
|
||||||
|
;; make redisplay slower for as long as the session lasted.
|
||||||
|
(test-flan--check
|
||||||
|
"installing repeatedly leaves one copy of the rule"
|
||||||
|
(let ((flan--defs test-flan-mode--defs))
|
||||||
|
(flan--dynamic-rebuild)
|
||||||
|
(with-temp-buffer
|
||||||
|
(flan-mode)
|
||||||
|
(font-lock-ensure)
|
||||||
|
(dotimes (_ 5) (flan--dynamic-install))
|
||||||
|
(= 1 (seq-count (lambda (k) (equal k (car flan--dynamic-keywords)))
|
||||||
|
font-lock-keywords)))))
|
||||||
|
|
||||||
|
;;; Electric pairs
|
||||||
|
|
||||||
|
;; `electric-pair-mode' reads the syntax table and nothing else, so the three
|
||||||
|
;; bracket pairs Flan writes work without a word being said about them — and
|
||||||
|
;; that is exactly why it wants a test: the table gained entries in this pass,
|
||||||
|
;; and a mistake in one of them would show up here first.
|
||||||
|
|
||||||
|
(message "\n-- electric pairs")
|
||||||
|
|
||||||
|
(defun test-flan-mode--pair (open)
|
||||||
|
"Type OPEN in a Flan buffer with `electric-pair-mode' on, and read the line."
|
||||||
|
(with-temp-buffer
|
||||||
|
(flan-mode)
|
||||||
|
(electric-pair-local-mode 1)
|
||||||
|
(let ((last-command-event open))
|
||||||
|
(call-interactively #'self-insert-command))
|
||||||
|
(buffer-string)))
|
||||||
|
|
||||||
|
(dolist (case '((?\( "()" "a paren")
|
||||||
|
(?\[ "[]" "a bracket")
|
||||||
|
(?{ "{}" "a brace")
|
||||||
|
(?\" "\"\"" "a string")))
|
||||||
|
(test-flan--check (format "%s closes itself" (nth 2 case))
|
||||||
|
(equal (test-flan-mode--pair (nth 0 case)) (nth 1 case))))
|
||||||
|
|
||||||
(provide 'test-flan-mode)
|
(provide 'test-flan-mode)
|
||||||
;;; test-flan-mode.el ends here
|
;;; test-flan-mode.el ends here
|
||||||
@@ -0,0 +1,249 @@
|
|||||||
|
;;; test-flan-repl.el --- The prompt's history, at a stub prompt -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Loaded by test-flan-cider.el, which runs under `dune test', for the reason
|
||||||
|
;; test-flan-mode.el gives: `emacs/*.el' is already a dependency of that
|
||||||
|
;; stanza, so a file here needs no build change to be run.
|
||||||
|
;;
|
||||||
|
;; Nothing here needs a daemon, and that is not a shortcut. History is a
|
||||||
|
;; function from *a ring and where point is* to *what the buffer says*, and the
|
||||||
|
;; failures worth catching are all on that side: an up-arrow that recalls where
|
||||||
|
;; someone meant to scroll, a second press that does not move because comint
|
||||||
|
;; cannot see its own name in `last-command', a form typed over several lines
|
||||||
|
;; that comes back out of the file in pieces. Evaluation is the other half and
|
||||||
|
;; test_emacs drives it against a real program.
|
||||||
|
;;
|
||||||
|
;; The one thing that must be borrowed from the real thing is the process: the
|
||||||
|
;; input line is wherever the process mark is, so a prompt with no process
|
||||||
|
;; behind it has no input line to be on. It is the same `cat' stub
|
||||||
|
;; `flan-repl' starts, for the same reason its comment gives.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'flan-repl)
|
||||||
|
(require 'ring)
|
||||||
|
|
||||||
|
(declare-function test-flan--check "test-flan-cider" (name ok))
|
||||||
|
(declare-function test-flan--caught "test-flan-cider" (thunk))
|
||||||
|
|
||||||
|
(defvar test-flan-repl--history
|
||||||
|
(make-temp-name (expand-file-name "flan-repl-history-"
|
||||||
|
temporary-file-directory))
|
||||||
|
"Where these checks keep history.
|
||||||
|
Never the user's own file: `kill-emacs-hook' saves every REPL buffer, and a
|
||||||
|
batch run exits through `kill-emacs' like any other.")
|
||||||
|
|
||||||
|
(defun test-flan-repl--buffer (&optional inputs)
|
||||||
|
"A live `flan-repl-mode' buffer at a fresh prompt, with INPUTS in its ring.
|
||||||
|
INPUTS are given oldest first, the order they would have been typed in."
|
||||||
|
(let ((buf (get-buffer-create "*test-flan-repl*")))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(let ((flan-repl-history-file test-flan-repl--history))
|
||||||
|
(flan-repl-mode))
|
||||||
|
(let ((proc (start-process "test-flan-repl" buf "cat")))
|
||||||
|
(set-process-query-on-exit-flag proc nil)
|
||||||
|
(comint-output-filter proc flan-repl-prompt))
|
||||||
|
(dolist (input inputs) (ring-insert comint-input-ring input))
|
||||||
|
(setq comint-input-ring-index nil)
|
||||||
|
;; The keypresses below are checked for what they do, so they are run
|
||||||
|
;; through the map the same way a keypress reaches them.
|
||||||
|
(setq last-command nil))
|
||||||
|
buf))
|
||||||
|
|
||||||
|
(defun test-flan-repl--press (key)
|
||||||
|
"Run KEY's binding in the current buffer the way a keypress would.
|
||||||
|
Through `call-interactively' and with `last-command' carried across, because
|
||||||
|
both are what the commands under test read: the binding is half the claim, and
|
||||||
|
comint's search reads the command that ran before it."
|
||||||
|
(let ((cmd (key-binding (kbd key)))
|
||||||
|
;; Quiet: comint says which history item it landed on, and in batch
|
||||||
|
;; that lands in the middle of the line a result is printed on.
|
||||||
|
(inhibit-message t))
|
||||||
|
(setq this-command cmd)
|
||||||
|
(call-interactively cmd)
|
||||||
|
(setq last-command this-command)))
|
||||||
|
|
||||||
|
(defun test-flan-repl--input ()
|
||||||
|
"The text currently typed at the prompt."
|
||||||
|
(buffer-substring-no-properties
|
||||||
|
(process-mark (get-buffer-process (current-buffer)))
|
||||||
|
(point-max)))
|
||||||
|
|
||||||
|
(defun test-flan-repl--done (buf)
|
||||||
|
"Finish with BUF, writing no history on the way out.
|
||||||
|
The hook has to come off the buffer rather than be bound away around the kill:
|
||||||
|
it is buffer-local, and a `let' outside the buffer does not reach it. Saving
|
||||||
|
here would make every check below read a file the one above it happened to
|
||||||
|
leave, which is a test of the order they are written in."
|
||||||
|
(with-current-buffer buf
|
||||||
|
(remove-hook 'kill-buffer-hook #'flan-repl--save-history t)
|
||||||
|
(let ((proc (get-buffer-process buf)))
|
||||||
|
(when proc (delete-process proc))))
|
||||||
|
(kill-buffer buf))
|
||||||
|
|
||||||
|
;;; Up-arrow at the prompt
|
||||||
|
|
||||||
|
(let ((buf (test-flan-repl--buffer '("(+ 1 2)" "(foo 1)"))))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(test-flan-repl--press "<up>")
|
||||||
|
(test-flan--check "up at the prompt recalls the last input"
|
||||||
|
(equal (test-flan-repl--input) "(foo 1)"))
|
||||||
|
(test-flan-repl--press "<up>")
|
||||||
|
;; The press that discriminates: comint decides whether a press continues
|
||||||
|
;; the search by looking for its own command name in `last-command', and a
|
||||||
|
;; wrapper that does not hand it over searches again from the entry it just
|
||||||
|
;; inserted, so the first press looks perfect and the second does nothing.
|
||||||
|
(test-flan--check "and a second press reaches the one before it"
|
||||||
|
(equal (test-flan-repl--input) "(+ 1 2)"))
|
||||||
|
(test-flan-repl--press "<down>")
|
||||||
|
(test-flan--check "down comes back up the ring"
|
||||||
|
(equal (test-flan-repl--input) "(foo 1)")))
|
||||||
|
(test-flan-repl--done buf))
|
||||||
|
|
||||||
|
(let ((buf (test-flan-repl--buffer '("(+ 1 2)" "(foo 1)" "(bar 2)"))))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(insert "(f")
|
||||||
|
(test-flan-repl--press "<up>")
|
||||||
|
(test-flan--check "what is already typed filters the search, as a shell does"
|
||||||
|
(equal (test-flan-repl--input) "(foo 1)")))
|
||||||
|
(test-flan-repl--done buf))
|
||||||
|
|
||||||
|
;;; Up-arrow above the prompt
|
||||||
|
|
||||||
|
(let ((buf (test-flan-repl--buffer '("(+ 1 2)"))))
|
||||||
|
(with-current-buffer buf
|
||||||
|
;; The transcript above the prompt is read by scrolling back through it,
|
||||||
|
;; which a blunt history binding would make impossible.
|
||||||
|
(comint-output-filter (get-buffer-process buf)
|
||||||
|
(concat "3\n" flan-repl-prompt))
|
||||||
|
(goto-char (point-min))
|
||||||
|
(let ((line-move-visual nil)
|
||||||
|
(where (point)))
|
||||||
|
(test-flan-repl--press "<down>")
|
||||||
|
(test-flan--check "down above the input moves a line, and recalls nothing"
|
||||||
|
(and (> (point) where)
|
||||||
|
(string-empty-p (test-flan-repl--input))))
|
||||||
|
(test-flan-repl--press "<up>")
|
||||||
|
(test-flan--check "and up moves back"
|
||||||
|
(and (= (point) where)
|
||||||
|
(string-empty-p (test-flan-repl--input))))))
|
||||||
|
(test-flan-repl--done buf))
|
||||||
|
|
||||||
|
;;; A form typed over several lines
|
||||||
|
|
||||||
|
(let ((buf (test-flan-repl--buffer)))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(let ((line-move-visual nil))
|
||||||
|
(insert "(defn f [x]")
|
||||||
|
(test-flan-repl--press "RET")
|
||||||
|
(test-flan--check "RET on a half-typed form opens a line instead of sending"
|
||||||
|
(equal (test-flan-repl--input) "(defn f [x]\n"))
|
||||||
|
;; The line RET just opened is empty and is the last one, so `<down>'
|
||||||
|
;; does go to history — with a prefix that spans the newline and matches
|
||||||
|
;; nothing, which comint refuses rather than answering. What matters is
|
||||||
|
;; that the half-typed form is still there afterwards.
|
||||||
|
(test-flan--check "down on the opened line leaves the half-typed form alone"
|
||||||
|
(and (test-flan--caught
|
||||||
|
(lambda () (test-flan-repl--press "<down>")))
|
||||||
|
(equal (test-flan-repl--input) "(defn f [x]\n")))
|
||||||
|
(insert " (+ x 1))")
|
||||||
|
(test-flan-repl--press "<up>")
|
||||||
|
;; Inside the form the key is line motion, not history: the lines of one
|
||||||
|
;; input are as much a thing to move around in as the transcript is.
|
||||||
|
(test-flan--check "up inside the form moves between its lines"
|
||||||
|
(and (equal (test-flan-repl--input) "(defn f [x]\n (+ x 1))")
|
||||||
|
(flan-repl--on-first-input-line-p)))))
|
||||||
|
(test-flan-repl--done buf))
|
||||||
|
|
||||||
|
(let* ((buf (test-flan-repl--buffer '("(defn f [x]\n (+ x 1))")))
|
||||||
|
(sent nil))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(setq-local comint-input-sender (lambda (_proc text) (setq sent text)))
|
||||||
|
(test-flan-repl--press "<up>")
|
||||||
|
;; History leaves point where the typing stopped, which for an empty prompt
|
||||||
|
;; is the start of what was just recalled. `comint-send-input' sends only
|
||||||
|
;; as far as point, so a recalled form is exactly the case where sending
|
||||||
|
;; the line under point would send nothing at all.
|
||||||
|
(test-flan-repl--press "RET")
|
||||||
|
(test-flan--check "a recalled multi-line form is sent whole"
|
||||||
|
(equal sent "(defn f [x]\n (+ x 1))")))
|
||||||
|
(test-flan-repl--done buf))
|
||||||
|
|
||||||
|
;;; The file between sessions
|
||||||
|
|
||||||
|
(let ((buf (test-flan-repl--buffer '("(+ 1 2)" "(defn f [x]\n (+ x 1))"))))
|
||||||
|
(with-current-buffer buf (flan-repl--save-history))
|
||||||
|
(test-flan-repl--done buf)
|
||||||
|
(test-flan--check "the history file is written"
|
||||||
|
(file-readable-p test-flan-repl--history))
|
||||||
|
(let ((buf (test-flan-repl--buffer)))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(test-flan--check "a new session reads back what the last one typed"
|
||||||
|
(and (= (ring-length comint-input-ring) 2)
|
||||||
|
(equal (ring-ref comint-input-ring 1) "(+ 1 2)")))
|
||||||
|
;; Comint separates entries with a newline, which is also what is inside
|
||||||
|
;; a form typed over several lines; with that separator this entry comes
|
||||||
|
;; back as two broken ones.
|
||||||
|
(test-flan--check "including a form written over several lines, in one piece"
|
||||||
|
(equal (ring-ref comint-input-ring 0)
|
||||||
|
"(defn f [x]\n (+ x 1))"))
|
||||||
|
(test-flan-repl--press "<up>")
|
||||||
|
(test-flan--check "and up recalls it"
|
||||||
|
(equal (test-flan-repl--input) "(defn f [x]\n (+ x 1))")))
|
||||||
|
(test-flan-repl--done buf)))
|
||||||
|
|
||||||
|
(let ((buf (test-flan-repl--buffer)))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(flan-repl--save-history)
|
||||||
|
(test-flan--check "a session that typed nothing does not empty the file"
|
||||||
|
(= (flan-repl--history-entries test-flan-repl--history) 2)))
|
||||||
|
(test-flan-repl--done buf))
|
||||||
|
|
||||||
|
(let ((buf (test-flan-repl--buffer)))
|
||||||
|
(with-current-buffer buf
|
||||||
|
;; What a second Emacs having saved a longer history looks like from here.
|
||||||
|
;; A write replaces the file whole, so the short ring would throw the other
|
||||||
|
;; session away.
|
||||||
|
(setq comint-input-ring (make-ring flan-repl-history-size))
|
||||||
|
(ring-insert comint-input-ring "(only-this)")
|
||||||
|
(flan-repl--save-history)
|
||||||
|
(test-flan--check "nor does a ring shorter than the file replace it"
|
||||||
|
(= (flan-repl--history-entries test-flan-repl--history) 2)))
|
||||||
|
(test-flan-repl--done buf))
|
||||||
|
|
||||||
|
(when (file-exists-p test-flan-repl--history)
|
||||||
|
(delete-file test-flan-repl--history))
|
||||||
|
|
||||||
|
;; And the hook itself, which is what makes any of the above happen without
|
||||||
|
;; being asked: this is the only check that kills a REPL buffer the way a
|
||||||
|
;; person does.
|
||||||
|
(let* ((test-flan-repl--history
|
||||||
|
(make-temp-name (expand-file-name "flan-repl-killed-"
|
||||||
|
temporary-file-directory)))
|
||||||
|
(buf (test-flan-repl--buffer '("(kept)"))))
|
||||||
|
(kill-buffer buf)
|
||||||
|
(test-flan--check "killing the prompt saves what was typed at it"
|
||||||
|
(= (flan-repl--history-entries test-flan-repl--history) 1))
|
||||||
|
(when (file-exists-p test-flan-repl--history)
|
||||||
|
(delete-file test-flan-repl--history)))
|
||||||
|
|
||||||
|
;; The prompt reads the indented syntax: the request says so, and a whole
|
||||||
|
;; form is one whose brackets balance by .fln's own syntax table.
|
||||||
|
(let ((sent nil))
|
||||||
|
(with-current-buffer (test-flan-repl--buffer)
|
||||||
|
(cl-letf (((symbol-function 'flan--request)
|
||||||
|
(lambda (form) (setq sent form) (list :status "ok" :value "9")))
|
||||||
|
((symbol-function 'flan--use-image) #'ignore))
|
||||||
|
(flan-repl--send nil "state.memory[0x200..0x220]"))
|
||||||
|
(test-flan--check "the prompt's text goes to the daemon as indented syntax"
|
||||||
|
(and (equal (plist-get sent :op) "eval-expr")
|
||||||
|
(equal (plist-get sent :syntax) "indented")
|
||||||
|
(equal (plist-get sent :code)
|
||||||
|
"state.memory[0x200..0x220]")))
|
||||||
|
(test-flan--check "a bracket left open is not a whole form"
|
||||||
|
(not (flan-repl--complete-p "f(a[0x1..0x2]")))
|
||||||
|
(test-flan--check "a closed one is"
|
||||||
|
(flan-repl--complete-p "f(a[0x1..0x2])"))
|
||||||
|
(kill-buffer (current-buffer))))
|
||||||
|
|
||||||
|
(provide 'test-flan-repl)
|
||||||
|
;;; test-flan-repl.el ends here
|
||||||
@@ -0,0 +1,59 @@
|
|||||||
|
;;; test-flan-session.el --- Marks and logs the session leaves, from fixtures -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Loaded by test-flan-cider.el. No daemon: each check calls what a reply's
|
||||||
|
;; handler calls.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'flan)
|
||||||
|
|
||||||
|
(declare-function test-flan--check "test-flan-cider" (name ok))
|
||||||
|
|
||||||
|
(message "\nthe session's marks and log")
|
||||||
|
|
||||||
|
(let* ((file (make-temp-file "flan-session" nil ".fln"))
|
||||||
|
(buf (progn (with-temp-file file (insert "fn a() = 1\nfn b() = 2\nfn c() = 3\n"))
|
||||||
|
(find-file-noselect file))))
|
||||||
|
(unwind-protect
|
||||||
|
(with-current-buffer buf
|
||||||
|
;; A load that installed some forms and refused one: the warning of
|
||||||
|
;; the install, then the refusal marked.
|
||||||
|
(flan--show-warning file 1 1 "unused")
|
||||||
|
(flan--show-error (format "%s:2:1" file) "does not compile")
|
||||||
|
(test-flan--check "a refusal's mark leaves the same reply's warning mark up"
|
||||||
|
(and (= (length (flan--warning-overlays)) 1)
|
||||||
|
(= (length (flan--error-overlays)) 2)))
|
||||||
|
(flan--show-error (format "%s:3:1" file) "again")
|
||||||
|
(test-flan--check "and a second refusal replaces the first, not the warning"
|
||||||
|
(and (= (length (flan--warning-overlays)) 1)
|
||||||
|
(= (length (flan--error-overlays)) 2)))
|
||||||
|
(flan-clear-errors)
|
||||||
|
(test-flan--check "any command still takes every mark down"
|
||||||
|
(null (flan--error-overlays))))
|
||||||
|
(kill-buffer buf)
|
||||||
|
(delete-file file)))
|
||||||
|
|
||||||
|
(let ((flan-diagnostics-buffer " *flan-diagnostics-test*"))
|
||||||
|
(unwind-protect
|
||||||
|
(cl-letf (((symbol-function 'display-buffer) #'ignore))
|
||||||
|
(flan--record-diagnostic "a.fln:1:1" "first run")
|
||||||
|
(flan--render-memory-sites nil)
|
||||||
|
(flan--record-diagnostic "a.fln:2:1" "first run too")
|
||||||
|
(flan--clear-diagnostic-log)
|
||||||
|
(flan--record-diagnostic "a.fln:3:1" "second run")
|
||||||
|
(let ((text (with-current-buffer (flan--diagnostics-buffer)
|
||||||
|
(buffer-substring-no-properties (point-min) (point-max)))))
|
||||||
|
(test-flan--check "a load's log holds that load's messages only"
|
||||||
|
(and (string-match-p "second run" text)
|
||||||
|
(not (string-match-p "first run" text)))))
|
||||||
|
(flan--clear-diagnostic-log)
|
||||||
|
(test-flan--check "a clean load leaves nothing above the memory section"
|
||||||
|
(not (string-match-p
|
||||||
|
"run"
|
||||||
|
(with-current-buffer (flan--diagnostics-buffer)
|
||||||
|
(buffer-string))))))
|
||||||
|
(when (get-buffer flan-diagnostics-buffer)
|
||||||
|
(kill-buffer flan-diagnostics-buffer))))
|
||||||
|
|
||||||
|
(provide 'test-flan-session)
|
||||||
|
;;; test-flan-session.el ends here
|
||||||
@@ -0,0 +1,106 @@
|
|||||||
|
;;; test-flan-step.el --- The stepper's keys and marks, from a fixture stop -*- lexical-binding: t; -*-
|
||||||
|
|
||||||
|
;; Loaded by test-flan-cider.el. A step stop is a `break' reply; showing one
|
||||||
|
;; needs no daemon, only a file for its location to name. Taking a step
|
||||||
|
;; (n, i, o, c) is test-flan.el's, which has a program to step.
|
||||||
|
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(require 'flan-step)
|
||||||
|
|
||||||
|
(declare-function test-flan--check "test-flan-cider" (name ok))
|
||||||
|
|
||||||
|
(message "\nthe stepper's keys")
|
||||||
|
|
||||||
|
(let* ((file (make-temp-file "flan-step" nil ".fln"))
|
||||||
|
(stop (list :step-loc (concat file ":2:3") :step-fn "f" :step-gen 1
|
||||||
|
:step-value "42" :step-value-at (concat file ":2:3")))
|
||||||
|
(other (generate-new-buffer " *flan-step-other*")))
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
(with-temp-file file (insert "fn f()\n g()\n h()\n"))
|
||||||
|
(let ((buf (find-file-noselect file)))
|
||||||
|
(with-current-buffer buf
|
||||||
|
(setq header-line-format "mine"))
|
||||||
|
(switch-to-buffer buf)
|
||||||
|
(flan-step--show stop)
|
||||||
|
(with-current-buffer buf
|
||||||
|
(test-flan--check "a stop turns the keys on in its source buffer only"
|
||||||
|
(and flan-step-mode
|
||||||
|
(not (buffer-local-value 'flan-step-mode other))))
|
||||||
|
(test-flan--check "n i o c q e l are the stepper's there"
|
||||||
|
(equal (mapcar (lambda (k) (key-binding (kbd k)))
|
||||||
|
'("n" "i" "o" "c" "q" "e" "l"))
|
||||||
|
'(flan-step-next flan-step-in flan-step-out
|
||||||
|
flan-step-continue flan-step-quit
|
||||||
|
flan-step-eval flan-step-locals)))
|
||||||
|
(test-flan--check "the source is read-only while stopped"
|
||||||
|
buffer-read-only)
|
||||||
|
;; Called, not format-mode-line'd: a batch frame has no header
|
||||||
|
;; line to format it for.
|
||||||
|
(let ((h (flan-step--header)))
|
||||||
|
(test-flan--check "the header line lists the keys and the place"
|
||||||
|
(and (string-match-p "n next" h)
|
||||||
|
(string-match-p "i into" h)
|
||||||
|
(string-match-p "q quit" h)
|
||||||
|
(string-match-p "f, line 2" h)
|
||||||
|
(equal header-line-format
|
||||||
|
'(:eval (flan-step--header))))))
|
||||||
|
(test-flan--check "the form to run has the quiet face, one overlay"
|
||||||
|
(let ((o (seq-filter
|
||||||
|
(lambda (o) (overlay-get o 'face))
|
||||||
|
flan-step--overlays)))
|
||||||
|
(and (= (length o) 1)
|
||||||
|
(eq (overlay-get (car o) 'face)
|
||||||
|
'flan-step-face)
|
||||||
|
(memq (face-attribute 'flan-step-face
|
||||||
|
:underline nil t)
|
||||||
|
'(nil unspecified))))))
|
||||||
|
(with-current-buffer other
|
||||||
|
(test-flan--check "another buffer has none of the keys"
|
||||||
|
(not (eq (key-binding (kbd "n")) 'flan-step-next))))
|
||||||
|
(flan-step--clear)
|
||||||
|
(with-current-buffer buf
|
||||||
|
(test-flan--check "clearing turns the keys off"
|
||||||
|
(not flan-step-mode))
|
||||||
|
(test-flan--check "and puts the read-only flag and header line back"
|
||||||
|
(and (not buffer-read-only)
|
||||||
|
(equal header-line-format "mine"))))
|
||||||
|
(kill-buffer buf)))
|
||||||
|
(kill-buffer other)
|
||||||
|
(delete-file file)))
|
||||||
|
|
||||||
|
;; The stop ending by any route but the stepper's own keys: the keys go, the
|
||||||
|
;; buffer is writable again.
|
||||||
|
(let* ((file (make-temp-file "flan-step" nil ".fln"))
|
||||||
|
(stop (list :step-loc (concat file ":2:3") :step-fn "f" :step-gen 1)))
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
(with-temp-file file (insert "fn f()\n g()\n h()\n"))
|
||||||
|
(let ((buf (find-file-noselect file))
|
||||||
|
(flan--image nil))
|
||||||
|
(switch-to-buffer buf)
|
||||||
|
(let ((show (lambda () (flan-step--show stop))))
|
||||||
|
(funcall show)
|
||||||
|
(cl-letf (((symbol-function 'flan--append-output) #'ignore))
|
||||||
|
(flan--absorb (list :status "ok")))
|
||||||
|
(test-flan--check "a poll that finds the stop gone turns the keys off"
|
||||||
|
(with-current-buffer buf
|
||||||
|
(and (not flan-step-mode) (not buffer-read-only))))
|
||||||
|
(funcall show)
|
||||||
|
(flan--sentinel nil nil)
|
||||||
|
(test-flan--check "a lost connection turns the keys off"
|
||||||
|
(with-current-buffer buf (not flan-step-mode)))
|
||||||
|
(funcall show)
|
||||||
|
(setq flan-step--stop stop)
|
||||||
|
(cl-letf (((symbol-function 'flan--request)
|
||||||
|
(lambda (_) (error "flan dev: nothing is listening"))))
|
||||||
|
(ignore-errors (flan-step-quit)))
|
||||||
|
(test-flan--check "q with nothing listening still turns them off"
|
||||||
|
(with-current-buffer buf
|
||||||
|
(and (not flan-step-mode) (not buffer-read-only)))))
|
||||||
|
(kill-buffer buf)))
|
||||||
|
(delete-file file)))
|
||||||
|
|
||||||
|
(provide 'test-flan-step)
|
||||||
|
;;; test-flan-step.el ends here
|
||||||
+76
-49
@@ -56,7 +56,7 @@ what bounds its cost; a `with-temp-buffer' would be scanned by nothing."
|
|||||||
(concat "(defn step [] i64\n"
|
(concat "(defn step [] i64\n"
|
||||||
" (watch-i64 \"ticks\" ticks)\n"
|
" (watch-i64 \"ticks\" ticks)\n"
|
||||||
" (watch-f64 \"hp\" hp)\n"
|
" (watch-f64 \"hp\" hp)\n"
|
||||||
" (println \"(watch-i64 \\\"fake\\\" x)\")\n"
|
" (print \"(watch-i64 \\\"fake\\\" x)\")\n"
|
||||||
" (watch \"hp\" hp))\n"))))
|
" (watch \"hp\" hp))\n"))))
|
||||||
(with-current-buffer buf
|
(with-current-buffer buf
|
||||||
(let ((sites (flan-watch--ghost-sites)))
|
(let ((sites (flan-watch--ghost-sites)))
|
||||||
@@ -141,7 +141,7 @@ what bounds its cost; a `with-temp-buffer' would be scanned by nothing."
|
|||||||
"(watch-i64 \"ticks\" ticks)\n"
|
"(watch-i64 \"ticks\" ticks)\n"
|
||||||
"(watch-i64 \"gone\" g)\n")))
|
"(watch-i64 \"gone\" g)\n")))
|
||||||
(flan-watch--consumers '(ghost))
|
(flan-watch--consumers '(ghost))
|
||||||
(flan-dev--stopped nil))
|
(flan--stopped nil))
|
||||||
(flan-watch--ghost-paint '(("ticks" . "42")) nil)
|
(flan-watch--ghost-paint '(("ticks" . "42")) nil)
|
||||||
(test-flan--check
|
(test-flan--check
|
||||||
"a site whose name is in the table gets an overlay, and one that is not does not"
|
"a site whose name is in the table gets an overlay, and one that is not does not"
|
||||||
@@ -163,14 +163,14 @@ what bounds its cost; a `with-temp-buffer' would be scanned by nothing."
|
|||||||
(equal (nth 2 (test-flan-watch--strings))
|
(equal (nth 2 (test-flan-watch--strings))
|
||||||
" => no slot: the table is full"))
|
" => no slot: the table is full"))
|
||||||
|
|
||||||
(setq flan-dev--stopped "BoundsError")
|
(setq flan--stopped "BoundsError")
|
||||||
(flan-watch--ghost-paint '(("ticks" . "42")) nil)
|
(flan-watch--ghost-paint '(("ticks" . "42")) nil)
|
||||||
(test-flan--check
|
(test-flan--check
|
||||||
"stopping the program marks every overlay, not the buffer's modeline only"
|
"stopping the program marks every overlay, not the buffer's modeline only"
|
||||||
(equal (test-flan-watch--strings)
|
(equal (test-flan-watch--strings)
|
||||||
'(" => 42 one slot, 2 sites last frame"
|
'(" => 42 one slot, 2 sites last frame"
|
||||||
" => 42 one slot, 2 sites last frame")))
|
" => 42 one slot, 2 sites last frame")))
|
||||||
(setq flan-dev--stopped nil)
|
(setq flan--stopped nil)
|
||||||
|
|
||||||
;; The whole answer to invalidating an overlay whose line moved: no overlay
|
;; The whole answer to invalidating an overlay whose line moved: no overlay
|
||||||
;; outlives a repaint, so there is nothing to invalidate.
|
;; outlives a repaint, so there is nothing to invalidate.
|
||||||
@@ -210,54 +210,81 @@ what bounds its cost; a `with-temp-buffer' would be scanned by nothing."
|
|||||||
(test-flan--check "and the last consumer out disarms the table"
|
(test-flan--check "and the last consumer out disarms the table"
|
||||||
(and (null flan-watch--consumers) torn))))
|
(and (null flan-watch--consumers) torn))))
|
||||||
|
|
||||||
;; --- The reset is guarded on the stop ------------------------------------
|
;; --- Pushes and replies on one connection ---------------------------------
|
||||||
;;
|
;;
|
||||||
;; `flan-watch--tick' asks for "since you last looked" by sending `:reset t'
|
;; The daemon writes two kinds of frame: replies, and pushes it sends without
|
||||||
;; beside the read. A stopped program takes no samples, so there is no window
|
;; being asked — output as it is printed, the watch table while it is armed.
|
||||||
;; for a reset to close and none for it to open — and the runtime's lazy clear
|
;; The filter handles a push as it arrives and queues a reply for whoever is
|
||||||
;; is what keeps a paused program showing the numbers from the moment you
|
;; waiting. Frames are written into a pipe process's buffer by hand, split
|
||||||
;; paused it. So the tick must drop `:reset' while stopped and keep reading.
|
;; mid-frame the way a socket may deliver them, so what is claimed is the
|
||||||
;;
|
;; reader and not the daemon.
|
||||||
;; Asserted at the level the rest of this file works at: no daemon, no socket.
|
|
||||||
;; The tick is a function from `flan-dev--stopped' to the form it puts on the
|
|
||||||
;; wire, and that is the whole claim, so `flan-dev--send' and `process-live-p'
|
|
||||||
;; are stubs. What this cannot reach is the daemon actually honouring the
|
|
||||||
;; absent field; `test/test_dev.ml' drives a real program for that.
|
|
||||||
|
|
||||||
(defun test-flan-watch--tick-form (stopped)
|
(defun test-flan-watch--frame (form)
|
||||||
"The form `flan-watch--tick' sends with the program STOPPED or not."
|
"FORM framed as the daemon frames it."
|
||||||
(let ((sent nil)
|
(let ((payload (encode-coding-string (prin1-to-string form) 'utf-8 t)))
|
||||||
(flan-dev--stopped stopped)
|
(format "%d\n%s" (length payload) payload)))
|
||||||
(flan-dev--connection 'a-process)
|
|
||||||
(flan-dev--busy nil)
|
|
||||||
(flan-watch--pending nil)
|
|
||||||
;; Not `buffer': that consumer checks for a live watch buffer first and
|
|
||||||
;; would drop the subscription instead of ticking.
|
|
||||||
(flan-watch--consumers '(ghost)))
|
|
||||||
(cl-letf (((symbol-function 'process-live-p) (lambda (_) t))
|
|
||||||
((symbol-function 'flan-dev--take-reply) (lambda (_) nil))
|
|
||||||
((symbol-function 'flan-dev--send)
|
|
||||||
(lambda (_proc form) (setq sent form))))
|
|
||||||
(flan-watch--tick)
|
|
||||||
(list sent flan-watch--pending))))
|
|
||||||
|
|
||||||
(let ((running (test-flan-watch--tick-form nil))
|
(let* ((buf (generate-new-buffer " *flan-push-test*"))
|
||||||
(stopped (test-flan-watch--tick-form "BoundsError")))
|
(proc (make-pipe-process :name "flan-push-test" :buffer buf
|
||||||
(test-flan--check
|
:noquery t))
|
||||||
"a tick while the program runs asks for the window it is closing"
|
(painted nil)
|
||||||
(equal (nth 0 running) '(:op "watch" :reset t)))
|
(appended nil)
|
||||||
(test-flan--check
|
(flan-watch--consumers '(ghost)))
|
||||||
"a tick while the program is stopped sends no reset"
|
(with-current-buffer buf (set-buffer-multibyte nil))
|
||||||
(null (plist-get (nth 0 stopped) :reset)))
|
(unwind-protect
|
||||||
;; Skipping the tick outright would be worse than resetting: the watch would
|
(cl-letf (((symbol-function 'flan-watch--absorb)
|
||||||
;; freeze at whatever it held when the program stopped, and a break loop is
|
(lambda (r) (push r painted)))
|
||||||
;; exactly when the numbers are being read.
|
((symbol-function 'flan--append-output)
|
||||||
(test-flan--check
|
(lambda (text) (push text appended))))
|
||||||
"but it still reads the table"
|
(let ((flan-push-functions '(flan-watch--on-push))
|
||||||
(equal (plist-get (nth 0 stopped) :op) "watch"))
|
(stream
|
||||||
(test-flan--check
|
(concat
|
||||||
"and still has a reply in flight, so the cycle survives the pause"
|
(test-flan-watch--frame '(:push "output" :status "ok"
|
||||||
(and (nth 1 running) (nth 1 stopped))))
|
:output "héllo\n"))
|
||||||
|
(test-flan-watch--frame '(:status "ok" :value "42"))
|
||||||
|
(test-flan-watch--frame '(:push "watch" :status "ok"
|
||||||
|
:watch (("ticks" "7"))
|
||||||
|
:overflow nil)))))
|
||||||
|
;; In three pieces, the first ending inside the first frame's body.
|
||||||
|
(flan--filter proc (substring stream 0 12))
|
||||||
|
(test-flan--check "a push is not handled before all of it has arrived"
|
||||||
|
(null appended))
|
||||||
|
(flan--filter proc (substring stream 12 40))
|
||||||
|
(flan--filter proc (substring stream 40))
|
||||||
|
(test-flan--check "an output push reaches the output as it arrives"
|
||||||
|
(equal appended
|
||||||
|
(list (decode-coding-string
|
||||||
|
(encode-coding-string "héllo\n" 'utf-8)
|
||||||
|
'utf-8))))
|
||||||
|
(test-flan--check "a watch push behind a reply is painted without waiting for the reply to be read"
|
||||||
|
(equal (plist-get (car painted) :watch)
|
||||||
|
'(("ticks" "7"))))
|
||||||
|
(test-flan--check "and the reply is kept for the request that asked"
|
||||||
|
(equal (flan--take-reply proc)
|
||||||
|
'(:status "ok" :value "42")))
|
||||||
|
(test-flan--check "and taken once"
|
||||||
|
(null (flan--take-reply proc)))
|
||||||
|
(let ((flan-watch--consumers nil))
|
||||||
|
(flan--filter proc (test-flan-watch--frame
|
||||||
|
'(:push "watch" :status "ok" :watch nil)))
|
||||||
|
(test-flan--check "a watch push with nothing watching paints nothing"
|
||||||
|
(= 1 (length painted))))))
|
||||||
|
(delete-process proc)
|
||||||
|
(kill-buffer buf)))
|
||||||
|
|
||||||
|
;; The daemon's buffer keeps `flan-output-maximum-lines' and loses the oldest.
|
||||||
|
(let ((flan-daemon-buffer " *flan-trim-test*")
|
||||||
|
(flan-output-maximum-lines 10))
|
||||||
|
(unwind-protect
|
||||||
|
(progn
|
||||||
|
(dotimes (i 30) (flan--append-output (format "line %d\n" i)))
|
||||||
|
(with-current-buffer flan-daemon-buffer
|
||||||
|
(test-flan--check "the daemon's buffer is kept to its line limit"
|
||||||
|
(<= (count-lines (point-min) (point-max)) 10))
|
||||||
|
(test-flan--check "and keeps the newest lines"
|
||||||
|
(and (string-match-p "line 29" (buffer-string))
|
||||||
|
(not (string-match-p "line 0\n" (buffer-string)))))))
|
||||||
|
(kill-buffer flan-daemon-buffer)))
|
||||||
|
|
||||||
(provide 'test-flan-watch)
|
(provide 'test-flan-watch)
|
||||||
;;; test-flan-watch.el ends here
|
;;; test-flan-watch.el ends here
|
||||||
+3039
File diff suppressed because it is too large.
Load diff
@@ -0,0 +1,102 @@
|
|||||||
|
;;;; raylib [core] example - 2d camera mouse zoom
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_2d_camera_mouse_zoom.c at the raylib 5.5 tag. It
|
||||||
|
;;;; needed rlgl's matrix stack: the grid is a 3D grid on the XZ plane, and the
|
||||||
|
;;;; C stands it up in the XY plane by pushing a matrix, translating, rotating
|
||||||
|
;;;; ninety degrees about X and drawing. vendor/rlgl binds that stack.
|
||||||
|
;;;;
|
||||||
|
;;;; One difference from the C. The mouse read-out is `TextFormat("[%i, %i]",
|
||||||
|
;;;; ...)` through DrawTextEx with a spacing of 2. TextFormat is variadic and
|
||||||
|
;;;; unbound, so the read-out is drawn in pieces with draw-text and
|
||||||
|
;;;; digits.fln's draw-int, which space the glyphs raylib's default way.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
import rlgl "vendor:rlgl"
|
||||||
|
|
||||||
|
import d "digits.fln"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
;; 0 zooms with the mouse wheel, 1 with a right-button drag.
|
||||||
|
once zoom-mode: i32
|
||||||
|
once camera: rl/Camera2D
|
||||||
|
|
||||||
|
;; Put the world point under the mouse at the camera's origin, and the origin
|
||||||
|
;; under the mouse, so a zoom that follows keeps that point still.
|
||||||
|
fn anchor-at-mouse() -> ()
|
||||||
|
let mouse-world = rl/get-screen-to-world-2d(rl/get-mouse-position(), camera)
|
||||||
|
camera.offset = rl/get-mouse-position()
|
||||||
|
camera.target = mouse-world
|
||||||
|
|
||||||
|
;; One zoom step: `amount` is how far the input moved, and the direction is its
|
||||||
|
;; sign. The zoom stays between 1/8 and 64.
|
||||||
|
fn zoom-by(amount: f32, rate: f32) -> ()
|
||||||
|
let factor = 1.0 + rate * abs-f32(amount)
|
||||||
|
let factor = if amount < 0.0 then 1.0 / factor else factor
|
||||||
|
camera.zoom = clamp(camera.zoom * factor, 0.125, 64.0)
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - 2d camera mouse zoom")
|
||||||
|
defer rl/close-window()
|
||||||
|
;; A zero zoom makes the camera's transform singular.
|
||||||
|
camera = rl/Camera2D{.zoom 1.0}
|
||||||
|
zoom-mode = 0
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update
|
||||||
|
if rl/is-key-pressed(:key-one)
|
||||||
|
zoom-mode = 0
|
||||||
|
elif rl/is-key-pressed(:key-two)
|
||||||
|
zoom-mode = 1
|
||||||
|
;; Drag to move: the mouse's screen delta, scaled back into world units.
|
||||||
|
if rl/is-mouse-button-down(:mouse-left)
|
||||||
|
let delta = rl/v2-scale(rl/get-mouse-delta(), -1.0 / camera.zoom)
|
||||||
|
camera.target = rl/v2-add(camera.target, delta)
|
||||||
|
if zoom-mode == 0
|
||||||
|
let wheel = rl/get-mouse-wheel-move()
|
||||||
|
if wheel != 0.0
|
||||||
|
anchor-at-mouse()
|
||||||
|
zoom-by(wheel, 0.25)
|
||||||
|
else
|
||||||
|
if rl/is-mouse-button-pressed(:mouse-right)
|
||||||
|
anchor-at-mouse()
|
||||||
|
if rl/is-mouse-button-down(:mouse-right)
|
||||||
|
zoom-by(rl/get-mouse-delta().x, 0.01)
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/begin-mode-2d(camera)
|
||||||
|
;; The 3D grid, rotated ninety degrees and centred on the origin, so it
|
||||||
|
;; lies in the XY plane the 2D camera looks at.
|
||||||
|
rlgl/push-matrix()
|
||||||
|
rlgl/translate(0.0, 25.0 * 50.0, 0.0)
|
||||||
|
rlgl/rotate(90.0, 1.0, 0.0, 0.0)
|
||||||
|
rl/draw-grid(100, 50.0)
|
||||||
|
rlgl/pop-matrix()
|
||||||
|
;; A reference circle.
|
||||||
|
rl/draw-circle(rl/get-screen-width() / 2, rl/get-screen-height() / 2,
|
||||||
|
50.0, rl/maroon)
|
||||||
|
rl/end-mode-2d()
|
||||||
|
;; The mouse, and where it is in screen pixels.
|
||||||
|
let mouse = rl/get-mouse-position()
|
||||||
|
x = i32(mouse.x) - 44
|
||||||
|
y = i32(mouse.y) - 24
|
||||||
|
rl/draw-circle-v(mouse, 4.0, rl/darkgray)
|
||||||
|
rl/draw-text("[", x, y, 20, rl/black)
|
||||||
|
let x = x + rl/measure-text("[", 20)
|
||||||
|
let x = x + d/draw-int(rl/get-mouse-x(), x, y, 20, rl/black)
|
||||||
|
rl/draw-text(", ", x, y, 20, rl/black)
|
||||||
|
let x = x + rl/measure-text(", ", 20)
|
||||||
|
let x = x + d/draw-int(rl/get-mouse-y(), x, y, 20, rl/black)
|
||||||
|
rl/draw-text("]", x, y, 20, rl/black)
|
||||||
|
rl/draw-text("[1][2] Select mouse zoom mode (Wheel or Move)", 20, 20, 20,
|
||||||
|
rl/darkgray)
|
||||||
|
if zoom-mode == 0
|
||||||
|
rl/draw-text("Mouse left button drag to move, mouse wheel to zoom", 20,
|
||||||
|
50, 20, rl/darkgray)
|
||||||
|
else
|
||||||
|
rl/draw-text("Mouse left button drag to move, mouse press and move to zoom",
|
||||||
|
20, 50, 20, rl/darkgray)
|
||||||
@@ -1,137 +0,0 @@
|
|||||||
;;;; raylib [core] example - 2d camera
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_2d_camera.c. Needed no new binding at all, which is
|
|
||||||
;;;; the reason to port it: Camera2D, begin-mode-2d and end-mode-2d have been
|
|
||||||
;;;; in vendor/raylib/raylib.flan since the beginning and nothing in the
|
|
||||||
;;;; corpus had ever passed a whole Camera2D across the FFI on a frame's path.
|
|
||||||
;;;; Two Vector2s, a float and a float, by value, sixty times a second — the
|
|
||||||
;;;; acceptance table pins that layout with get-screen-to-world-2d, and this
|
|
||||||
;;;; is the same struct going into the call that actually draws with it.
|
|
||||||
;;;;
|
|
||||||
;;;; The hundred buildings are a `defvar` of fixed arrays rather than a Vec:
|
|
||||||
;;;; a global cannot hold a Vec (PORTING.md §3) and does not need to here,
|
|
||||||
;;;; because the count is a constant in the C too. `(array n T)` is the zeroed
|
|
||||||
;;;; fixed array, and the C's `= { 0 }` is exactly that.
|
|
||||||
;;;;
|
|
||||||
;;;; get-random-value comes from the generated half of the bindings. It is on
|
|
||||||
;;;; no frame's path — it runs once, before the loop — and its Flan face is
|
|
||||||
;;;; the C one, so PORTING.md §1's rule does not reach it.
|
|
||||||
;;;;
|
|
||||||
;;;; One deliberate difference from the C: `(- camera.rotation 1.0)` and the
|
|
||||||
;;;; clamp after it are written with the prelude's `clamp` macro rather than
|
|
||||||
;;;; two ifs. It is the same arithmetic; the C spells it out because C has no
|
|
||||||
;;;; clamp.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defconst max-buildings 100)
|
|
||||||
|
|
||||||
(defvar buildings [100 rl/Rectangle])
|
|
||||||
(defvar build-colors [100 rl/Color])
|
|
||||||
(defvar player rl/Rectangle)
|
|
||||||
(defvar camera rl/Camera2D)
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - 2d camera")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(set player (rl/Rectangle {.x 400.0 .y 280.0 .width 40.0 .height 40.0}))
|
|
||||||
(set buildings (array max-buildings rl/Rectangle))
|
|
||||||
(set build-colors (array max-buildings rl/Color))
|
|
||||||
|
|
||||||
;; The skyline: each building is as wide as the last one left room for, so
|
|
||||||
;; the spacing accumulates and the row starts 6000 units to the left.
|
|
||||||
(let [spacing 0]
|
|
||||||
(dotimes [i max-buildings]
|
|
||||||
(let [w (f32 (rl/get-random-value 50 200))
|
|
||||||
h (f32 (rl/get-random-value 100 800))]
|
|
||||||
(set (at buildings i)
|
|
||||||
(rl/Rectangle {.x (+ -6000.0 (f32 spacing))
|
|
||||||
.y (- (- (f32 screen-height) 130.0) h)
|
|
||||||
.width w
|
|
||||||
.height h}))
|
|
||||||
(set spacing (+ spacing (i32 w)))
|
|
||||||
(set (at build-colors i)
|
|
||||||
(rl/Color {.r (u8 (rl/get-random-value 200 240))
|
|
||||||
.g (u8 (rl/get-random-value 200 240))
|
|
||||||
.b (u8 (rl/get-random-value 200 250))
|
|
||||||
.a 255})))))
|
|
||||||
|
|
||||||
;; A fresh Camera2D is all zeroes and a zoom of 0 makes the transform
|
|
||||||
;; singular, so the zoom is the one field that must be set — raylib.flan's
|
|
||||||
;; own comment on the struct says so.
|
|
||||||
(set camera (rl/Camera2D {.offset (rl/Vector2 {.x (/ (f32 screen-width) 2.0)
|
|
||||||
.y (/ (f32 screen-height) 2.0)})
|
|
||||||
.target (rl/Vector2 {.x (+ (.x player) 20.0)
|
|
||||||
.y (+ (.y player) 20.0)})
|
|
||||||
.rotation 0.0
|
|
||||||
.zoom 1.0}))
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
|
||||||
;; The C's `if (RIGHT) ... else if (LEFT) ...`: both held cancels to the
|
|
||||||
;; right, which is the else-if and not an accident.
|
|
||||||
(if (rl/key-down? :right)
|
|
||||||
(set (.x player) (+ (.x player) 2.0))
|
|
||||||
(when (rl/key-down? :left) (set (.x player) (- (.x player) 2.0))))
|
|
||||||
|
|
||||||
;; The camera follows the player's centre.
|
|
||||||
(set (.target camera) (rl/Vector2 {.x (+ (.x player) 20.0)
|
|
||||||
.y (+ (.y player) 20.0)}))
|
|
||||||
|
|
||||||
(if (rl/key-down? :a)
|
|
||||||
(set (.rotation camera) (- (.rotation camera) 1.0))
|
|
||||||
(when (rl/key-down? :s)
|
|
||||||
(set (.rotation camera) (+ (.rotation camera) 1.0))))
|
|
||||||
(set (.rotation camera) (clamp (.rotation camera) -40.0 40.0))
|
|
||||||
|
|
||||||
(set (.zoom camera) (+ (.zoom camera) (* (rl/get-mouse-wheel-move) 0.05)))
|
|
||||||
(set (.zoom camera) (clamp (.zoom camera) 0.1 3.0))
|
|
||||||
|
|
||||||
(when (rl/key-pressed? :r)
|
|
||||||
(set (.zoom camera) 1.0)
|
|
||||||
(set (.rotation camera) 0.0))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
;; Everything inside with-mode-2d is in world space and goes through
|
|
||||||
;; the camera. The ground and the crosshair lines are drawn far outside
|
|
||||||
;; the window on purpose: at zoom 0.1 they still have to reach the edges.
|
|
||||||
(rl/with-mode-2d camera
|
|
||||||
(rl/draw-rectangle -6000 320 13000 8000 rl/darkgray)
|
|
||||||
|
|
||||||
(dotimes [i max-buildings]
|
|
||||||
(rl/draw-rectangle-rec (at buildings i) (at build-colors i)))
|
|
||||||
|
|
||||||
(rl/draw-rectangle-rec player rl/red)
|
|
||||||
|
|
||||||
(rl/draw-line (i32 (.x (.target camera))) (* screen-height -10)
|
|
||||||
(i32 (.x (.target camera))) (* screen-height 10) rl/green)
|
|
||||||
(rl/draw-line (* screen-width -10) (i32 (.y (.target camera)))
|
|
||||||
(* screen-width 10) (i32 (.y (.target camera))) rl/green))
|
|
||||||
|
|
||||||
;; And everything after it is in screen space again — the frame drawn
|
|
||||||
;; around the window is how the example shows the difference.
|
|
||||||
(rl/draw-text "SCREEN AREA" 640 10 20 rl/red)
|
|
||||||
|
|
||||||
(rl/draw-rectangle 0 0 screen-width 5 rl/red)
|
|
||||||
(rl/draw-rectangle 0 5 5 (- screen-height 10) rl/red)
|
|
||||||
(rl/draw-rectangle (- screen-width 5) 5 5 (- screen-height 10) rl/red)
|
|
||||||
(rl/draw-rectangle 0 (- screen-height 5) screen-width 5 rl/red)
|
|
||||||
|
|
||||||
(rl/draw-rectangle 10 10 250 113 (rl/fade rl/skyblue 0.5))
|
|
||||||
(rl/draw-rectangle-lines 10 10 250 113 rl/blue)
|
|
||||||
|
|
||||||
(rl/draw-text "Free 2d camera controls:" 20 20 10 rl/black)
|
|
||||||
(rl/draw-text "- Right/Left to move Offset" 40 40 10 rl/darkgray)
|
|
||||||
(rl/draw-text "- Mouse Wheel to Zoom in-out" 40 60 10 rl/darkgray)
|
|
||||||
(rl/draw-text "- A / S to Rotate" 40 80 10 rl/darkgray)
|
|
||||||
(rl/draw-text "- R to reset Zoom and Rotation" 40 100 10 rl/darkgray))))
|
|
||||||
@@ -0,0 +1,106 @@
|
|||||||
|
;;;; raylib [core] example - 2d camera
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_2d_camera.c. Needed no new binding at all, which is
|
||||||
|
;;;; the reason to port it: Camera2D, begin-mode-2d and end-mode-2d have been
|
||||||
|
;;;; in vendor/raylib/raylib.fln since the beginning and nothing in the
|
||||||
|
;;;; corpus had ever passed a whole Camera2D across the FFI on a frame's path.
|
||||||
|
;;;; Two Vector2s, a float and a float, by value, sixty times a second — the
|
||||||
|
;;;; acceptance table pins that layout with get-screen-to-world-2d, and this
|
||||||
|
;;;; is the same struct going into the call that actually draws with it.
|
||||||
|
;;;;
|
||||||
|
;;;; The hundred buildings are a `once` of fixed arrays rather than a Vec:
|
||||||
|
;;;; a global cannot hold a Vec (docs/PORTING.md §3) and does not need to here,
|
||||||
|
;;;; because the count is a constant in the C too. `array(n, T)` is the zeroed
|
||||||
|
;;;; fixed array, and the C's `= { 0 }` is exactly that.
|
||||||
|
;;;;
|
||||||
|
;;;; get-random-value comes from the generated half of the bindings. It is on
|
||||||
|
;;;; no frame's path — it runs once, before the loop — and its Flan face is
|
||||||
|
;;;; the C one, so docs/PORTING.md §1's rule does not reach it.
|
||||||
|
;;;;
|
||||||
|
;;;; One deliberate difference from the C: `camera.rotation - 1.0` and the
|
||||||
|
;;;; clamp after it are written with the prelude's `clamp` macro rather than
|
||||||
|
;;;; two ifs. It is the same arithmetic; the C spells it out because C has no
|
||||||
|
;;;; clamp.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
const max-buildings = 100
|
||||||
|
|
||||||
|
once buildings: [100 rl/Rectangle]
|
||||||
|
once build-colors: [100 rl/Color]
|
||||||
|
once player: rl/Rectangle
|
||||||
|
once camera: rl/Camera2D
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - 2d camera")
|
||||||
|
defer rl/close-window()
|
||||||
|
player = rl/Rectangle{.x 400.0, .y 280.0, .width 40.0, .height 40.0}
|
||||||
|
buildings = array(max-buildings, rl/Rectangle)
|
||||||
|
build-colors = array(max-buildings, rl/Color)
|
||||||
|
;; The skyline: each building is as wide as the last one left room for, so
|
||||||
|
;; the spacing accumulates and the row starts 6000 units to the left.
|
||||||
|
let spacing = 0
|
||||||
|
for i in 0..max-buildings
|
||||||
|
let w = f32(rl/get-random-value(50, 200))
|
||||||
|
h = f32(rl/get-random-value(100, 800))
|
||||||
|
buildings[i] = rl/Rectangle{.x -6000.0 + f32(spacing), .y (f32(screen-height) - 130.0) - h, .width w, .height h}
|
||||||
|
spacing += i32(w)
|
||||||
|
build-colors[i] = rl/Color{.r u8(rl/get-random-value(200, 240)) .g u8(rl/get-random-value(200, 240)) .b u8(rl/get-random-value(200, 250)) .a 255}
|
||||||
|
;; A fresh Camera2D is all zeroes and a zoom of 0 makes the transform
|
||||||
|
;; singular, so the zoom is the one field that must be set — raylib.fln's
|
||||||
|
;; own comment on the struct says so.
|
||||||
|
camera = rl/Camera2D{.offset rl/Vector2{.x f32(screen-width) / 2.0, .y f32(screen-height) / 2.0} .target rl/Vector2{.x player.x + 20.0, .y player.y + 20.0} .rotation 0.0 .zoom 1.0}
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update
|
||||||
|
;; The C's `if (RIGHT) ... else if (LEFT) ...`: both held cancels to the
|
||||||
|
;; right, which is the else-if and not an accident.
|
||||||
|
if rl/is-key-down(:key-right)
|
||||||
|
player.x += 2.0
|
||||||
|
elif rl/is-key-down(:key-left)
|
||||||
|
player.x -= 2.0
|
||||||
|
;; The camera follows the player's centre.
|
||||||
|
camera.target = rl/Vector2{.x player.x + 20.0, .y player.y + 20.0}
|
||||||
|
if rl/is-key-down(:key-a)
|
||||||
|
camera.rotation -= 1.0
|
||||||
|
elif rl/is-key-down(:key-s)
|
||||||
|
camera.rotation += 1.0
|
||||||
|
camera.rotation = clamp(camera.rotation, -40.0, 40.0)
|
||||||
|
camera.zoom += rl/get-mouse-wheel-move() * 0.05
|
||||||
|
camera.zoom = clamp(camera.zoom, 0.1, 3.0)
|
||||||
|
if rl/is-key-pressed(:key-r)
|
||||||
|
camera.zoom = 1.0
|
||||||
|
camera.rotation = 0.0
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
;; Everything inside with-mode-2d is in world space and goes through
|
||||||
|
;; the camera. The ground and the crosshair lines are drawn far outside
|
||||||
|
;; the window on purpose: at zoom 0.1 they still have to reach the edges.
|
||||||
|
rl/with-mode-2d(camera):
|
||||||
|
rl/draw-rectangle(-6000, 320, 13000, 8000, rl/darkgray)
|
||||||
|
for i in 0..max-buildings
|
||||||
|
rl/draw-rectangle-rec(buildings[i], build-colors[i])
|
||||||
|
rl/draw-rectangle-rec(player, rl/red)
|
||||||
|
rl/draw-line(i32(camera.target.x), screen-height * -10,
|
||||||
|
i32(camera.target.x), screen-height * 10, rl/green)
|
||||||
|
rl/draw-line(screen-width * -10, i32(camera.target.y),
|
||||||
|
screen-width * 10, i32(camera.target.y), rl/green)
|
||||||
|
;; And everything after it is in screen space again — the frame drawn
|
||||||
|
;; around the window is how the example shows the difference.
|
||||||
|
rl/draw-text("SCREEN AREA", 640, 10, 20, rl/red)
|
||||||
|
rl/draw-rectangle(0, 0, screen-width, 5, rl/red)
|
||||||
|
rl/draw-rectangle(0, 5, 5, screen-height - 10, rl/red)
|
||||||
|
rl/draw-rectangle(screen-width - 5, 5, 5, screen-height - 10, rl/red)
|
||||||
|
rl/draw-rectangle(0, screen-height - 5, screen-width, 5, rl/red)
|
||||||
|
rl/draw-rectangle(10, 10, 250, 113, rl/fade(rl/skyblue, 0.5))
|
||||||
|
rl/draw-rectangle-lines(10, 10, 250, 113, rl/blue)
|
||||||
|
rl/draw-text("Free 2d camera controls:", 20, 20, 10, rl/black)
|
||||||
|
rl/draw-text("- Right/Left to move Offset", 40, 40, 10, rl/darkgray)
|
||||||
|
rl/draw-text("- Mouse Wheel to Zoom in-out", 40, 60, 10, rl/darkgray)
|
||||||
|
rl/draw-text("- A / S to Rotate", 40, 80, 10, rl/darkgray)
|
||||||
|
rl/draw-text("- R to reset Zoom and Rotation", 40, 100, 10, rl/darkgray)
|
||||||
@@ -1,153 +0,0 @@
|
|||||||
;;;; raylib [core] example - 3d picking
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_3d_picking.c. The one `core` example in this batch,
|
|
||||||
;;;; and it is here for surface and not for category: it is the only example
|
|
||||||
;;;; anywhere upstream that uses Ray and RayCollision without also loading a
|
|
||||||
;;;; Model, so it is the only way those two structs get a caller at all.
|
|
||||||
;;;;
|
|
||||||
;;;; Picking is the round trip the corpus was missing. core-world-screen.flan
|
|
||||||
;;;; already runs get-world-to-screen — a point in the scene to a pixel. This
|
|
||||||
;;;; is the inverse and it is a different shape: a pixel does not name a
|
|
||||||
;;;; point, it names a *line* through the scene, which is what a Ray is, and
|
|
||||||
;;;; the answer to "what did I click on" is where that line first meets
|
|
||||||
;;;; something, which is what a RayCollision is. Two structs the package could
|
|
||||||
;;;; not describe, for one operation that cannot be written without them.
|
|
||||||
;;;;
|
|
||||||
;;;; What was added, all in vendor/raylib/raylib.flan:
|
|
||||||
;;;;
|
|
||||||
;;;; - `Ray` — two Vector3s, origin and direction.
|
|
||||||
;;;; - `RayCollision` — a C `bool`, a float and two Vector3s. This is the
|
|
||||||
;;;; one of the three new structs a layout check can actually fail:
|
|
||||||
;;;; `hit` is one byte and `distance` is four, so there are three padding
|
|
||||||
;;;; bytes between them that a permutation destroys. BoundingBox's two
|
|
||||||
;;;; Vector3s are interchangeable and nothing would catch swapping them.
|
|
||||||
;;;; - `BoundingBox` — shared with examples/models-box-collisions.flan.
|
|
||||||
;;;; - get-screen-to-world-ray and draw-ray, hand-written beside
|
|
||||||
;;;; get-world-to-screen and the cube draws for the reasons `bindings`
|
|
||||||
;;;; gives: the first reads the same camera as its inverse, and the second
|
|
||||||
;;;; is inside a frame.
|
|
||||||
;;;;
|
|
||||||
;;;; get-ray-collision-box came free out of the generated half the moment Ray
|
|
||||||
;;;; and BoundingBox existed, along with the sphere, triangle and quad forms.
|
|
||||||
;;;; get-ray-collision-mesh is still refused and will stay refused: Mesh owns
|
|
||||||
;;;; seven arrays and a GPU handle, and describing it is a different job.
|
|
||||||
;;;;
|
|
||||||
;;;; raylib 5.5 renamed GetMouseRay to GetScreenToWorldRay and left the old
|
|
||||||
;;;; name as a #define. A #define is not a symbol, so there is nothing to bind
|
|
||||||
;;;; it to and nothing lost by not trying.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defvar camera rl/Camera3D)
|
|
||||||
|
|
||||||
(defvar cube-position rl/Vector3)
|
|
||||||
(defvar cube-size rl/Vector3)
|
|
||||||
|
|
||||||
;; The picking ray, kept between frames because draw-ray draws it every frame
|
|
||||||
;; whether or not it hit anything — that is how the example shows where the
|
|
||||||
;; click went.
|
|
||||||
(defvar ray rl/Ray)
|
|
||||||
(defvar collision rl/RayCollision)
|
|
||||||
|
|
||||||
;; The same centre/size to min/max conversion as in
|
|
||||||
;; examples/models-box-collisions.flan. Written out here rather than shared
|
|
||||||
;; because an example is a single file the reader can follow end to end.
|
|
||||||
;;
|
|
||||||
;; It used to be eight expressions of field arithmetic; it is the half-extent
|
|
||||||
;; subtracted and added, which is what the C means, now that the package
|
|
||||||
;; carries vector arithmetic — see vendor/raylib/vector.flan. That file
|
|
||||||
;; exists because raymath is `static inline` and has no symbol to bind, so
|
|
||||||
;; v3-sub and v3-add are Flan and not C.
|
|
||||||
(defn box-around [centre rl/Vector3 size rl/Vector3] rl/BoundingBox
|
|
||||||
(let [half (rl/v3-scale size 0.5)]
|
|
||||||
(rl/BoundingBox {.min (rl/v3-sub centre half)
|
|
||||||
.max (rl/v3-add centre half)})))
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - 3d picking")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(set camera (rl/Camera3D {.position (rl/Vector3 {.x 10.0 .y 10.0 .z 10.0})
|
|
||||||
.target (rl/Vector3 {.x 0.0 .y 0.0 .z 0.0})
|
|
||||||
.up (rl/Vector3 {.x 0.0 .y 1.0 .z 0.0})
|
|
||||||
.fovy 45.0
|
|
||||||
.projection :perspective}))
|
|
||||||
|
|
||||||
(set cube-position (rl/Vector3 {.x 0.0 .y 1.0 .z 0.0}))
|
|
||||||
(set cube-size (rl/Vector3 {.x 2.0 .y 2.0 .z 2.0}))
|
|
||||||
|
|
||||||
;; Both start zeroed, which is the C's `= { 0 }`. A zero Ray draws as a
|
|
||||||
;; degenerate line at the origin and a zero RayCollision has hit false, so
|
|
||||||
;; neither needs a "not yet" flag beside it.
|
|
||||||
(set ray (rl/Ray {.position (rl/Vector3 {.x 0.0 .y 0.0 .z 0.0})
|
|
||||||
.direction (rl/Vector3 {.x 0.0 .y 0.0 .z 0.0})}))
|
|
||||||
(set collision (rl/RayCollision {.hit false .distance 0.0
|
|
||||||
.point (rl/Vector3 {.x 0.0 .y 0.0 .z 0.0})
|
|
||||||
.normal (rl/Vector3 {.x 0.0 .y 0.0 .z 0.0})}))
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update. The first-person controls only run while the cursor is
|
|
||||||
;; captured, which is what the right button toggles — otherwise the mouse
|
|
||||||
;; could not be used to aim at anything.
|
|
||||||
(when (rl/cursor-hidden?) (rl/update-camera (addr camera) :first-person))
|
|
||||||
|
|
||||||
(when (rl/mouse-button-pressed? :right)
|
|
||||||
(if (rl/cursor-hidden?) (rl/enable-cursor) (rl/disable-cursor)))
|
|
||||||
|
|
||||||
(when (rl/mouse-button-pressed? :left)
|
|
||||||
(if (not (.hit collision))
|
|
||||||
;; The pixel under the pointer, as a line through the scene, tested
|
|
||||||
;; against the cube's bounds.
|
|
||||||
(do
|
|
||||||
(set ray (rl/get-screen-to-world-ray (rl/get-mouse-position) camera))
|
|
||||||
(set collision
|
|
||||||
(rl/get-ray-collision-box ray (box-around cube-position cube-size))))
|
|
||||||
;; A second click deselects. Only `hit` is cleared; the ray stays put
|
|
||||||
;; and keeps being drawn, as in the C.
|
|
||||||
(set (.hit collision) false)))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(rl/with-mode-3d camera
|
|
||||||
(if (.hit collision)
|
|
||||||
(do
|
|
||||||
(rl/draw-cube cube-position (.x cube-size) (.y cube-size) (.z cube-size)
|
|
||||||
rl/red)
|
|
||||||
(rl/draw-cube-wires cube-position (.x cube-size) (.y cube-size)
|
|
||||||
(.z cube-size) rl/maroon)
|
|
||||||
;; A slightly larger wireframe around the selection, which is the
|
|
||||||
;; whole visual feedback of the example.
|
|
||||||
(rl/draw-cube-wires cube-position (+ (.x cube-size) 0.2)
|
|
||||||
(+ (.y cube-size) 0.2) (+ (.z cube-size) 0.2)
|
|
||||||
rl/green))
|
|
||||||
(do
|
|
||||||
(rl/draw-cube cube-position (.x cube-size) (.y cube-size) (.z cube-size)
|
|
||||||
rl/gray)
|
|
||||||
(rl/draw-cube-wires cube-position (.x cube-size) (.y cube-size)
|
|
||||||
(.z cube-size) rl/darkgray)))
|
|
||||||
|
|
||||||
;; raylib draws the ray a thousand units long, so it reads as a line
|
|
||||||
;; crossing the scene rather than as a segment with an end.
|
|
||||||
(rl/draw-ray ray rl/maroon)
|
|
||||||
(rl/draw-grid 10 1.0))
|
|
||||||
|
|
||||||
(rl/draw-text "Try clicking on the box with your mouse!" 240 10 20
|
|
||||||
rl/darkgray)
|
|
||||||
|
|
||||||
(when (.hit collision)
|
|
||||||
(rl/draw-text "BOX SELECTED"
|
|
||||||
(/ (- screen-width (rl/measure-text "BOX SELECTED" 30)) 2)
|
|
||||||
(i32 (* (f32 screen-height) 0.1)) 30 rl/green))
|
|
||||||
|
|
||||||
(rl/draw-text "Right click mouse to toggle camera controls" 10 430 10
|
|
||||||
rl/gray)
|
|
||||||
|
|
||||||
(rl/draw-fps 10 10))))
|
|
||||||
@@ -0,0 +1,130 @@
|
|||||||
|
;;;; raylib [core] example - 3d picking
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_3d_picking.c. The one `core` example in this batch,
|
||||||
|
;;;; and it is here for surface and not for category: it is the only example
|
||||||
|
;;;; anywhere upstream that uses Ray and RayCollision without also loading a
|
||||||
|
;;;; Model, so it is the only way those two structs get a caller at all.
|
||||||
|
;;;;
|
||||||
|
;;;; Picking is the round trip the corpus was missing. core-world-screen.fln
|
||||||
|
;;;; already runs get-world-to-screen — a point in the scene to a pixel. This
|
||||||
|
;;;; is the inverse and it is a different shape: a pixel does not name a
|
||||||
|
;;;; point, it names a *line* through the scene, which is what a Ray is, and
|
||||||
|
;;;; the answer to "what did I click on" is where that line first meets
|
||||||
|
;;;; something, which is what a RayCollision is. Two structs the package could
|
||||||
|
;;;; not describe, for one operation that cannot be written without them.
|
||||||
|
;;;;
|
||||||
|
;;;; What was added, all in vendor/raylib/raylib.fln:
|
||||||
|
;;;;
|
||||||
|
;;;; - `Ray` — two Vector3s, origin and direction.
|
||||||
|
;;;; - `RayCollision` — a C `bool`, a float and two Vector3s. This is the
|
||||||
|
;;;; one of the three new structs a layout check can actually fail:
|
||||||
|
;;;; `hit` is one byte and `distance` is four, so there are three padding
|
||||||
|
;;;; bytes between them that a permutation destroys. BoundingBox's two
|
||||||
|
;;;; Vector3s are interchangeable and nothing would catch swapping them.
|
||||||
|
;;;; - `BoundingBox` — shared with examples/models-box-collisions.fln.
|
||||||
|
;;;; - get-screen-to-world-ray and draw-ray, hand-written beside
|
||||||
|
;;;; get-world-to-screen and the cube draws for the reasons `bindings`
|
||||||
|
;;;; gives: the first reads the same camera as its inverse, and the second
|
||||||
|
;;;; is inside a frame.
|
||||||
|
;;;;
|
||||||
|
;;;; get-ray-collision-box came free out of the generated half the moment Ray
|
||||||
|
;;;; and BoundingBox existed, along with the sphere, triangle and quad forms.
|
||||||
|
;;;; get-ray-collision-mesh is still refused and will stay refused: Mesh owns
|
||||||
|
;;;; seven arrays and a GPU handle, and describing it is a different job.
|
||||||
|
;;;;
|
||||||
|
;;;; raylib 5.5 renamed GetMouseRay to GetScreenToWorldRay and left the old
|
||||||
|
;;;; name as a #define. A #define is not a symbol, so there is nothing to bind
|
||||||
|
;;;; it to and nothing lost by not trying.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
once camera: rl/Camera3D
|
||||||
|
|
||||||
|
once cube-position: rl/Vector3
|
||||||
|
once cube-size: rl/Vector3
|
||||||
|
|
||||||
|
;; The picking ray, kept between frames because draw-ray draws it every frame
|
||||||
|
;; whether or not it hit anything — that is how the example shows where the
|
||||||
|
;; click went.
|
||||||
|
once ray: rl/Ray
|
||||||
|
once collision: rl/RayCollision
|
||||||
|
|
||||||
|
;; The same centre/size to min/max conversion as in
|
||||||
|
;; examples/models-box-collisions.fln. Written out here rather than shared
|
||||||
|
;; because an example is a single file the reader can follow end to end.
|
||||||
|
;;
|
||||||
|
;; It used to be eight expressions of field arithmetic; it is the half-extent
|
||||||
|
;; subtracted and added, which is what the C means, now that the package
|
||||||
|
;; carries vector arithmetic — see vendor/raylib/vector.fln. That file
|
||||||
|
;; exists because raymath is `static inline` and has no symbol to bind, so
|
||||||
|
;; v3-sub and v3-add are Flan and not C.
|
||||||
|
fn box-around(centre: rl/Vector3, size: rl/Vector3) -> rl/BoundingBox
|
||||||
|
let half = rl/v3-scale(size, 0.5)
|
||||||
|
rl/BoundingBox{.min rl/v3-sub(centre, half) .max rl/v3-add(centre, half)}
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - 3d picking")
|
||||||
|
defer rl/close-window()
|
||||||
|
camera = rl/Camera3D{.position rl/Vector3{.x 10.0 .y 10.0 .z 10.0} .target rl/Vector3{.x 0.0 .y 0.0 .z 0.0} .up rl/Vector3{.x 0.0 .y 1.0 .z 0.0} .fovy 45.0 .projection :projection-perspective}
|
||||||
|
cube-position = rl/Vector3{.x 0.0 .y 1.0 .z 0.0}
|
||||||
|
cube-size = rl/Vector3{.x 2.0 .y 2.0 .z 2.0}
|
||||||
|
;; Both start zeroed, which is the C's `= { 0 }`. A zero Ray draws as a
|
||||||
|
;; degenerate line at the origin and a zero RayCollision has hit false, so
|
||||||
|
;; neither needs a "not yet" flag beside it.
|
||||||
|
ray = rl/Ray{.position rl/Vector3{.x 0.0 .y 0.0 .z 0.0} .direction rl/Vector3{.x 0.0 .y 0.0 .z 0.0}}
|
||||||
|
collision = rl/RayCollision{.hit false .distance 0.0 .point rl/Vector3{.x 0.0 .y 0.0 .z 0.0} .normal rl/Vector3{.x 0.0 .y 0.0 .z 0.0}}
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update. The first-person controls only run while the cursor is
|
||||||
|
;; captured, which is what the right button toggles — otherwise the mouse
|
||||||
|
;; could not be used to aim at anything.
|
||||||
|
if rl/is-cursor-hidden()
|
||||||
|
rl/update-camera(addr(camera), :camera-first-person)
|
||||||
|
if rl/is-mouse-button-pressed(:mouse-right)
|
||||||
|
if rl/is-cursor-hidden() then rl/enable-cursor() else rl/disable-cursor()
|
||||||
|
if rl/is-mouse-button-pressed(:mouse-left)
|
||||||
|
if not collision.hit
|
||||||
|
;; The pixel under the pointer, as a line through the scene, tested
|
||||||
|
;; against the cube's bounds.
|
||||||
|
ray = rl/get-screen-to-world-ray(rl/get-mouse-position(), camera)
|
||||||
|
collision = rl/get-ray-collision-box(ray,
|
||||||
|
box-around(cube-position, cube-size))
|
||||||
|
;; A second click deselects. Only `hit` is cleared; the ray stays put
|
||||||
|
;; and keeps being drawn, as in the C.
|
||||||
|
else
|
||||||
|
collision.hit = false
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/with-mode-3d(camera):
|
||||||
|
if collision.hit
|
||||||
|
rl/draw-cube(cube-position, cube-size.x, cube-size.y, cube-size.z,
|
||||||
|
rl/red)
|
||||||
|
rl/draw-cube-wires(cube-position, cube-size.x, cube-size.y,
|
||||||
|
cube-size.z, rl/maroon)
|
||||||
|
;; A slightly larger wireframe around the selection, which is the
|
||||||
|
;; whole visual feedback of the example.
|
||||||
|
rl/draw-cube-wires(cube-position, cube-size.x + 0.2,
|
||||||
|
cube-size.y + 0.2, cube-size.z + 0.2, rl/green)
|
||||||
|
else
|
||||||
|
rl/draw-cube(cube-position, cube-size.x, cube-size.y, cube-size.z,
|
||||||
|
rl/gray)
|
||||||
|
rl/draw-cube-wires(cube-position, cube-size.x, cube-size.y,
|
||||||
|
cube-size.z, rl/darkgray)
|
||||||
|
;; raylib draws the ray a thousand units long, so it reads as a line
|
||||||
|
;; crossing the scene rather than as a segment with an end.
|
||||||
|
rl/draw-ray(ray, rl/maroon)
|
||||||
|
rl/draw-grid(10, 1.0)
|
||||||
|
rl/draw-text("Try clicking on the box with your mouse!", 240, 10, 20,
|
||||||
|
rl/darkgray)
|
||||||
|
if collision.hit
|
||||||
|
rl/draw-text("BOX SELECTED",
|
||||||
|
(screen-width - rl/measure-text("BOX SELECTED", 30)) / 2,
|
||||||
|
i32(f32(screen-height) * 0.1), 30, rl/green)
|
||||||
|
rl/draw-text("Right click mouse to toggle camera controls", 10, 430, 10,
|
||||||
|
rl/gray)
|
||||||
|
rl/draw-fps(10, 10)
|
||||||
@@ -6,26 +6,24 @@
|
|||||||
;;;;
|
;;;;
|
||||||
;;;; The one structural difference from the C is the loop: the C writes
|
;;;; The one structural difference from the C is the loop: the C writes
|
||||||
;;;; `while (!WindowShouldClose())` and Flan has `until`, which is the same
|
;;;; `while (!WindowShouldClose())` and Flan has `until`, which is the same
|
||||||
;;;; thing without the negation. sand.flan does likewise.
|
;;;; thing without the negation. sand.fln does likewise.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; `defer` closes the window. It is function-scoped — it runs when `main`
|
;;;; `defer` closes the window. It is function-scoped — it runs when `main`
|
||||||
;;;; returns and not at the end of any inner block — which is exactly what the
|
;;;; returns and not at the end of any inner block — which is exactly what the
|
||||||
;;;; C's trailing CloseWindow() means here.
|
;;;; C's trailing CloseWindow() means here.
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
(defconst screen-width 800)
|
const screen-width = 800
|
||||||
(defconst screen-height 450)
|
const screen-height = 450
|
||||||
|
|
||||||
(defn main [] ()
|
fn main() -> ()
|
||||||
(rl/init-window screen-width screen-height
|
rl/init-window(screen-width, screen-height,
|
||||||
"raylib [core] example - basic window")
|
"raylib [core] example - basic window")
|
||||||
(defer (rl/close-window))
|
defer rl/close-window()
|
||||||
|
rl/set-target-fps(60)
|
||||||
(rl/set-target-fps 60)
|
until rl/window-should-close()
|
||||||
|
rl/with-drawing:
|
||||||
(until (rl/window-should-close?)
|
rl/clear-background(rl/raywhite)
|
||||||
(rl/with-drawing
|
rl/draw-text("Congrats! You created your first window!", 190, 200, 20,
|
||||||
(rl/clear-background rl/raywhite)
|
rl/lightgray)
|
||||||
(rl/draw-text "Congrats! You created your first window!" 190 200 20
|
|
||||||
rl/lightgray))))
|
|
||||||
@@ -1,117 +0,0 @@
|
|||||||
;;;; raylib [core] example - delta time
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_delta_time.c. Needed get-mouse-wheel-move and get-fps,
|
|
||||||
;;;; both now bound — draw-fps was already there, but it puts the number on the
|
|
||||||
;;;; screen itself and this example wants to compare it against the target it
|
|
||||||
;;;; set, so it needs the number back.
|
|
||||||
;;;;
|
|
||||||
;;;; Three TextFormats in the C. Two of the three are a fixed number of
|
|
||||||
;;;; decimal places, which `f64->bytes` cannot do — it is "%g" — so they
|
|
||||||
;;;; still go through examples/digits.flan. The integer one does too, only
|
|
||||||
;;;; because its width is needed to put the next piece after it; the draw
|
|
||||||
;;;; itself is now (string (i64->bytes n)) and one draw-text.
|
|
||||||
;;;;
|
|
||||||
;;;; One faithfulness note that is a bug in the C and is kept anyway: it draws
|
|
||||||
;;;; `TextFormat("Frame time: %02.02f ms", GetFrameTime())` — GetFrameTime is
|
|
||||||
;;;; in SECONDS, so at 60 fps the C's own screen reads "0.02 ms" for what is
|
|
||||||
;;;; really 16.7 ms. Porting it as-is means the two programs show the same
|
|
||||||
;;;; thing, which is what a port is for; the milliseconds are drawn beside it
|
|
||||||
;;;; here rather than instead of it, so the file is not quietly asserting that
|
|
||||||
;;;; the original was right.
|
|
||||||
;;;;
|
|
||||||
;;;; The two circle positions are `defvar`s for the usual reason: they are
|
|
||||||
;;;; state between frames and a `let` inside the loop would reset them.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
(import d "digits.flan")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defconst speed f32 10.0)
|
|
||||||
(defconst circle-radius f32 32.0)
|
|
||||||
|
|
||||||
(defvar delta-circle rl/Vector2)
|
|
||||||
(defvar frame-circle rl/Vector2)
|
|
||||||
(defvar current-fps i32)
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - delta time")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(set current-fps 60)
|
|
||||||
(set delta-circle (rl/Vector2 {.x 0.0 .y (/ (f32 screen-height) 3.0)}))
|
|
||||||
(set frame-circle (rl/Vector2 {.x 0.0
|
|
||||||
.y (* (f32 screen-height) (/ 2.0 3.0))}))
|
|
||||||
|
|
||||||
(rl/set-target-fps current-fps)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
|
||||||
(let [wheel (rl/get-mouse-wheel-move)]
|
|
||||||
(unless (= wheel 0.0)
|
|
||||||
(set current-fps (+ current-fps (i32 wheel)))
|
|
||||||
(when (< current-fps 0) (set current-fps 0))
|
|
||||||
(rl/set-target-fps current-fps)))
|
|
||||||
|
|
||||||
;; The whole point of the example: one circle is scaled by the frame time
|
|
||||||
;; and one is not, so lowering the target with the wheel makes the second
|
|
||||||
;; one crawl while the first keeps its speed.
|
|
||||||
(set (.x delta-circle)
|
|
||||||
(+ (.x delta-circle) (* (rl/get-frame-time) (* 6.0 speed))))
|
|
||||||
(set (.x frame-circle) (+ (.x frame-circle) (* 0.1 speed)))
|
|
||||||
|
|
||||||
(when (> (.x delta-circle) (f32 screen-width)) (set (.x delta-circle) 0.0))
|
|
||||||
(when (> (.x frame-circle) (f32 screen-width)) (set (.x frame-circle) 0.0))
|
|
||||||
|
|
||||||
(when (rl/key-pressed? :r)
|
|
||||||
(set (.x delta-circle) 0.0)
|
|
||||||
(set (.x frame-circle) 0.0))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(rl/draw-circle-v delta-circle circle-radius rl/red)
|
|
||||||
(rl/draw-circle-v frame-circle circle-radius rl/blue)
|
|
||||||
|
|
||||||
;; "FPS: unlimited (%i)" when the target is 0, "FPS: %i (target: %i)"
|
|
||||||
;; otherwise — the C's own branch, reassembled out of literals and
|
|
||||||
;; draw-int. `x` walks along the line as each piece is drawn, which is what
|
|
||||||
;; the returned width from draw-int is for.
|
|
||||||
(if (<= current-fps 0)
|
|
||||||
(let [x 10]
|
|
||||||
(rl/draw-text "FPS: unlimited (" x 10 20 rl/darkgray)
|
|
||||||
(set x (+ x (rl/measure-text "FPS: unlimited (" 20)))
|
|
||||||
(set x (+ x (d/draw-int (rl/get-fps) x 10 20 rl/darkgray)))
|
|
||||||
(rl/draw-text ")" x 10 20 rl/darkgray))
|
|
||||||
(let [x 10]
|
|
||||||
(rl/draw-text "FPS: " x 10 20 rl/darkgray)
|
|
||||||
(set x (+ x (rl/measure-text "FPS: " 20)))
|
|
||||||
(set x (+ x (d/draw-int (rl/get-fps) x 10 20 rl/darkgray)))
|
|
||||||
(rl/draw-text " (target: " x 10 20 rl/darkgray)
|
|
||||||
(set x (+ x (rl/measure-text " (target: " 20)))
|
|
||||||
(set x (+ x (d/draw-int current-fps x 10 20 rl/darkgray)))
|
|
||||||
(rl/draw-text ")" x 10 20 rl/darkgray)))
|
|
||||||
|
|
||||||
;; The C's line, kept exactly — seconds, labelled ms.
|
|
||||||
(let [x 10]
|
|
||||||
(rl/draw-text "Frame time: " x 30 20 rl/darkgray)
|
|
||||||
(set x (+ x (rl/measure-text "Frame time: " 20)))
|
|
||||||
(set x (+ x (d/draw-f32 (rl/get-frame-time) 2 x 30 20 rl/darkgray)))
|
|
||||||
(rl/draw-text " ms" x 30 20 rl/darkgray))
|
|
||||||
;; And the same number in the unit the label claims, so the file does not
|
|
||||||
;; have to be read to notice.
|
|
||||||
(let [x 10]
|
|
||||||
(rl/draw-text "(really " x 50 20 rl/lightgray)
|
|
||||||
(set x (+ x (rl/measure-text "(really " 20)))
|
|
||||||
(set x (+ x (d/draw-f32 (* (rl/get-frame-time) 1000.0) 2 x 50 20
|
|
||||||
rl/lightgray)))
|
|
||||||
(rl/draw-text " ms)" x 50 20 rl/lightgray))
|
|
||||||
|
|
||||||
(rl/draw-text "Use the scroll wheel to change the fps limit, r to reset"
|
|
||||||
10 70 20 rl/darkgray)
|
|
||||||
|
|
||||||
(rl/draw-text "FUNC: x += GetFrameTime()*speed" 10 110 20 rl/red)
|
|
||||||
(rl/draw-text "FUNC: x += speed" 10 260 20 rl/blue))))
|
|
||||||
@@ -0,0 +1,107 @@
|
|||||||
|
;;;; raylib [core] example - delta time
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_delta_time.c. Needed get-mouse-wheel-move and get-fps,
|
||||||
|
;;;; both now bound — draw-fps was already there, but it puts the number on the
|
||||||
|
;;;; screen itself and this example wants to compare it against the target it
|
||||||
|
;;;; set, so it needs the number back.
|
||||||
|
;;;;
|
||||||
|
;;;; Three TextFormats in the C. Two of the three are a fixed number of
|
||||||
|
;;;; decimal places, which `f64->bytes` cannot do — it is "%g" — so they
|
||||||
|
;;;; still go through examples/digits.fln. The integer one does too, only
|
||||||
|
;;;; because its width is needed to put the next piece after it; the draw
|
||||||
|
;;;; itself is now (string (i64->bytes n)) and one draw-text.
|
||||||
|
;;;;
|
||||||
|
;;;; One faithfulness note that is a bug in the C and is kept anyway: it draws
|
||||||
|
;;;; `TextFormat("Frame time: %02.02f ms", GetFrameTime())` — GetFrameTime is
|
||||||
|
;;;; in SECONDS, so at 60 fps the C's own screen reads "0.02 ms" for what is
|
||||||
|
;;;; really 16.7 ms. Porting it as-is means the two programs show the same
|
||||||
|
;;;; thing, which is what a port is for; the milliseconds are drawn beside it
|
||||||
|
;;;; here rather than instead of it, so the file is not quietly asserting that
|
||||||
|
;;;; the original was right.
|
||||||
|
;;;;
|
||||||
|
;;;; The two circle positions are `once`s for the usual reason: they are
|
||||||
|
;;;; state between frames and a `let` inside the loop would reset them.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
import d "digits.fln"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
const speed: f32 = 10.0
|
||||||
|
const circle-radius: f32 = 32.0
|
||||||
|
|
||||||
|
once delta-circle: rl/Vector2
|
||||||
|
once frame-circle: rl/Vector2
|
||||||
|
once current-fps: i32
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - delta time")
|
||||||
|
defer rl/close-window()
|
||||||
|
current-fps = 60
|
||||||
|
delta-circle = rl/Vector2{.x 0.0, .y f32(screen-height) / 3.0}
|
||||||
|
frame-circle = rl/Vector2{.x 0.0, .y f32(screen-height) * (2.0 / 3.0)}
|
||||||
|
rl/set-target-fps(current-fps)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update
|
||||||
|
let wheel = rl/get-mouse-wheel-move()
|
||||||
|
unless(wheel == 0.0):
|
||||||
|
current-fps += i32(wheel)
|
||||||
|
if current-fps < 0
|
||||||
|
current-fps = 0
|
||||||
|
rl/set-target-fps(current-fps)
|
||||||
|
;; The whole point of the example: one circle is scaled by the frame time
|
||||||
|
;; and one is not, so lowering the target with the wheel makes the second
|
||||||
|
;; one crawl while the first keeps its speed.
|
||||||
|
delta-circle.x += rl/get-frame-time() * (6.0 * speed)
|
||||||
|
frame-circle.x += 0.1 * speed
|
||||||
|
if delta-circle.x > f32(screen-width)
|
||||||
|
delta-circle.x = 0.0
|
||||||
|
if frame-circle.x > f32(screen-width)
|
||||||
|
frame-circle.x = 0.0
|
||||||
|
if rl/is-key-pressed(:key-r)
|
||||||
|
delta-circle.x = 0.0
|
||||||
|
frame-circle.x = 0.0
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/draw-circle-v(delta-circle, circle-radius, rl/red)
|
||||||
|
rl/draw-circle-v(frame-circle, circle-radius, rl/blue)
|
||||||
|
;; "FPS: unlimited (%i)" when the target is 0, "FPS: %i (target: %i)"
|
||||||
|
;; otherwise — the C's own branch, reassembled out of literals and
|
||||||
|
;; draw-int. `x` walks along the line as each piece is drawn, which is what
|
||||||
|
;; the returned width from draw-int is for.
|
||||||
|
if current-fps <= 0
|
||||||
|
let x = 10
|
||||||
|
rl/draw-text("FPS: unlimited (", x, 10, 20, rl/darkgray)
|
||||||
|
x += rl/measure-text("FPS: unlimited (", 20)
|
||||||
|
x += d/draw-int(rl/get-fps(), x, 10, 20, rl/darkgray)
|
||||||
|
rl/draw-text(")", x, 10, 20, rl/darkgray)
|
||||||
|
else
|
||||||
|
let x = 10
|
||||||
|
rl/draw-text("FPS: ", x, 10, 20, rl/darkgray)
|
||||||
|
x += rl/measure-text("FPS: ", 20)
|
||||||
|
x += d/draw-int(rl/get-fps(), x, 10, 20, rl/darkgray)
|
||||||
|
rl/draw-text(" (target: ", x, 10, 20, rl/darkgray)
|
||||||
|
x += rl/measure-text(" (target: ", 20)
|
||||||
|
x += d/draw-int(current-fps, x, 10, 20, rl/darkgray)
|
||||||
|
rl/draw-text(")", x, 10, 20, rl/darkgray)
|
||||||
|
;; The C's line, kept exactly — seconds, labelled ms.
|
||||||
|
let x = 10
|
||||||
|
rl/draw-text("Frame time: ", x, 30, 20, rl/darkgray)
|
||||||
|
x += rl/measure-text("Frame time: ", 20)
|
||||||
|
x += d/draw-f32(rl/get-frame-time(), 2, x, 30, 20, rl/darkgray)
|
||||||
|
rl/draw-text(" ms", x, 30, 20, rl/darkgray)
|
||||||
|
;; And the same number in the unit the label claims, so the file does not
|
||||||
|
;; have to be read to notice.
|
||||||
|
let x = 10
|
||||||
|
rl/draw-text("(really ", x, 50, 20, rl/lightgray)
|
||||||
|
x += rl/measure-text("(really ", 20)
|
||||||
|
x += d/draw-f32(rl/get-frame-time() * 1000.0, 2, x, 50, 20, rl/lightgray)
|
||||||
|
rl/draw-text(" ms)", x, 50, 20, rl/lightgray)
|
||||||
|
rl/draw-text("Use the scroll wheel to change the fps limit, r to reset",
|
||||||
|
10, 70, 20, rl/darkgray)
|
||||||
|
rl/draw-text("FUNC: x += GetFrameTime()*speed", 10, 110, 20, rl/red)
|
||||||
|
rl/draw-text("FUNC: x += speed", 10, 260, 20, rl/blue)
|
||||||
@@ -1,278 +0,0 @@
|
|||||||
;;;; raylib [core] example - input gamepad
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_input_gamepad.c. Needed set-config-flags (and the
|
|
||||||
;;;; FLAG_ constants), both now bound.
|
|
||||||
;;;;
|
|
||||||
;;;; Three deliberate differences from the C, all of them things the port
|
|
||||||
;;;; could not or should not follow.
|
|
||||||
;;;;
|
|
||||||
;;;; **The pad artwork is gone, and with it the xbox/PS branches.** The C draws
|
|
||||||
;;;; `resources/ps3.png` or `resources/xbox.png` and picks between them by
|
|
||||||
;;;; matching `GetGamepadName` against four substrings. Neither image is in
|
|
||||||
;;;; this repository, and importing two binaries for one example is worse than
|
|
||||||
;;;; the alternative: the C has a third branch, for a pad it does not
|
|
||||||
;;;; recognise, which draws the whole thing out of rounded rectangles and
|
|
||||||
;;;; circles and needs no asset at all. That branch is what this ports, in
|
|
||||||
;;;; full. It is also the branch a Linux desktop usually takes anyway.
|
|
||||||
;;;;
|
|
||||||
;;;; **GetGamepadName is not bound, and cannot be.** It is what the C matches
|
|
||||||
;;;; on, and declare-c refuses it by name:
|
|
||||||
;;;;
|
|
||||||
;;;; the return type of get-gamepad-name is a string, and a string only
|
|
||||||
;;;; crosses as a parameter — a C function that *returns* one returns
|
|
||||||
;;;; something Flan has no owner for
|
|
||||||
;;;;
|
|
||||||
;;;; which is correct: raylib hands back a pointer into its own static storage
|
|
||||||
;;;; and Flan has nothing that owns a borrowed C string. So the pad's name is
|
|
||||||
;;;; not on screen and the branch that used it is not here.
|
|
||||||
;;;;
|
|
||||||
;;;; **The VIBRATE button is drawn and inert.** SetGamepadVibration is the one
|
|
||||||
;;;; call in the C this refuses to bind, and vendor/raylib/raylib.flan already
|
|
||||||
;;;; carries the paragraph saying why: its arity differs between raylib
|
|
||||||
;;;; versions with no 5.5 header here to settle it, so a guess is a corrupted
|
|
||||||
;;;; stack frame rather than a link error — and the symbol in libraylib.so.550
|
|
||||||
;;;; disassembles to a single TraceLog call and a jump. Binding it would be
|
|
||||||
;;;; binding a warning. The button is drawn because taking it out would hide
|
|
||||||
;;;; the finding; it is labelled so.
|
|
||||||
;;;;
|
|
||||||
;;;; With no pad attached this shows "GP0: NOT DETECTED" and nothing else,
|
|
||||||
;;;; which is the C's behaviour minus the greyed-out artwork.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
(import d "digits.flan")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defconst stick-deadzone f32 0.1)
|
|
||||||
(defconst trigger-deadzone f32 -0.9)
|
|
||||||
|
|
||||||
(defvar gamepad i32)
|
|
||||||
|
|
||||||
;; The C's deadzone test, which is a band around zero and not a clamp: inside
|
|
||||||
;; it the axis reads exactly 0, outside it the raw value passes through
|
|
||||||
;; unscaled. That is a step at the edge of the band and the C has it too.
|
|
||||||
(defn deadzone [v f32 limit f32] f32
|
|
||||||
(if (and (> v (- 0.0 limit)) (< v limit)) 0.0 v))
|
|
||||||
|
|
||||||
;; The triggers rest at -1 rather than 0, which raylib does not normalise —
|
|
||||||
;; see the note on GamepadAxis in vendor/raylib/raylib.flan. So their deadzone
|
|
||||||
;; is a floor near the resting end and not a band around the middle.
|
|
||||||
(defn trigger-deadzoned [v f32] f32
|
|
||||||
(if (< v trigger-deadzone) -1.0 v))
|
|
||||||
|
|
||||||
;; The C's read-out loop is `for (i = 0; i < GetGamepadAxisCount(gamepad); i++)
|
|
||||||
;; DrawText(TextFormat("AXIS %i: %.02f", i, GetGamepadAxisMovement(gamepad, i)))`
|
|
||||||
;; — an axis selected by a loop variable, which is what this is: an integer
|
|
||||||
;; converts to an enum when the conversion is written by name.
|
|
||||||
;;
|
|
||||||
;; It used to be a six-armed cond over the members, because an enum is its own
|
|
||||||
;; type in the checker and a bare i32 does not fit one:
|
|
||||||
;;
|
|
||||||
;; expected rl/GamepadAxis, found i32
|
|
||||||
;;
|
|
||||||
;; That rule is unchanged and should be. It is what makes a misspelled
|
|
||||||
;; `:lft-x` an error *here*, at the call site, rather than a wrong axis read
|
|
||||||
;; later — which is the whole reason an enum is a type at all rather than a
|
|
||||||
;; pile of i32 constants. What changed is that the conversion can be said out
|
|
||||||
;; loud: the rule was never "an integer is dangerous", it was "an integer must
|
|
||||||
;; not arrive silently", and (rl/GamepadAxis index) is not silent.
|
|
||||||
;;
|
|
||||||
;; (The other escape stays closed, and should: a second declare-c of
|
|
||||||
;; GetGamepadAxisMovement with an i32 face is still refused — one declare-c
|
|
||||||
;; per C function — and a defn wrapper still cannot retype a parameter. It is
|
|
||||||
;; no longer needed.)
|
|
||||||
;;
|
|
||||||
;; An index raylib does not name converts too, rather than being refused, and
|
|
||||||
;; raylib bounds-checks its own axis and answers 0.0. So the (min 6 ...) clamp
|
|
||||||
;; at the call site is what keeps the read-out to the six axes raylib names —
|
|
||||||
;; load-bearing now rather than cosmetic, since it replaced the :else arm.
|
|
||||||
(defn axis-at [pad i32 index i32] f32
|
|
||||||
(rl/get-gamepad-axis-movement pad (rl/GamepadAxis index)))
|
|
||||||
|
|
||||||
(defn draw-pad-background [] ()
|
|
||||||
(rl/draw-rectangle-rounded
|
|
||||||
(rl/Rectangle {.x 175.0 .y 110.0 .width 460.0 .height 220.0})
|
|
||||||
0.3 16 rl/darkgray)
|
|
||||||
|
|
||||||
;; The three middle buttons and the four face buttons, as outlines. The
|
|
||||||
;; filled overlays go on top only while the button is down.
|
|
||||||
(rl/draw-circle 365 170 12.0 rl/raywhite)
|
|
||||||
(rl/draw-circle 405 170 12.0 rl/raywhite)
|
|
||||||
(rl/draw-circle 445 170 12.0 rl/raywhite)
|
|
||||||
(rl/draw-circle 516 191 17.0 rl/raywhite)
|
|
||||||
(rl/draw-circle 551 227 17.0 rl/raywhite)
|
|
||||||
(rl/draw-circle 587 191 17.0 rl/raywhite)
|
|
||||||
(rl/draw-circle 551 155 17.0 rl/raywhite)
|
|
||||||
|
|
||||||
;; The d-pad cross: a light plate with a dark one inset, so a pressed
|
|
||||||
;; direction has something to show up against.
|
|
||||||
(rl/draw-rectangle 245 145 28 88 rl/raywhite)
|
|
||||||
(rl/draw-rectangle 215 174 88 29 rl/raywhite)
|
|
||||||
(rl/draw-rectangle 247 147 24 84 rl/black)
|
|
||||||
(rl/draw-rectangle 217 176 84 25 rl/black)
|
|
||||||
|
|
||||||
(rl/draw-rectangle-rounded
|
|
||||||
(rl/Rectangle {.x 215.0 .y 98.0 .width 100.0 .height 10.0})
|
|
||||||
0.5 16 rl/darkgray)
|
|
||||||
(rl/draw-rectangle-rounded
|
|
||||||
(rl/Rectangle {.x 495.0 .y 98.0 .width 100.0 .height 10.0})
|
|
||||||
0.5 16 rl/darkgray))
|
|
||||||
|
|
||||||
(defn draw-pad-buttons [] ()
|
|
||||||
(when (rl/gamepad-button-down? gamepad :middle-left)
|
|
||||||
(rl/draw-circle 365 170 10.0 rl/red))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :middle)
|
|
||||||
(rl/draw-circle 405 170 10.0 rl/green))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :middle-right)
|
|
||||||
(rl/draw-circle 445 170 10.0 rl/blue))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :right-face-left)
|
|
||||||
(rl/draw-circle 516 191 15.0 rl/gold))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :right-face-down)
|
|
||||||
(rl/draw-circle 551 227 15.0 rl/blue))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :right-face-right)
|
|
||||||
(rl/draw-circle 587 191 15.0 rl/green))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :right-face-up)
|
|
||||||
(rl/draw-circle 551 155 15.0 rl/red))
|
|
||||||
|
|
||||||
(when (rl/gamepad-button-down? gamepad :left-face-up)
|
|
||||||
(rl/draw-rectangle 247 147 24 29 rl/red))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :left-face-down)
|
|
||||||
(rl/draw-rectangle 247 201 24 30 rl/red))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :left-face-left)
|
|
||||||
(rl/draw-rectangle 217 176 30 25 rl/red))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :left-face-right)
|
|
||||||
(rl/draw-rectangle 271 176 30 25 rl/red))
|
|
||||||
|
|
||||||
(when (rl/gamepad-button-down? gamepad :left-trigger-1)
|
|
||||||
(rl/draw-rectangle-rounded
|
|
||||||
(rl/Rectangle {.x 215.0 .y 98.0 .width 100.0 .height 10.0})
|
|
||||||
0.5 16 rl/red))
|
|
||||||
(when (rl/gamepad-button-down? gamepad :right-trigger-1)
|
|
||||||
(rl/draw-rectangle-rounded
|
|
||||||
(rl/Rectangle {.x 495.0 .y 98.0 .width 100.0 .height 10.0})
|
|
||||||
0.5 16 rl/red)))
|
|
||||||
|
|
||||||
(defn draw-stick [cx i32 cy i32 ax f32 ay f32 thumb-down bool] ()
|
|
||||||
(rl/draw-circle cx cy 40.0 rl/black)
|
|
||||||
(rl/draw-circle cx cy 35.0 rl/lightgray)
|
|
||||||
(rl/draw-circle (+ cx (i32 (* ax 20.0))) (+ cy (i32 (* ay 20.0))) 25.0
|
|
||||||
(if thumb-down rl/red rl/black)))
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
;; Before init-window, and it has to be: raylib reads the flags while it is
|
|
||||||
;; creating the context, so the same call afterwards is accepted, logged, and
|
|
||||||
;; has no effect on the window that already exists.
|
|
||||||
(rl/set-config-flags rl/flag-msaa-4x-hint)
|
|
||||||
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - input gamepad")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
|
||||||
(when (and (rl/key-pressed? :left) (> gamepad 0))
|
|
||||||
(set gamepad (- gamepad 1)))
|
|
||||||
(when (rl/key-pressed? :right) (set gamepad (+ gamepad 1)))
|
|
||||||
|
|
||||||
(let [axis-count (min 6 (rl/get-gamepad-axis-count gamepad))
|
|
||||||
vibrate-rect (rl/Rectangle {.x 10.0
|
|
||||||
.y (+ 90.0 (* 20.0 (f32 axis-count)))
|
|
||||||
.width 75.0 .height 24.0})]
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(if (rl/gamepad-available? gamepad)
|
|
||||||
(do
|
|
||||||
;; The C draws `TextFormat("GP%d: %s", gamepad, GetGamepadName(...))`.
|
|
||||||
;; The name is unbindable — see the header — so this is the index and
|
|
||||||
;; the word the C would have followed it with.
|
|
||||||
(rl/draw-text "GP" 10 10 10 rl/black)
|
|
||||||
(let [x (+ 10 (rl/measure-text "GP" 10))]
|
|
||||||
(rl/draw-text ": CONNECTED (name unbindable)"
|
|
||||||
(+ x (d/draw-int gamepad x 10 10 rl/black))
|
|
||||||
10 10 rl/black))
|
|
||||||
|
|
||||||
(let [lx (deadzone (rl/get-gamepad-axis-movement gamepad :left-x)
|
|
||||||
stick-deadzone)
|
|
||||||
ly (deadzone (rl/get-gamepad-axis-movement gamepad :left-y)
|
|
||||||
stick-deadzone)
|
|
||||||
rx (deadzone (rl/get-gamepad-axis-movement gamepad :right-x)
|
|
||||||
stick-deadzone)
|
|
||||||
ry (deadzone (rl/get-gamepad-axis-movement gamepad :right-y)
|
|
||||||
stick-deadzone)
|
|
||||||
lt (trigger-deadzoned
|
|
||||||
(rl/get-gamepad-axis-movement gamepad :left-trigger))
|
|
||||||
rt (trigger-deadzoned
|
|
||||||
(rl/get-gamepad-axis-movement gamepad :right-trigger))]
|
|
||||||
|
|
||||||
(draw-pad-background)
|
|
||||||
(draw-pad-buttons)
|
|
||||||
|
|
||||||
(draw-stick 345 260 lx ly
|
|
||||||
(rl/gamepad-button-down? gamepad :left-thumb))
|
|
||||||
(draw-stick 465 260 rx ry
|
|
||||||
(rl/gamepad-button-down? gamepad :right-thumb))
|
|
||||||
|
|
||||||
;; The triggers as bars filling upward from a grey track. The +1
|
|
||||||
;; and the halving turn raylib's [-1, 1] into [0, 1].
|
|
||||||
(rl/draw-rectangle 151 110 15 70 rl/gray)
|
|
||||||
(rl/draw-rectangle 644 110 15 70 rl/gray)
|
|
||||||
(rl/draw-rectangle 151 110 15 (i32 (* (/ (+ 1.0 lt) 2.0) 70.0))
|
|
||||||
rl/red)
|
|
||||||
(rl/draw-rectangle 644 110 15 (i32 (* (/ (+ 1.0 rt) 2.0) 70.0))
|
|
||||||
rl/red))
|
|
||||||
|
|
||||||
(rl/draw-text "DETECTED AXIS [" 10 50 10 rl/maroon)
|
|
||||||
(let [x (+ 10 (rl/measure-text "DETECTED AXIS [" 10))]
|
|
||||||
(rl/draw-text "]:" (+ x (d/draw-int axis-count x 50 10 rl/maroon))
|
|
||||||
50 10 rl/maroon))
|
|
||||||
|
|
||||||
(dotimes [i axis-count]
|
|
||||||
(rl/draw-text "AXIS " 20 (+ 70 (* 20 i)) 10 rl/darkgray)
|
|
||||||
(let [x (+ 20 (rl/measure-text "AXIS " 10))
|
|
||||||
y (+ 70 (* 20 i))]
|
|
||||||
(set x (+ x (d/draw-int i x y 10 rl/darkgray)))
|
|
||||||
(rl/draw-text ": " x y 10 rl/darkgray)
|
|
||||||
(set x (+ x (rl/measure-text ": " 10)))
|
|
||||||
;; The raw reading, not the deadzoned one — the C shows the raw
|
|
||||||
;; value here too, which is what makes the deadzone visible as a
|
|
||||||
;; difference between this row and the stick.
|
|
||||||
(d/draw-f32 (axis-at gamepad i) 2 x y 10
|
|
||||||
rl/darkgray)))
|
|
||||||
|
|
||||||
;; Drawn and inert. See the header: SetGamepadVibration is a stub in
|
|
||||||
;; this raylib and is not bound.
|
|
||||||
(rl/draw-rectangle-rec vibrate-rect rl/skyblue)
|
|
||||||
(rl/draw-text "VIBRATE" (+ (i32 (.x vibrate-rect)) 14)
|
|
||||||
(+ (i32 (.y vibrate-rect)) 1) 10 rl/darkgray)
|
|
||||||
(rl/draw-text "(not bound: raylib stub)" 95
|
|
||||||
(+ (i32 (.y vibrate-rect)) 7) 10 rl/gray)
|
|
||||||
|
|
||||||
;; -1 when nothing is pressed, which is why the binding answers an
|
|
||||||
;; i32 and not a GamepadButton.
|
|
||||||
;; draw-int answers the width it drew, so a branch that ends in one
|
|
||||||
;; has type i32 while its sibling has type () and the `if` will not
|
|
||||||
;; typecheck — "expected i32, found ()". Both arms end in a
|
|
||||||
;; draw-text here, which is the tidy way out; where that is awkward a
|
|
||||||
;; trailing `(do)` is the other.
|
|
||||||
(let [b (rl/get-gamepad-button-pressed)]
|
|
||||||
(if (>= b 0)
|
|
||||||
(do (rl/draw-text "DETECTED BUTTON: " 10 430 10 rl/red)
|
|
||||||
(d/draw-int b (+ 10 (rl/measure-text "DETECTED BUTTON: " 10))
|
|
||||||
430 10 rl/red)
|
|
||||||
(do))
|
|
||||||
(rl/draw-text "DETECTED BUTTON: NONE" 10 430 10 rl/gray))))
|
|
||||||
|
|
||||||
(do
|
|
||||||
(rl/draw-text "GP" 10 10 10 rl/gray)
|
|
||||||
(let [x (+ 10 (rl/measure-text "GP" 10))]
|
|
||||||
(rl/draw-text ": NOT DETECTED"
|
|
||||||
(+ x (d/draw-int gamepad x 10 10 rl/gray))
|
|
||||||
10 10 rl/gray))
|
|
||||||
(rl/draw-text "left/right arrows select another pad" 10 30 10
|
|
||||||
rl/lightgray)))))))
|
|
||||||
@@ -0,0 +1,244 @@
|
|||||||
|
;;;; raylib [core] example - input gamepad
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_input_gamepad.c. Needed set-config-flags (and the
|
||||||
|
;;;; FLAG_ constants), both now bound.
|
||||||
|
;;;;
|
||||||
|
;;;; Three deliberate differences from the C, all of them things the port
|
||||||
|
;;;; could not or should not follow.
|
||||||
|
;;;;
|
||||||
|
;;;; **The pad artwork is gone, and with it the xbox/PS branches.** The C draws
|
||||||
|
;;;; `resources/ps3.png` or `resources/xbox.png` and picks between them by
|
||||||
|
;;;; matching `GetGamepadName` against four substrings. Neither image is in
|
||||||
|
;;;; this repository, and importing two binaries for one example is worse than
|
||||||
|
;;;; the alternative: the C has a third branch, for a pad it does not
|
||||||
|
;;;; recognise, which draws the whole thing out of rounded rectangles and
|
||||||
|
;;;; circles and needs no asset at all. That branch is what this ports, in
|
||||||
|
;;;; full. It is also the branch a Linux desktop usually takes anyway.
|
||||||
|
;;;;
|
||||||
|
;;;; **The name is drawn and not matched on.** get-gamepad-name copies
|
||||||
|
;;;; raylib's static text into the context allocator, which this program never
|
||||||
|
;;;; frees — so the name is read once per frame into the frame arena, and the
|
||||||
|
;;;; branches that matched on it are the artwork's and are gone with it.
|
||||||
|
;;;;
|
||||||
|
;;;; **The VIBRATE button is drawn and inert.** SetGamepadVibration is the one
|
||||||
|
;;;; call in the C this refuses to bind, and vendor/raylib/raylib.fln already
|
||||||
|
;;;; carries the paragraph saying why: its arity differs between raylib
|
||||||
|
;;;; versions with no 5.5 header here to settle it, so a guess is a corrupted
|
||||||
|
;;;; stack frame rather than a link error — and the symbol in libraylib.so.550
|
||||||
|
;;;; disassembles to a single TraceLog call and a jump. Binding it would be
|
||||||
|
;;;; binding a warning. The button is drawn because taking it out would hide
|
||||||
|
;;;; the finding; it is labelled so.
|
||||||
|
;;;;
|
||||||
|
;;;; With no pad attached this shows "GP0: NOT DETECTED" and nothing else,
|
||||||
|
;;;; which is the C's behaviour minus the greyed-out artwork.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
import d "digits.fln"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
const stick-deadzone: f32 = 0.1
|
||||||
|
const trigger-deadzone: f32 = -0.9
|
||||||
|
|
||||||
|
once gamepad: i32
|
||||||
|
|
||||||
|
;; The C's deadzone test, which is a band around zero and not a clamp: inside
|
||||||
|
;; it the axis reads exactly 0, outside it the raw value passes through
|
||||||
|
;; unscaled. That is a step at the edge of the band and the C has it too.
|
||||||
|
fn deadzone(v: f32, limit: f32) -> f32
|
||||||
|
if v > 0.0 - limit and v < limit then 0.0 else v
|
||||||
|
|
||||||
|
;; The triggers rest at -1 rather than 0, which raylib does not normalise —
|
||||||
|
;; see the note on GamepadAxis in vendor/raylib/raylib.fln. So their deadzone
|
||||||
|
;; is a floor near the resting end and not a band around the middle.
|
||||||
|
fn trigger-deadzoned(v: f32) -> f32
|
||||||
|
if v < trigger-deadzone then -1.0 else v
|
||||||
|
|
||||||
|
;; The C's read-out loop is `for (i = 0; i < GetGamepadAxisCount(gamepad); i++)
|
||||||
|
;; DrawText(TextFormat("AXIS %i: %.02f", i, GetGamepadAxisMovement(gamepad, i)))`
|
||||||
|
;; — an axis selected by a loop variable, which is what this is: an integer
|
||||||
|
;; converts to an enum when the conversion is written by name.
|
||||||
|
;;
|
||||||
|
;; It used to be a six-armed cond over the members, because an enum is its own
|
||||||
|
;; type in the checker and a bare i32 does not fit one:
|
||||||
|
;;
|
||||||
|
;; expected rl/GamepadAxis, found i32
|
||||||
|
;;
|
||||||
|
;; That rule is unchanged and should be. It is what makes a misspelled
|
||||||
|
;; `:lft-x` an error *here*, at the call site, rather than a wrong axis read
|
||||||
|
;; later — which is the whole reason an enum is a type at all rather than a
|
||||||
|
;; pile of i32 constants. What changed is that the conversion can be said out
|
||||||
|
;; loud: the rule was never "an integer is dangerous", it was "an integer must
|
||||||
|
;; not arrive silently", and (rl/GamepadAxis index) is not silent.
|
||||||
|
;;
|
||||||
|
;; (The other escape stays closed, and should: a second declare-c of
|
||||||
|
;; GetGamepadAxisMovement with an i32 face is still refused — one declare-c
|
||||||
|
;; per C function — and a defn wrapper still cannot retype a parameter. It is
|
||||||
|
;; no longer needed.)
|
||||||
|
;;
|
||||||
|
;; An index raylib does not name converts too, rather than being refused, and
|
||||||
|
;; raylib bounds-checks its own axis and answers 0.0. So the (min 6 ...) clamp
|
||||||
|
;; at the call site is what keeps the read-out to the six axes raylib names —
|
||||||
|
;; load-bearing now rather than cosmetic, since it replaced the :else arm.
|
||||||
|
fn axis-at(pad: i32, index: i32) -> f32
|
||||||
|
rl/get-gamepad-axis-movement(pad, rl/GamepadAxis(index))
|
||||||
|
|
||||||
|
fn draw-pad-background() -> ()
|
||||||
|
rl/draw-rectangle-rounded(rl/Rectangle{.x 175.0 .y 110.0 .width 460.0 .height 220.0},
|
||||||
|
0.3, 16, rl/darkgray)
|
||||||
|
;; The three middle buttons and the four face buttons, as outlines. The
|
||||||
|
;; filled overlays go on top only while the button is down.
|
||||||
|
rl/draw-circle(365, 170, 12.0, rl/raywhite)
|
||||||
|
rl/draw-circle(405, 170, 12.0, rl/raywhite)
|
||||||
|
rl/draw-circle(445, 170, 12.0, rl/raywhite)
|
||||||
|
rl/draw-circle(516, 191, 17.0, rl/raywhite)
|
||||||
|
rl/draw-circle(551, 227, 17.0, rl/raywhite)
|
||||||
|
rl/draw-circle(587, 191, 17.0, rl/raywhite)
|
||||||
|
rl/draw-circle(551, 155, 17.0, rl/raywhite)
|
||||||
|
;; The d-pad cross: a light plate with a dark one inset, so a pressed
|
||||||
|
;; direction has something to show up against.
|
||||||
|
rl/draw-rectangle(245, 145, 28, 88, rl/raywhite)
|
||||||
|
rl/draw-rectangle(215, 174, 88, 29, rl/raywhite)
|
||||||
|
rl/draw-rectangle(247, 147, 24, 84, rl/black)
|
||||||
|
rl/draw-rectangle(217, 176, 84, 25, rl/black)
|
||||||
|
rl/draw-rectangle-rounded(rl/Rectangle{.x 215.0 .y 98.0 .width 100.0 .height 10.0},
|
||||||
|
0.5, 16, rl/darkgray)
|
||||||
|
rl/draw-rectangle-rounded(rl/Rectangle{.x 495.0 .y 98.0 .width 100.0 .height 10.0},
|
||||||
|
0.5, 16, rl/darkgray)
|
||||||
|
|
||||||
|
fn draw-pad-buttons() -> ()
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-middle-left)
|
||||||
|
rl/draw-circle(365, 170, 10.0, rl/red)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-middle)
|
||||||
|
rl/draw-circle(405, 170, 10.0, rl/green)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-middle-right)
|
||||||
|
rl/draw-circle(445, 170, 10.0, rl/blue)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-right-face-left)
|
||||||
|
rl/draw-circle(516, 191, 15.0, rl/gold)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-right-face-down)
|
||||||
|
rl/draw-circle(551, 227, 15.0, rl/blue)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-right-face-right)
|
||||||
|
rl/draw-circle(587, 191, 15.0, rl/green)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-right-face-up)
|
||||||
|
rl/draw-circle(551, 155, 15.0, rl/red)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-left-face-up)
|
||||||
|
rl/draw-rectangle(247, 147, 24, 29, rl/red)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-left-face-down)
|
||||||
|
rl/draw-rectangle(247, 201, 24, 30, rl/red)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-left-face-left)
|
||||||
|
rl/draw-rectangle(217, 176, 30, 25, rl/red)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-left-face-right)
|
||||||
|
rl/draw-rectangle(271, 176, 30, 25, rl/red)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-left-trigger-1)
|
||||||
|
rl/draw-rectangle-rounded(rl/Rectangle{.x 215.0 .y 98.0 .width 100.0 .height 10.0},
|
||||||
|
0.5, 16, rl/red)
|
||||||
|
if rl/is-gamepad-button-down(gamepad, :button-right-trigger-1)
|
||||||
|
rl/draw-rectangle-rounded(rl/Rectangle{.x 495.0 .y 98.0 .width 100.0 .height 10.0},
|
||||||
|
0.5, 16, rl/red)
|
||||||
|
|
||||||
|
fn draw-stick(cx: i32, cy: i32, ax: f32, ay: f32, thumb-down: bool) -> ()
|
||||||
|
rl/draw-circle(cx, cy, 40.0, rl/black)
|
||||||
|
rl/draw-circle(cx, cy, 35.0, rl/lightgray)
|
||||||
|
rl/draw-circle(cx + i32(ax * 20.0), cy + i32(ay * 20.0), 25.0,
|
||||||
|
if thumb-down then rl/red else rl/black)
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
;; Before init-window, and it has to be: raylib reads the flags while it is
|
||||||
|
;; creating the context, so the same call afterwards is accepted, logged, and
|
||||||
|
;; has no effect on the window that already exists.
|
||||||
|
rl/set-config-flags(rl/flag-msaa-4x-hint)
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - input gamepad")
|
||||||
|
defer rl/close-window()
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; The frame arena holds the pad's name for one frame.
|
||||||
|
free-all(context/temp)
|
||||||
|
;; Update
|
||||||
|
if rl/is-key-pressed(:key-left) and gamepad > 0
|
||||||
|
gamepad -= 1
|
||||||
|
if rl/is-key-pressed(:key-right)
|
||||||
|
gamepad += 1
|
||||||
|
let axis-count = min(6, rl/get-gamepad-axis-count(gamepad))
|
||||||
|
let vibrate-rect = rl/Rectangle{.x 10.0, .y 90.0 + 20.0 * f32(axis-count), .width 75.0, .height 24.0}
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
if rl/is-gamepad-available(gamepad)
|
||||||
|
;; The C draws `TextFormat("GP%d: %s", gamepad, GetGamepadName(...))`.
|
||||||
|
;; TextFormat is variadic and unbound, so the pieces are drawn in turn.
|
||||||
|
rl/draw-text("GP", 10, 10, 10, rl/black)
|
||||||
|
let x = 10 + rl/measure-text("GP", 10)
|
||||||
|
let x = x + d/draw-int(gamepad, x, 10, 10, rl/black)
|
||||||
|
rl/draw-text(": ", x, 10, 10, rl/black)
|
||||||
|
rl/draw-text(with-allocator(context/temp, rl/get-gamepad-name(gamepad)),
|
||||||
|
x + rl/measure-text(": ", 10), 10, 10, rl/black)
|
||||||
|
let lx = deadzone(rl/get-gamepad-axis-movement(gamepad, :axis-left-x),
|
||||||
|
stick-deadzone)
|
||||||
|
let ly = deadzone(rl/get-gamepad-axis-movement(gamepad, :axis-left-y),
|
||||||
|
stick-deadzone)
|
||||||
|
let rx = deadzone(rl/get-gamepad-axis-movement(gamepad, :axis-right-x),
|
||||||
|
stick-deadzone)
|
||||||
|
let ry = deadzone(rl/get-gamepad-axis-movement(gamepad, :axis-right-y),
|
||||||
|
stick-deadzone)
|
||||||
|
let lt = trigger-deadzoned(rl/get-gamepad-axis-movement(gamepad, :axis-left-trigger))
|
||||||
|
let rt = trigger-deadzoned(rl/get-gamepad-axis-movement(gamepad, :axis-right-trigger))
|
||||||
|
draw-pad-background()
|
||||||
|
draw-pad-buttons()
|
||||||
|
draw-stick(345, 260, lx, ly,
|
||||||
|
rl/is-gamepad-button-down(gamepad, :button-left-thumb))
|
||||||
|
draw-stick(465, 260, rx, ry,
|
||||||
|
rl/is-gamepad-button-down(gamepad, :button-right-thumb))
|
||||||
|
;; The triggers as bars filling upward from a grey track. The +1
|
||||||
|
;; and the halving turn raylib's [-1, 1] into [0, 1].
|
||||||
|
rl/draw-rectangle(151, 110, 15, 70, rl/gray)
|
||||||
|
rl/draw-rectangle(644, 110, 15, 70, rl/gray)
|
||||||
|
rl/draw-rectangle(151, 110, 15, i32((1.0 + lt) / 2.0 * 70.0), rl/red)
|
||||||
|
rl/draw-rectangle(644, 110, 15, i32((1.0 + rt) / 2.0 * 70.0), rl/red)
|
||||||
|
rl/draw-text("DETECTED AXIS [", 10, 50, 10, rl/maroon)
|
||||||
|
let x = 10 + rl/measure-text("DETECTED AXIS [", 10)
|
||||||
|
rl/draw-text("]:", x + d/draw-int(axis-count, x, 50, 10, rl/maroon), 50,
|
||||||
|
10, rl/maroon)
|
||||||
|
for i in 0..axis-count
|
||||||
|
rl/draw-text("AXIS ", 20, 70 + 20 * i, 10, rl/darkgray)
|
||||||
|
let x = 20 + rl/measure-text("AXIS ", 10)
|
||||||
|
y = 70 + 20 * i
|
||||||
|
x += d/draw-int(i, x, y, 10, rl/darkgray)
|
||||||
|
rl/draw-text(": ", x, y, 10, rl/darkgray)
|
||||||
|
x += rl/measure-text(": ", 10)
|
||||||
|
;; The raw reading, not the deadzoned one — the C shows the raw
|
||||||
|
;; value here too, which is what makes the deadzone visible as a
|
||||||
|
;; difference between this row and the stick.
|
||||||
|
d/draw-f32(axis-at(gamepad, i), 2, x, y, 10, rl/darkgray)
|
||||||
|
;; Drawn and inert. See the header: SetGamepadVibration is a stub in
|
||||||
|
;; this raylib and is not bound.
|
||||||
|
rl/draw-rectangle-rec(vibrate-rect, rl/skyblue)
|
||||||
|
rl/draw-text("VIBRATE", i32(vibrate-rect.x) + 14,
|
||||||
|
i32(vibrate-rect.y) + 1, 10, rl/darkgray)
|
||||||
|
rl/draw-text("(not bound: raylib stub)", 95, i32(vibrate-rect.y) + 7,
|
||||||
|
10, rl/gray)
|
||||||
|
;; -1 when nothing is pressed, which is why the binding answers an
|
||||||
|
;; i32 and not a GamepadButton.
|
||||||
|
;; draw-int answers the width it drew, so a branch that ends in one
|
||||||
|
;; has type i32 while its sibling has type () and the `if` will not
|
||||||
|
;; typecheck — "expected i32, found ()". Both arms end in a
|
||||||
|
;; draw-text here, which is the tidy way out; where that is awkward a
|
||||||
|
;; trailing `()` is the other.
|
||||||
|
let b = rl/get-gamepad-button-pressed()
|
||||||
|
if b >= 0
|
||||||
|
rl/draw-text("DETECTED BUTTON: ", 10, 430, 10, rl/red)
|
||||||
|
d/draw-int(b, 10 + rl/measure-text("DETECTED BUTTON: ", 10), 430, 10,
|
||||||
|
rl/red)
|
||||||
|
()
|
||||||
|
else
|
||||||
|
rl/draw-text("DETECTED BUTTON: NONE", 10, 430, 10, rl/gray)
|
||||||
|
else
|
||||||
|
rl/draw-text("GP", 10, 10, 10, rl/gray)
|
||||||
|
let x = 10 + rl/measure-text("GP", 10)
|
||||||
|
rl/draw-text(": NOT DETECTED",
|
||||||
|
x + d/draw-int(gamepad, x, 10, 10, rl/gray), 10, 10,
|
||||||
|
rl/gray)
|
||||||
|
rl/draw-text("left/right arrows select another pad", 10, 30, 10,
|
||||||
|
rl/lightgray)
|
||||||
@@ -1,362 +0,0 @@
|
|||||||
;;;; raylib [core] example - input gestures testbed
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_input_gestures_testbed.c, the four-star one and the
|
|
||||||
;;;; hardest of the ten. It runs, and it is the example that pushed hardest on
|
|
||||||
;;;; the language. Four things it needed, in descending order of how much they
|
|
||||||
;;;; cost.
|
|
||||||
;;;;
|
|
||||||
;;;; **An enum converts to an integer, when you say so.** The C treats the
|
|
||||||
;;;; gesture as the raw bitfield it is and compares it with `<` and `>`:
|
|
||||||
;;;; `currentGesture > 255` picks out the two pinches, `> 15` the four swipes,
|
|
||||||
;;;; `!= 4` excludes hold, `< 3` admits tap and double-tap. `get-gesture-
|
|
||||||
;;;; detected` answers an `rl/Gesture`, and that used to end the discussion —
|
|
||||||
;;;;
|
|
||||||
;;;; i32 converts a number, found rl/Gesture
|
|
||||||
;;;;
|
|
||||||
;;;; — so the three range tests were spelled out as keyword equalities, one
|
|
||||||
;;;; arm per member. They are `(> (i32 g) 255)`, `(> (i32 g) 15)` and
|
|
||||||
;;;; `(< (i32 g) 3)` now, still behind the named predicates below, and the fix
|
|
||||||
;;;; is not brevity: the enumerated version was *wrong about the future*. A
|
|
||||||
;;;; gesture raylib adds later falls silently out of a list of four members,
|
|
||||||
;;;; where the C's `> 15` catches it. The range test is the honest reading of
|
|
||||||
;;;; a bitfield and now it is the one written.
|
|
||||||
;;;;
|
|
||||||
;;;; The rule the refusal came from is unchanged and worth keeping: an enum is
|
|
||||||
;;;; its own type in the checker, so `:tpa` is an error at the call site
|
|
||||||
;;;; instead of a number that is wrong later, and a bare integer still does not
|
|
||||||
;;;; fit an `rl/Gesture` parameter. `(i32 g)` does not weaken that — it is
|
|
||||||
;;;; named, and it is at the site. The rule was "an integer must not arrive
|
|
||||||
;;;; silently", not "an integer is dangerous".
|
|
||||||
;;;;
|
|
||||||
;;;; The `!= 4` stays a keyword comparison, `(not (= g :hold))`. That one was
|
|
||||||
;;;; never a range test; it is a single member, and the C's 4 is a magic
|
|
||||||
;;;; number the keyword reads better than.
|
|
||||||
;;;;
|
|
||||||
;;;; **No sin or cos.** The prelude has sqrt-f32 — one `declare` over libm,
|
|
||||||
;;;; with a comment explaining why it is not a builtin — and nothing else
|
|
||||||
;;;; transcendental. The protractor needs both, so they are two more `declare`
|
|
||||||
;;;; lines here, in the same shape. They link: libm is already on the line.
|
|
||||||
;;;;
|
|
||||||
;;;; **No string formatting.** A number can be made into a string now —
|
|
||||||
;;;; (string (i64->bytes n)) — but a *format* still cannot: f64->bytes is
|
|
||||||
;;;; "%g", with no way to ask for two decimal places. The C prints the angle
|
|
||||||
;;;; with `TextFormat("%f", ...)`, finds the decimal point with
|
|
||||||
;;;; `TextFindIndex` and cuts two digits past it with `TextSubtext`;
|
|
||||||
;;;; `draw-f32` in examples/digits.flan does the whole thing in one call, and
|
|
||||||
;;;; rounds rather than truncating — which is the one place this screen
|
|
||||||
;;;; differs from the C's by a digit.
|
|
||||||
;;;;
|
|
||||||
;;;; **No local fixed arrays.** The C declares `char gestureLog[20][12]` and
|
|
||||||
;;;; `Vector2 touchPosition[32]` inside main. A `let` binding takes no type
|
|
||||||
;;;; annotation, so a fixed array can only be a top-level `defvar` or a literal
|
|
||||||
;;;; with every element written out — thirty-two Vector2s, here. They are
|
|
||||||
;;;; `defvar`s, which is what the C's storage amounts to anyway.
|
|
||||||
;;;;
|
|
||||||
;;;; The log itself came out simpler than the C's: the names are compile-time
|
|
||||||
;;;; literals, so a slot holds a `string` and there is no TextCopy and no
|
|
||||||
;;;; twelve-byte truncation.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
(import d "digits.flan")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defconst pi f32 3.14159265)
|
|
||||||
|
|
||||||
(defconst gesture-log-size 20)
|
|
||||||
(defconst max-touch-count 32)
|
|
||||||
|
|
||||||
(defvar gesture-log [gesture-log-size string])
|
|
||||||
;; The C's inverted circular queue: the index counts DOWN and wraps at the top,
|
|
||||||
;; so the newest entry is always at gesture-log-index and the draw loop walks
|
|
||||||
;; forward from there. Starting at the size rather than at size-1 is the C's
|
|
||||||
;; too — the first write decrements before storing.
|
|
||||||
(defvar gesture-log-index i32)
|
|
||||||
(defvar previous-gesture rl/Gesture)
|
|
||||||
(defvar last-gesture rl/Gesture)
|
|
||||||
(defvar gesture-color rl/Color)
|
|
||||||
(defvar log-mode i32)
|
|
||||||
(defvar current-angle f32)
|
|
||||||
(defvar touch-positions [max-touch-count rl/Vector2])
|
|
||||||
|
|
||||||
;; ── The comparisons the C makes on the raw bitfield ─────────────────
|
|
||||||
;;
|
|
||||||
;; A gesture is a flag: 1, 2, 4, 8 … up to 512, so the ranges are the C's way
|
|
||||||
;; of asking which family a gesture belongs to. (i32 g) is what lets that be
|
|
||||||
;; written; they are named here rather than inline because a bare 255 at a
|
|
||||||
;; call site says nothing, and because a gesture raylib adds later lands in
|
|
||||||
;; the right family without this file being edited.
|
|
||||||
|
|
||||||
(defn pinch? [g rl/Gesture] bool ; the C's `> 255`
|
|
||||||
(> (i32 g) 255))
|
|
||||||
|
|
||||||
(defn swipe? [g rl/Gesture] bool ; the C's `> 15`
|
|
||||||
(> (i32 g) 15))
|
|
||||||
|
|
||||||
(defn tapish? [g rl/Gesture] bool ; the C's `< 3`
|
|
||||||
(< (i32 g) 3))
|
|
||||||
|
|
||||||
;; Two orderings these impose, both of them the C's as well. A pinch is above
|
|
||||||
;; 255 and therefore above 15, so swipe? has to be asked after the pinches
|
|
||||||
;; rather than before; and tapish? admits :none, which is 0, so it belongs
|
|
||||||
;; under a :none guard. The C's switch over single members hides both; a range
|
|
||||||
;; test cannot.
|
|
||||||
|
|
||||||
(defn gesture-name [g rl/Gesture] string
|
|
||||||
(cond
|
|
||||||
(= g :none) "None"
|
|
||||||
(= g :tap) "Tap"
|
|
||||||
(= g :double-tap) "Double Tap"
|
|
||||||
(= g :hold) "Hold"
|
|
||||||
(= g :drag) "Drag"
|
|
||||||
(= g :swipe-right) "Swipe Right"
|
|
||||||
(= g :swipe-left) "Swipe Left"
|
|
||||||
(= g :swipe-up) "Swipe Up"
|
|
||||||
(= g :swipe-down) "Swipe Down"
|
|
||||||
(= g :pinch-in) "Pinch In"
|
|
||||||
(= g :pinch-out) "Pinch Out"
|
|
||||||
:else "Unknown"))
|
|
||||||
|
|
||||||
(defn gesture-color-of [g rl/Gesture] rl/Color
|
|
||||||
(cond
|
|
||||||
(= g :tap) rl/blue
|
|
||||||
(= g :double-tap) rl/skyblue
|
|
||||||
(= g :drag) rl/lime
|
|
||||||
;; The two pinches are above 255 and so are above 15 as well: swipe? is a
|
|
||||||
;; range test and has to be asked after them, not before. The C gets this
|
|
||||||
;; for free by being a switch over single members.
|
|
||||||
(= g :pinch-in) rl/violet
|
|
||||||
(= g :pinch-out) rl/orange
|
|
||||||
(swipe? g) rl/red
|
|
||||||
:else rl/black))
|
|
||||||
|
|
||||||
;; ── The log ─────────────────────────────────────────────────────────
|
|
||||||
|
|
||||||
;; The C's four log modes, as a truth table rather than as nested ifs:
|
|
||||||
;; 0 shows repeated events
|
|
||||||
;; 1 hides repeated events
|
|
||||||
;; 2 shows repeated events but hides hold
|
|
||||||
;; 3 hides repeated events and hides hold
|
|
||||||
(defn should-log? [g rl/Gesture] bool
|
|
||||||
(cond
|
|
||||||
(= g :none) false
|
|
||||||
(= log-mode 3) (or (and (not (= g :hold)) (not (= g previous-gesture)))
|
|
||||||
(tapish? g))
|
|
||||||
(= log-mode 2) (not (= g :hold))
|
|
||||||
(= log-mode 1) (not (= g previous-gesture))
|
|
||||||
:else true))
|
|
||||||
|
|
||||||
(defn push-log [g rl/Gesture] ()
|
|
||||||
(set previous-gesture g)
|
|
||||||
(set gesture-color (gesture-color-of g))
|
|
||||||
(when (<= gesture-log-index 0) (set gesture-log-index gesture-log-size))
|
|
||||||
(set gesture-log-index (- gesture-log-index 1))
|
|
||||||
(set (at gesture-log gesture-log-index) (gesture-name g)))
|
|
||||||
|
|
||||||
;; ── Drawing ─────────────────────────────────────────────────────────
|
|
||||||
|
|
||||||
(defconst last-x 165)
|
|
||||||
(defconst last-y 130)
|
|
||||||
(defconst prot-x f32 266.0)
|
|
||||||
(defconst prot-y f32 315.0)
|
|
||||||
(defconst angle-length f32 90.0)
|
|
||||||
|
|
||||||
(defn swipe-box [gx i32 gy i32 which rl/Gesture] ()
|
|
||||||
(rl/draw-rectangle gx gy 20 20
|
|
||||||
(if (= last-gesture which) rl/red rl/lightgray)))
|
|
||||||
|
|
||||||
(defn draw-last-gesture [touch-count i32] ()
|
|
||||||
(rl/draw-text "Last gesture" (+ last-x 33) (- last-y 47) 20 rl/black)
|
|
||||||
(rl/draw-text "Swipe Tap Pinch Touch" (+ last-x 17)
|
|
||||||
(- last-y 18) 10 rl/black)
|
|
||||||
|
|
||||||
(swipe-box (+ last-x 20) last-y :swipe-up)
|
|
||||||
(swipe-box last-x (+ last-y 20) :swipe-left)
|
|
||||||
(swipe-box (+ last-x 40) (+ last-y 20) :swipe-right)
|
|
||||||
(swipe-box (+ last-x 20) (+ last-y 40) :swipe-down)
|
|
||||||
|
|
||||||
(rl/draw-circle (+ last-x 80) (+ last-y 16) 10.0
|
|
||||||
(if (= last-gesture :tap) rl/blue rl/lightgray))
|
|
||||||
;; segments 0 lets raylib pick the count from the radius.
|
|
||||||
(rl/draw-ring (rl/Vector2 {.x (f32 (+ last-x 103)) .y (f32 (+ last-y 16))})
|
|
||||||
6.0 11.0 0.0 360.0 0
|
|
||||||
(if (= last-gesture :drag) rl/lime rl/lightgray))
|
|
||||||
(rl/draw-circle (+ last-x 80) (+ last-y 43) 10.0
|
|
||||||
(if (= last-gesture :double-tap) rl/skyblue rl/lightgray))
|
|
||||||
(rl/draw-circle (+ last-x 103) (+ last-y 43) 10.0
|
|
||||||
(if (= last-gesture :double-tap) rl/skyblue rl/lightgray))
|
|
||||||
|
|
||||||
;; The two pairs of arrowheads, pointing outward for pinch-out and inward
|
|
||||||
;; for pinch-in. Counter-clockwise winding, or raylib culls them.
|
|
||||||
(let [out-c (if (= last-gesture :pinch-out) rl/orange rl/lightgray)
|
|
||||||
in-c (if (= last-gesture :pinch-in) rl/violet rl/lightgray)]
|
|
||||||
(rl/draw-triangle (rl/Vector2 {.x (f32 (+ last-x 122)) .y (f32 (+ last-y 16))})
|
|
||||||
(rl/Vector2 {.x (f32 (+ last-x 137)) .y (f32 (+ last-y 26))})
|
|
||||||
(rl/Vector2 {.x (f32 (+ last-x 137)) .y (f32 (+ last-y 6))})
|
|
||||||
out-c)
|
|
||||||
(rl/draw-triangle (rl/Vector2 {.x (f32 (+ last-x 147)) .y (f32 (+ last-y 6))})
|
|
||||||
(rl/Vector2 {.x (f32 (+ last-x 147)) .y (f32 (+ last-y 26))})
|
|
||||||
(rl/Vector2 {.x (f32 (+ last-x 162)) .y (f32 (+ last-y 16))})
|
|
||||||
out-c)
|
|
||||||
(rl/draw-triangle (rl/Vector2 {.x (f32 (+ last-x 125)) .y (f32 (+ last-y 33))})
|
|
||||||
(rl/Vector2 {.x (f32 (+ last-x 125)) .y (f32 (+ last-y 53))})
|
|
||||||
(rl/Vector2 {.x (f32 (+ last-x 140)) .y (f32 (+ last-y 43))})
|
|
||||||
in-c)
|
|
||||||
(rl/draw-triangle (rl/Vector2 {.x (f32 (+ last-x 144)) .y (f32 (+ last-y 43))})
|
|
||||||
(rl/Vector2 {.x (f32 (+ last-x 159)) .y (f32 (+ last-y 53))})
|
|
||||||
(rl/Vector2 {.x (f32 (+ last-x 159)) .y (f32 (+ last-y 33))})
|
|
||||||
in-c))
|
|
||||||
|
|
||||||
;; Four pips, one per simultaneous touch raylib reports.
|
|
||||||
(dotimes [i 4]
|
|
||||||
(rl/draw-circle (+ last-x 180) (+ (+ last-y 7) (* i 15)) 5.0
|
|
||||||
(if (<= touch-count i) rl/lightgray gesture-color))))
|
|
||||||
|
|
||||||
(defn draw-log [] ()
|
|
||||||
(rl/draw-text "Log" 10 10 20 rl/black)
|
|
||||||
;; Forward from the newest, wrapping — the inverted queue read the right way
|
|
||||||
;; round.
|
|
||||||
(dotimes [i gesture-log-size]
|
|
||||||
(let [ii (% (+ gesture-log-index i) gesture-log-size)]
|
|
||||||
(rl/draw-text (at gesture-log ii) 10 (- (+ 10 410) (* i 20)) 20
|
|
||||||
(if (= i 0) gesture-color rl/lightgray))))
|
|
||||||
|
|
||||||
;; The two mode buttons. Maroon means the mode that button controls is on.
|
|
||||||
(let [b1 (rl/Rectangle {.x 53.0 .y 7.0 .width 48.0 .height 26.0})
|
|
||||||
b2 (rl/Rectangle {.x 108.0 .y 7.0 .width 36.0 .height 26.0})]
|
|
||||||
(rl/draw-rectangle-rec b1 (if (or (= log-mode 1) (= log-mode 3))
|
|
||||||
rl/maroon rl/gray))
|
|
||||||
(rl/draw-text "Hide" 60 10 10 rl/white)
|
|
||||||
(rl/draw-text "Repeat" 60 20 10 rl/white)
|
|
||||||
(rl/draw-rectangle-rec b2 (if (or (= log-mode 2) (= log-mode 3))
|
|
||||||
rl/maroon rl/gray))
|
|
||||||
(rl/draw-text "Hide" 115 10 10 rl/white)
|
|
||||||
(rl/draw-text "Hold" 115 20 10 rl/white)))
|
|
||||||
|
|
||||||
(defn draw-protractor [] ()
|
|
||||||
(rl/draw-text "Angle" (+ (i32 prot-x) 55) (+ (i32 prot-y) 76) 10 rl/black)
|
|
||||||
;; The C's TextFormat/TextFindIndex/TextSubtext dance to get two decimals,
|
|
||||||
;; in one call. It rounds where the C truncated, so the last digit can
|
|
||||||
;; differ by one.
|
|
||||||
(d/draw-f32 current-angle 2 (+ (i32 prot-x) 55) (+ (i32 prot-y) 92) 20
|
|
||||||
gesture-color)
|
|
||||||
|
|
||||||
(rl/draw-circle-v (rl/Vector2 {.x prot-x .y prot-y}) 80.0 rl/white)
|
|
||||||
(rl/draw-line-ex (rl/Vector2 {.x (- prot-x 90.0) .y prot-y})
|
|
||||||
(rl/Vector2 {.x (+ prot-x 90.0) .y prot-y}) 3.0 rl/lightgray)
|
|
||||||
(rl/draw-line-ex (rl/Vector2 {.x prot-x .y (- prot-y 90.0)})
|
|
||||||
(rl/Vector2 {.x prot-x .y (+ prot-y 90.0)}) 3.0 rl/lightgray)
|
|
||||||
(rl/draw-line-ex (rl/Vector2 {.x (- prot-x 80.0) .y (- prot-y 45.0)})
|
|
||||||
(rl/Vector2 {.x (+ prot-x 80.0) .y (+ prot-y 45.0)}) 3.0
|
|
||||||
rl/green)
|
|
||||||
(rl/draw-line-ex (rl/Vector2 {.x (- prot-x 80.0) .y (+ prot-y 45.0)})
|
|
||||||
(rl/Vector2 {.x (+ prot-x 80.0) .y (- prot-y 45.0)}) 3.0
|
|
||||||
rl/green)
|
|
||||||
|
|
||||||
(rl/draw-text "0" (+ (i32 prot-x) 96) (- (i32 prot-y) 9) 20 rl/black)
|
|
||||||
(rl/draw-text "30" (+ (i32 prot-x) 74) (- (i32 prot-y) 68) 20 rl/black)
|
|
||||||
(rl/draw-text "90" (- (i32 prot-x) 11) (- (i32 prot-y) 110) 20 rl/black)
|
|
||||||
(rl/draw-text "150" (- (i32 prot-x) 100) (- (i32 prot-y) 68) 20 rl/black)
|
|
||||||
(rl/draw-text "180" (- (i32 prot-x) 124) (- (i32 prot-y) 9) 20 rl/black)
|
|
||||||
(rl/draw-text "210" (- (i32 prot-x) 100) (+ (i32 prot-y) 50) 20 rl/black)
|
|
||||||
(rl/draw-text "270" (- (i32 prot-x) 18) (+ (i32 prot-y) 92) 20 rl/black)
|
|
||||||
(rl/draw-text "330" (+ (i32 prot-x) 72) (+ (i32 prot-y) 50) 20 rl/black)
|
|
||||||
|
|
||||||
;; The needle. The C's +90 puts 0 degrees on the right, and sin feeding x
|
|
||||||
;; against cos feeding y is what rotates it the way the dial is labelled.
|
|
||||||
(unless (= current-angle 0.0)
|
|
||||||
(let [rad (/ (* (+ current-angle 90.0) pi) 180.0)]
|
|
||||||
(rl/draw-line-ex (rl/Vector2 {.x prot-x .y prot-y})
|
|
||||||
(rl/Vector2 {.x (+ (* angle-length (sin-f32 rad)) prot-x)
|
|
||||||
.y (+ (* angle-length (cos-f32 rad)) prot-y)})
|
|
||||||
3.0 gesture-color))))
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - input gestures testbed")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
;; A zeroed Color has an alpha of 0 and is invisible; the C initialises this
|
|
||||||
;; to opaque black. Same for the log index, which starts at the SIZE.
|
|
||||||
(set gesture-color rl/black)
|
|
||||||
(set gesture-log-index gesture-log-size)
|
|
||||||
(set log-mode 1)
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(let [b1 (rl/Rectangle {.x 53.0 .y 7.0 .width 48.0 .height 26.0})
|
|
||||||
b2 (rl/Rectangle {.x 108.0 .y 7.0 .width 36.0 .height 26.0})]
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
|
||||||
(let [g (rl/get-gesture-detected)
|
|
||||||
touch-count (min max-touch-count (rl/get-touch-point-count))]
|
|
||||||
|
|
||||||
;; The C filters hold out of the "last gesture" display, because hold
|
|
||||||
;; repeats every frame and would drown everything else.
|
|
||||||
(when (and (and (not (= g :none)) (not (= g :hold)))
|
|
||||||
(not (= g previous-gesture)))
|
|
||||||
(set last-gesture g))
|
|
||||||
|
|
||||||
;; The two mode buttons toggle one bit each of log-mode.
|
|
||||||
(when (rl/mouse-button-released? :left)
|
|
||||||
(let [m (rl/get-mouse-position)]
|
|
||||||
(when (rl/collision-point-rec? m b1)
|
|
||||||
(set log-mode (cond (= log-mode 3) 2
|
|
||||||
(= log-mode 2) 3
|
|
||||||
(= log-mode 1) 0
|
|
||||||
:else 1)))
|
|
||||||
(when (rl/collision-point-rec? m b2)
|
|
||||||
(set log-mode (cond (= log-mode 3) 1
|
|
||||||
(= log-mode 2) 0
|
|
||||||
(= log-mode 1) 3
|
|
||||||
:else 2)))))
|
|
||||||
|
|
||||||
(when (should-log? g) (push-log g))
|
|
||||||
|
|
||||||
;; The protractor reads the pinch angle for a pinch, the drag angle for
|
|
||||||
;; a swipe, and sits at 0 for everything else. These are the C's
|
|
||||||
;; `> 255` / `> 15` / `> 0` — see the header for why they are spelled
|
|
||||||
;; this way.
|
|
||||||
(cond
|
|
||||||
(pinch? g) (set current-angle (rl/get-gesture-pinch-angle))
|
|
||||||
(swipe? g) (set current-angle (rl/get-gesture-drag-angle))
|
|
||||||
(not (= g :none)) (set current-angle 0.0)
|
|
||||||
:else (do))
|
|
||||||
|
|
||||||
(dotimes [i touch-count]
|
|
||||||
(set (at touch-positions i) (rl/get-touch-position i)))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(rl/draw-text "*" 165 12 10 rl/black)
|
|
||||||
(rl/draw-text "Example optimized for Web/HTML5\non Smartphones with Touch Screen."
|
|
||||||
175 12 10 rl/black)
|
|
||||||
(rl/draw-text "*" 165 42 10 rl/black)
|
|
||||||
(rl/draw-text "While running on Desktop Web Browsers,\ninspect and turn on Touch Emulation."
|
|
||||||
175 42 10 rl/black)
|
|
||||||
|
|
||||||
(draw-last-gesture touch-count)
|
|
||||||
(draw-log)
|
|
||||||
(draw-protractor)
|
|
||||||
|
|
||||||
;; The pointer itself: every live touch, or the mouse when there is no
|
|
||||||
;; touchscreen. The halo is the gesture colour faded, which is what
|
|
||||||
;; `fade` was bound for.
|
|
||||||
(unless (= g :none)
|
|
||||||
(if (> touch-count 0)
|
|
||||||
(do
|
|
||||||
(dotimes [i touch-count]
|
|
||||||
(let [p (at touch-positions i)]
|
|
||||||
(rl/draw-circle-v p 50.0 (rl/fade gesture-color 0.5))
|
|
||||||
(rl/draw-circle-v p 5.0 gesture-color)))
|
|
||||||
;; Two fingers: the line between them, thinner while pinching
|
|
||||||
;; out, which is the C's only use of the raw 512.
|
|
||||||
(when (= touch-count 2)
|
|
||||||
(rl/draw-line-ex (at touch-positions 0) (at touch-positions 1)
|
|
||||||
(if (= g :pinch-out) 8.0 12.0) gesture-color)))
|
|
||||||
(let [m (rl/get-mouse-position)]
|
|
||||||
(rl/draw-circle-v m 35.0 (rl/fade gesture-color 0.5))
|
|
||||||
(rl/draw-circle-v m 5.0 gesture-color)))))))))
|
|
||||||
@@ -0,0 +1,374 @@
|
|||||||
|
;;;; raylib [core] example - input gestures testbed
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_input_gestures_testbed.c, the four-star one and the
|
||||||
|
;;;; hardest of the ten. It runs, and it is the example that pushed hardest on
|
||||||
|
;;;; the language. Four things it needed, in descending order of how much they
|
||||||
|
;;;; cost.
|
||||||
|
;;;;
|
||||||
|
;;;; **An enum converts to an integer, when you say so.** The C treats the
|
||||||
|
;;;; gesture as the raw bitfield it is and compares it with `<` and `>`:
|
||||||
|
;;;; `currentGesture > 255` picks out the two pinches, `> 15` the four swipes,
|
||||||
|
;;;; `!= 4` excludes hold, `< 3` admits tap and double-tap. `get-gesture-
|
||||||
|
;;;; detected` answers an `rl/Gesture`, and that used to end the discussion —
|
||||||
|
;;;;
|
||||||
|
;;;; i32 converts a number, found rl/Gesture
|
||||||
|
;;;;
|
||||||
|
;;;; — so the three range tests were spelled out as keyword equalities, one
|
||||||
|
;;;; arm per member. They are `(> (i32 g) 255)`, `(> (i32 g) 15)` and
|
||||||
|
;;;; `(< (i32 g) 3)` now, still behind the named predicates below, and the fix
|
||||||
|
;;;; is not brevity: the enumerated version was *wrong about the future*. A
|
||||||
|
;;;; gesture raylib adds later falls silently out of a list of four members,
|
||||||
|
;;;; where the C's `> 15` catches it. The range test is the honest reading of
|
||||||
|
;;;; a bitfield and now it is the one written.
|
||||||
|
;;;;
|
||||||
|
;;;; The rule the refusal came from is unchanged and worth keeping: an enum is
|
||||||
|
;;;; its own type in the checker, so `:tpa` is an error at the call site
|
||||||
|
;;;; instead of a number that is wrong later, and a bare integer still does not
|
||||||
|
;;;; fit an `rl/Gesture` parameter. `i32(g)` does not weaken that — it is
|
||||||
|
;;;; named, and it is at the site. The rule was "an integer must not arrive
|
||||||
|
;;;; silently", not "an integer is dangerous".
|
||||||
|
;;;;
|
||||||
|
;;;; The `!= 4` stays a keyword comparison, `not g == :gesture-hold`. That
|
||||||
|
;;;; one was never a range test; it is a single member, and the C's 4 is a
|
||||||
|
;;;; magic number the keyword reads better than.
|
||||||
|
;;;;
|
||||||
|
;;;; **No sin or cos.** The prelude has sqrt-f32 — one `declare` over libm,
|
||||||
|
;;;; with a comment explaining why it is not a builtin — and nothing else
|
||||||
|
;;;; transcendental. The protractor needs both, so they are two more `declare`
|
||||||
|
;;;; lines here, in the same shape. They link: libm is already on the line.
|
||||||
|
;;;;
|
||||||
|
;;;; **No string formatting.** A number can be made into a string now —
|
||||||
|
;;;; (string (i64->bytes n)) — but a *format* still cannot: f64->bytes is
|
||||||
|
;;;; "%g", with no way to ask for two decimal places. The C prints the angle
|
||||||
|
;;;; with `TextFormat("%f", ...)`, finds the decimal point with
|
||||||
|
;;;; `TextFindIndex` and cuts two digits past it with `TextSubtext`;
|
||||||
|
;;;; `draw-f32` in examples/digits.fln does the whole thing in one call, and
|
||||||
|
;;;; rounds rather than truncating — which is the one place this screen
|
||||||
|
;;;; differs from the C's by a digit.
|
||||||
|
;;;;
|
||||||
|
;;;; **No local fixed arrays.** The C declares `char gestureLog[20][12]` and
|
||||||
|
;;;; `Vector2 touchPosition[32]` inside main. A `let` binding takes no type
|
||||||
|
;;;; annotation, so a fixed array can only be a top-level `once` or a literal
|
||||||
|
;;;; with every element written out — thirty-two Vector2s, here. They are
|
||||||
|
;;;; `once`s, which is what the C's storage amounts to anyway.
|
||||||
|
;;;;
|
||||||
|
;;;; The log itself came out simpler than the C's: the names are compile-time
|
||||||
|
;;;; literals, so a slot holds a `string` and there is no TextCopy and no
|
||||||
|
;;;; twelve-byte truncation.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
import d "digits.fln"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
const pi: f32 = 3.14159265
|
||||||
|
|
||||||
|
const gesture-log-size = 20
|
||||||
|
const max-touch-count = 32
|
||||||
|
|
||||||
|
once gesture-log: [gesture-log-size str]
|
||||||
|
|
||||||
|
;; The C's inverted circular queue: the index counts DOWN and wraps at the top,
|
||||||
|
;; so the newest entry is always at gesture-log-index and the draw loop walks
|
||||||
|
;; forward from there. Starting at the size rather than at size-1 is the C's
|
||||||
|
;; too — the first write decrements before storing.
|
||||||
|
once gesture-log-index: i32
|
||||||
|
once previous-gesture: rl/Gesture
|
||||||
|
once last-gesture: rl/Gesture
|
||||||
|
once gesture-color: rl/Color
|
||||||
|
once log-mode: i32
|
||||||
|
once current-angle: f32
|
||||||
|
once touch-positions: [max-touch-count rl/Vector2]
|
||||||
|
|
||||||
|
;; ── The comparisons the C makes on the raw bitfield ─────────────────
|
||||||
|
;;
|
||||||
|
;; A gesture is a flag: 1, 2, 4, 8 … up to 512, so the ranges are the C's way
|
||||||
|
;; of asking which family a gesture belongs to. (i32 g) is what lets that be
|
||||||
|
;; written; they are named here rather than inline because a bare 255 at a
|
||||||
|
;; call site says nothing, and because a gesture raylib adds later lands in
|
||||||
|
;; the right family without this file being edited.
|
||||||
|
|
||||||
|
fn is-pinch(g: rl/Gesture) -> bool ; the C's `> 255`
|
||||||
|
i32(g) > 255
|
||||||
|
|
||||||
|
fn is-swipe(g: rl/Gesture) -> bool ; the C's `> 15`
|
||||||
|
i32(g) > 15
|
||||||
|
|
||||||
|
fn is-tapish(g: rl/Gesture) -> bool ; the C's `< 3`
|
||||||
|
i32(g) < 3
|
||||||
|
|
||||||
|
;; Two orderings these impose, both of them the C's as well. A pinch is above
|
||||||
|
;; 255 and therefore above 15, so is-swipe has to be asked after the pinches
|
||||||
|
;; rather than before; and is-tapish admits :gesture-none, which is 0, so it
|
||||||
|
;; belongs under a :gesture-none guard. The C's switch over single members
|
||||||
|
;; hides both; a range test cannot.
|
||||||
|
|
||||||
|
fn gesture-name(g: rl/Gesture) -> str
|
||||||
|
if g == :gesture-none
|
||||||
|
"None"
|
||||||
|
elif g == :gesture-tap
|
||||||
|
"Tap"
|
||||||
|
elif g == :gesture-double-tap
|
||||||
|
"Double Tap"
|
||||||
|
elif g == :gesture-hold
|
||||||
|
"Hold"
|
||||||
|
elif g == :gesture-drag
|
||||||
|
"Drag"
|
||||||
|
elif g == :gesture-swipe-right
|
||||||
|
"Swipe Right"
|
||||||
|
elif g == :gesture-swipe-left
|
||||||
|
"Swipe Left"
|
||||||
|
elif g == :gesture-swipe-up
|
||||||
|
"Swipe Up"
|
||||||
|
elif g == :gesture-swipe-down
|
||||||
|
"Swipe Down"
|
||||||
|
elif g == :gesture-pinch-in
|
||||||
|
"Pinch In"
|
||||||
|
elif g == :gesture-pinch-out
|
||||||
|
"Pinch Out"
|
||||||
|
else
|
||||||
|
"Unknown"
|
||||||
|
|
||||||
|
fn gesture-color-of(g: rl/Gesture) -> rl/Color
|
||||||
|
if g == :gesture-tap
|
||||||
|
rl/blue
|
||||||
|
elif g == :gesture-double-tap
|
||||||
|
rl/skyblue
|
||||||
|
elif g == :gesture-drag
|
||||||
|
rl/lime
|
||||||
|
;; The two pinches are above 255 and so are above 15 as well: is-swipe is a
|
||||||
|
;; range test and has to be asked after them, not before. The C gets this
|
||||||
|
;; for free by being a switch over single members.
|
||||||
|
elif g == :gesture-pinch-in
|
||||||
|
rl/violet
|
||||||
|
elif g == :gesture-pinch-out
|
||||||
|
rl/orange
|
||||||
|
elif is-swipe(g)
|
||||||
|
rl/red
|
||||||
|
else
|
||||||
|
rl/black
|
||||||
|
|
||||||
|
;; ── The log ─────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
;; The C's four log modes, as a truth table rather than as nested ifs:
|
||||||
|
;; 0 shows repeated events
|
||||||
|
;; 1 hides repeated events
|
||||||
|
;; 2 shows repeated events but hides hold
|
||||||
|
;; 3 hides repeated events and hides hold
|
||||||
|
fn is-should-log(g: rl/Gesture) -> bool
|
||||||
|
if g == :gesture-none
|
||||||
|
false
|
||||||
|
elif log-mode == 3
|
||||||
|
(not g == :gesture-hold and not g == previous-gesture) or is-tapish(g)
|
||||||
|
elif log-mode == 2
|
||||||
|
not g == :gesture-hold
|
||||||
|
elif log-mode == 1
|
||||||
|
not g == previous-gesture
|
||||||
|
else
|
||||||
|
true
|
||||||
|
|
||||||
|
fn push-log(g: rl/Gesture) -> ()
|
||||||
|
previous-gesture = g
|
||||||
|
gesture-color = gesture-color-of(g)
|
||||||
|
if gesture-log-index <= 0
|
||||||
|
gesture-log-index = gesture-log-size
|
||||||
|
gesture-log-index -= 1
|
||||||
|
gesture-log[gesture-log-index] = gesture-name(g)
|
||||||
|
|
||||||
|
;; ── Drawing ─────────────────────────────────────────────────────────
|
||||||
|
|
||||||
|
const last-x = 165
|
||||||
|
const last-y = 130
|
||||||
|
const prot-x: f32 = 266.0
|
||||||
|
const prot-y: f32 = 315.0
|
||||||
|
const angle-length: f32 = 90.0
|
||||||
|
|
||||||
|
fn swipe-box(gx: i32, gy: i32, which: rl/Gesture) -> ()
|
||||||
|
rl/draw-rectangle(gx, gy, 20, 20,
|
||||||
|
if last-gesture == which then rl/red else rl/lightgray)
|
||||||
|
|
||||||
|
fn draw-last-gesture(touch-count: i32) -> ()
|
||||||
|
rl/draw-text("Last gesture", last-x + 33, last-y - 47, 20, rl/black)
|
||||||
|
rl/draw-text("Swipe Tap Pinch Touch", last-x + 17, last-y - 18,
|
||||||
|
10, rl/black)
|
||||||
|
swipe-box(last-x + 20, last-y, :gesture-swipe-up)
|
||||||
|
swipe-box(last-x, last-y + 20, :gesture-swipe-left)
|
||||||
|
swipe-box(last-x + 40, last-y + 20, :gesture-swipe-right)
|
||||||
|
swipe-box(last-x + 20, last-y + 40, :gesture-swipe-down)
|
||||||
|
rl/draw-circle(last-x + 80, last-y + 16, 10.0,
|
||||||
|
if last-gesture == :gesture-tap then rl/blue else rl/lightgray)
|
||||||
|
;; segments 0 lets raylib pick the count from the radius.
|
||||||
|
rl/draw-ring(rl/Vector2{.x f32(last-x + 103) .y f32(last-y + 16)}, 6.0, 11.0,
|
||||||
|
0.0, 360.0, 0,
|
||||||
|
if last-gesture == :gesture-drag then rl/lime else rl/lightgray)
|
||||||
|
rl/draw-circle(last-x + 80, last-y + 43, 10.0,
|
||||||
|
if last-gesture == :gesture-double-tap then rl/skyblue else rl/lightgray)
|
||||||
|
rl/draw-circle(last-x + 103, last-y + 43, 10.0,
|
||||||
|
if last-gesture == :gesture-double-tap then rl/skyblue else rl/lightgray)
|
||||||
|
;; The two pairs of arrowheads, pointing outward for pinch-out and inward
|
||||||
|
;; for pinch-in. Counter-clockwise winding, or raylib culls them.
|
||||||
|
let out-c =
|
||||||
|
if last-gesture == :gesture-pinch-out then rl/orange else rl/lightgray
|
||||||
|
let in-c =
|
||||||
|
if last-gesture == :gesture-pinch-in then rl/violet else rl/lightgray
|
||||||
|
rl/draw-triangle(rl/Vector2{.x f32(last-x + 122) .y f32(last-y + 16)},
|
||||||
|
rl/Vector2{.x f32(last-x + 137) .y f32(last-y + 26)},
|
||||||
|
rl/Vector2{.x f32(last-x + 137) .y f32(last-y + 6)}, out-c)
|
||||||
|
rl/draw-triangle(rl/Vector2{.x f32(last-x + 147) .y f32(last-y + 6)},
|
||||||
|
rl/Vector2{.x f32(last-x + 147) .y f32(last-y + 26)},
|
||||||
|
rl/Vector2{.x f32(last-x + 162) .y f32(last-y + 16)}, out-c)
|
||||||
|
rl/draw-triangle(rl/Vector2{.x f32(last-x + 125) .y f32(last-y + 33)},
|
||||||
|
rl/Vector2{.x f32(last-x + 125) .y f32(last-y + 53)},
|
||||||
|
rl/Vector2{.x f32(last-x + 140) .y f32(last-y + 43)}, in-c)
|
||||||
|
rl/draw-triangle(rl/Vector2{.x f32(last-x + 144) .y f32(last-y + 43)},
|
||||||
|
rl/Vector2{.x f32(last-x + 159) .y f32(last-y + 53)},
|
||||||
|
rl/Vector2{.x f32(last-x + 159) .y f32(last-y + 33)}, in-c)
|
||||||
|
;; Four pips, one per simultaneous touch raylib reports.
|
||||||
|
for i in 0..4
|
||||||
|
rl/draw-circle(last-x + 180, (last-y + 7) + i * 15, 5.0,
|
||||||
|
if touch-count <= i then rl/lightgray else gesture-color)
|
||||||
|
|
||||||
|
fn draw-log() -> ()
|
||||||
|
rl/draw-text("Log", 10, 10, 20, rl/black)
|
||||||
|
;; Forward from the newest, wrapping — the inverted queue read the right way
|
||||||
|
;; round.
|
||||||
|
for i in 0..gesture-log-size
|
||||||
|
let ii = (gesture-log-index + i) % gesture-log-size
|
||||||
|
rl/draw-text(gesture-log[ii], 10, 10 + 410 - i * 20, 20,
|
||||||
|
if i == 0 then gesture-color else rl/lightgray)
|
||||||
|
;; The two mode buttons. Maroon means the mode that button controls is on.
|
||||||
|
let b1 = rl/Rectangle{.x 53.0 .y 7.0 .width 48.0 .height 26.0}
|
||||||
|
let b2 = rl/Rectangle{.x 108.0 .y 7.0 .width 36.0 .height 26.0}
|
||||||
|
rl/draw-rectangle-rec(b1,
|
||||||
|
if log-mode == 1 or log-mode == 3 then rl/maroon else rl/gray)
|
||||||
|
rl/draw-text("Hide", 60, 10, 10, rl/white)
|
||||||
|
rl/draw-text("Repeat", 60, 20, 10, rl/white)
|
||||||
|
rl/draw-rectangle-rec(b2,
|
||||||
|
if log-mode == 2 or log-mode == 3 then rl/maroon else rl/gray)
|
||||||
|
rl/draw-text("Hide", 115, 10, 10, rl/white)
|
||||||
|
rl/draw-text("Hold", 115, 20, 10, rl/white)
|
||||||
|
|
||||||
|
fn draw-protractor() -> ()
|
||||||
|
rl/draw-text("Angle", i32(prot-x) + 55, i32(prot-y) + 76, 10, rl/black)
|
||||||
|
;; The C's TextFormat/TextFindIndex/TextSubtext dance to get two decimals,
|
||||||
|
;; in one call. It rounds where the C truncated, so the last digit can
|
||||||
|
;; differ by one.
|
||||||
|
d/draw-f32(current-angle, 2, i32(prot-x) + 55, i32(prot-y) + 92, 20,
|
||||||
|
gesture-color)
|
||||||
|
rl/draw-circle-v(rl/Vector2{.x prot-x .y prot-y}, 80.0, rl/white)
|
||||||
|
rl/draw-line-ex(rl/Vector2{.x prot-x - 90.0, .y prot-y},
|
||||||
|
rl/Vector2{.x prot-x + 90.0, .y prot-y}, 3.0, rl/lightgray)
|
||||||
|
rl/draw-line-ex(rl/Vector2{.x prot-x, .y prot-y - 90.0},
|
||||||
|
rl/Vector2{.x prot-x, .y prot-y + 90.0}, 3.0, rl/lightgray)
|
||||||
|
rl/draw-line-ex(rl/Vector2{.x prot-x - 80.0, .y prot-y - 45.0},
|
||||||
|
rl/Vector2{.x prot-x + 80.0, .y prot-y + 45.0}, 3.0, rl/green)
|
||||||
|
rl/draw-line-ex(rl/Vector2{.x prot-x - 80.0, .y prot-y + 45.0},
|
||||||
|
rl/Vector2{.x prot-x + 80.0, .y prot-y - 45.0}, 3.0, rl/green)
|
||||||
|
rl/draw-text("0", i32(prot-x) + 96, i32(prot-y) - 9, 20, rl/black)
|
||||||
|
rl/draw-text("30", i32(prot-x) + 74, i32(prot-y) - 68, 20, rl/black)
|
||||||
|
rl/draw-text("90", i32(prot-x) - 11, i32(prot-y) - 110, 20, rl/black)
|
||||||
|
rl/draw-text("150", i32(prot-x) - 100, i32(prot-y) - 68, 20, rl/black)
|
||||||
|
rl/draw-text("180", i32(prot-x) - 124, i32(prot-y) - 9, 20, rl/black)
|
||||||
|
rl/draw-text("210", i32(prot-x) - 100, i32(prot-y) + 50, 20, rl/black)
|
||||||
|
rl/draw-text("270", i32(prot-x) - 18, i32(prot-y) + 92, 20, rl/black)
|
||||||
|
rl/draw-text("330", i32(prot-x) + 72, i32(prot-y) + 50, 20, rl/black)
|
||||||
|
;; The needle. The C's +90 puts 0 degrees on the right, and sin feeding x
|
||||||
|
;; against cos feeding y is what rotates it the way the dial is labelled.
|
||||||
|
unless(current-angle == 0.0):
|
||||||
|
let rad = (current-angle + 90.0) * pi / 180.0
|
||||||
|
rl/draw-line-ex(rl/Vector2{.x prot-x .y prot-y},
|
||||||
|
rl/Vector2{.x angle-length * sin-f32(rad) + prot-x, .y angle-length * cos-f32(rad) + prot-y},
|
||||||
|
3.0, gesture-color)
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - input gestures testbed")
|
||||||
|
defer rl/close-window()
|
||||||
|
;; A zeroed Color has an alpha of 0 and is invisible; the C initialises this
|
||||||
|
;; to opaque black. Same for the log index, which starts at the SIZE.
|
||||||
|
gesture-color = rl/black
|
||||||
|
gesture-log-index = gesture-log-size
|
||||||
|
log-mode = 1
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
let b1 = rl/Rectangle{.x 53.0 .y 7.0 .width 48.0 .height 26.0}
|
||||||
|
let b2 = rl/Rectangle{.x 108.0 .y 7.0 .width 36.0 .height 26.0}
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update
|
||||||
|
let g = rl/get-gesture-detected()
|
||||||
|
let touch-count = min(max-touch-count, rl/get-touch-point-count())
|
||||||
|
;; The C filters hold out of the "last gesture" display, because hold
|
||||||
|
;; repeats every frame and would drown everything else.
|
||||||
|
if (not g == :gesture-none and not g == :gesture-hold) and not g == previous-gesture
|
||||||
|
last-gesture = g
|
||||||
|
;; The two mode buttons toggle one bit each of log-mode.
|
||||||
|
if rl/is-mouse-button-released(:mouse-left)
|
||||||
|
let m = rl/get-mouse-position()
|
||||||
|
if rl/check-collision-point-rec(m, b1)
|
||||||
|
log-mode =
|
||||||
|
if log-mode == 3
|
||||||
|
2
|
||||||
|
elif log-mode == 2
|
||||||
|
3
|
||||||
|
elif log-mode == 1
|
||||||
|
0
|
||||||
|
else
|
||||||
|
1
|
||||||
|
if rl/check-collision-point-rec(m, b2)
|
||||||
|
log-mode =
|
||||||
|
if log-mode == 3
|
||||||
|
1
|
||||||
|
elif log-mode == 2
|
||||||
|
0
|
||||||
|
elif log-mode == 1
|
||||||
|
3
|
||||||
|
else
|
||||||
|
2
|
||||||
|
if is-should-log(g)
|
||||||
|
push-log(g)
|
||||||
|
;; The protractor reads the pinch angle for a pinch, the drag angle for
|
||||||
|
;; a swipe, and sits at 0 for everything else. These are the C's
|
||||||
|
;; `> 255` / `> 15` / `> 0` — see the header for why they are spelled
|
||||||
|
;; this way.
|
||||||
|
if is-pinch(g)
|
||||||
|
current-angle = rl/get-gesture-pinch-angle()
|
||||||
|
elif is-swipe(g)
|
||||||
|
current-angle = rl/get-gesture-drag-angle()
|
||||||
|
elif not g == :gesture-none
|
||||||
|
current-angle = 0.0
|
||||||
|
else
|
||||||
|
()
|
||||||
|
for i in 0..touch-count
|
||||||
|
touch-positions[i] = rl/get-touch-position(i)
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/draw-text("*", 165, 12, 10, rl/black)
|
||||||
|
rl/draw-text("Example optimized for Web/HTML5\non Smartphones with Touch Screen.",
|
||||||
|
175, 12, 10, rl/black)
|
||||||
|
rl/draw-text("*", 165, 42, 10, rl/black)
|
||||||
|
rl/draw-text("While running on Desktop Web Browsers,\ninspect and turn on Touch Emulation.",
|
||||||
|
175, 42, 10, rl/black)
|
||||||
|
draw-last-gesture(touch-count)
|
||||||
|
draw-log()
|
||||||
|
draw-protractor()
|
||||||
|
;; The pointer itself: every live touch, or the mouse when there is no
|
||||||
|
;; touchscreen. The halo is the gesture colour faded, which is what
|
||||||
|
;; `fade` was bound for.
|
||||||
|
unless(g == :gesture-none):
|
||||||
|
if touch-count > 0
|
||||||
|
for i in 0..touch-count
|
||||||
|
let p = touch-positions[i]
|
||||||
|
rl/draw-circle-v(p, 50.0, rl/fade(gesture-color, 0.5))
|
||||||
|
rl/draw-circle-v(p, 5.0, gesture-color)
|
||||||
|
;; Two fingers: the line between them, thinner while pinching
|
||||||
|
;; out, which is the C's only use of the raw 512.
|
||||||
|
if touch-count == 2
|
||||||
|
rl/draw-line-ex(touch-positions[0], touch-positions[1],
|
||||||
|
if g == :gesture-pinch-out then 8.0 else 12.0,
|
||||||
|
gesture-color)
|
||||||
|
else
|
||||||
|
let m = rl/get-mouse-position()
|
||||||
|
rl/draw-circle-v(m, 35.0, rl/fade(gesture-color, 0.5))
|
||||||
|
rl/draw-circle-v(m, 5.0, gesture-color)
|
||||||
@@ -1,108 +0,0 @@
|
|||||||
;;;; raylib [core] example - input gestures
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_input_gestures.c. Needed `fade`, now bound.
|
|
||||||
;;;;
|
|
||||||
;;;; The C keeps `char gestureStrings[20][32]` and TextCopy's a name into the
|
|
||||||
;;;; next slot. Flan has no mutable character buffer and no way to copy into
|
|
||||||
;;;; one, but it does not need either: the names are compile-time literals, so
|
|
||||||
;;;; the log is a `[20 string]` and a slot holds the literal itself. That is
|
|
||||||
;;;; strictly better than the C — no truncation at 32 bytes, no copy — and it
|
|
||||||
;;;; is only possible because every string that ever goes into the log is
|
|
||||||
;;;; known at compile time. A log of strings the program had BUILT could not be
|
|
||||||
;;;; written at all.
|
|
||||||
;;;;
|
|
||||||
;;;; The C's `switch (currentGesture)` over the ten gesture values is a `cond`
|
|
||||||
;;;; of keyword equalities. `get-gesture-detected` answers an `rl/Gesture` and
|
|
||||||
;;;; `(= g :tap)` compares against a member by name, checked at compile time —
|
|
||||||
;;;; so a typo here is an error and the C's `default: break` has nothing to
|
|
||||||
;;;; catch.
|
|
||||||
;;;;
|
|
||||||
;;;; A slot that has not been written yet holds a zero-length string, because a
|
|
||||||
;;;; `defvar` with no initialiser is all-bytes-zero and a string is ptr+len —
|
|
||||||
;;;; a null pointer with a length of 0. draw-text draws nothing for it. That is
|
|
||||||
;;;; the C's `{ "" }` initialiser arriving by a different route, and it is why
|
|
||||||
;;;; resetting the log below only has to reset the counter.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defconst max-gesture-strings 20)
|
|
||||||
|
|
||||||
(defvar gesture-log [max-gesture-strings string])
|
|
||||||
(defvar gestures-count i32)
|
|
||||||
(defvar current-gesture rl/Gesture)
|
|
||||||
(defvar last-gesture rl/Gesture)
|
|
||||||
|
|
||||||
;; The C's switch, as a function. `:else` is its `default:` — an unnamed
|
|
||||||
;; gesture logs the empty string, which draws nothing, which is what falling
|
|
||||||
;; through the C's switch without a TextCopy leaves in the slot.
|
|
||||||
(defn gesture-name [g rl/Gesture] string
|
|
||||||
(cond
|
|
||||||
(= g :tap) "GESTURE TAP"
|
|
||||||
(= g :double-tap) "GESTURE DOUBLETAP"
|
|
||||||
(= g :hold) "GESTURE HOLD"
|
|
||||||
(= g :drag) "GESTURE DRAG"
|
|
||||||
(= g :swipe-right) "GESTURE SWIPE RIGHT"
|
|
||||||
(= g :swipe-left) "GESTURE SWIPE LEFT"
|
|
||||||
(= g :swipe-up) "GESTURE SWIPE UP"
|
|
||||||
(= g :swipe-down) "GESTURE SWIPE DOWN"
|
|
||||||
(= g :pinch-in) "GESTURE PINCH IN"
|
|
||||||
(= g :pinch-out) "GESTURE PINCH OUT"
|
|
||||||
:else ""))
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - input gestures")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(let [touch-area (rl/Rectangle {.x 220.0 .y 10.0
|
|
||||||
.width (- (f32 screen-width) 230.0)
|
|
||||||
.height (- (f32 screen-height) 20.0)})]
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
|
||||||
(set last-gesture current-gesture)
|
|
||||||
(set current-gesture (rl/get-gesture-detected))
|
|
||||||
(let [touch (rl/get-touch-position 0)]
|
|
||||||
|
|
||||||
(when (and (rl/collision-point-rec? touch touch-area)
|
|
||||||
(not (= current-gesture :none))
|
|
||||||
(not (= current-gesture last-gesture)))
|
|
||||||
(set (at gesture-log gestures-count) (gesture-name current-gesture))
|
|
||||||
(set gestures-count (+ gestures-count 1))
|
|
||||||
;; Full: start over. The stale slots below the counter are never
|
|
||||||
;; drawn, so they do not have to be cleared the way the C clears
|
|
||||||
;; them — the loop below is bounded by gestures-count.
|
|
||||||
(when (>= gestures-count max-gesture-strings)
|
|
||||||
(set gestures-count 0)))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(rl/draw-rectangle-rec touch-area rl/gray)
|
|
||||||
(rl/draw-rectangle 225 15 (- screen-width 240) (- screen-height 30)
|
|
||||||
rl/raywhite)
|
|
||||||
|
|
||||||
(rl/draw-text "GESTURES TEST AREA" (- screen-width 270)
|
|
||||||
(- screen-height 40) 20 (rl/fade rl/gray 0.5))
|
|
||||||
|
|
||||||
(dotimes [i gestures-count]
|
|
||||||
(if (= 0 (% i 2))
|
|
||||||
(rl/draw-rectangle 10 (+ 30 (* 20 i)) 200 20
|
|
||||||
(rl/fade rl/lightgray 0.5))
|
|
||||||
(rl/draw-rectangle 10 (+ 30 (* 20 i)) 200 20
|
|
||||||
(rl/fade rl/lightgray 0.3)))
|
|
||||||
;; The newest entry in maroon and the rest in dark grey, as the C
|
|
||||||
;; has it.
|
|
||||||
(rl/draw-text (at gesture-log i) 35 (+ 36 (* 20 i)) 10
|
|
||||||
(if (< i (- gestures-count 1)) rl/darkgray rl/maroon)))
|
|
||||||
|
|
||||||
(rl/draw-rectangle-lines 10 29 200 (- screen-height 50) rl/gray)
|
|
||||||
(rl/draw-text "DETECTED GESTURES" 50 15 10 rl/gray)
|
|
||||||
|
|
||||||
(unless (= current-gesture :none)
|
|
||||||
(rl/draw-circle-v touch 30.0 rl/maroon)))))))
|
|
||||||
@@ -0,0 +1,106 @@
|
|||||||
|
;;;; raylib [core] example - input gestures
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_input_gestures.c. Needed `fade`, now bound.
|
||||||
|
;;;;
|
||||||
|
;;;; The C keeps `char gestureStrings[20][32]` and TextCopy's a name into the
|
||||||
|
;;;; next slot. Flan has no mutable character buffer and no way to copy into
|
||||||
|
;;;; one, but it does not need either: the names are compile-time literals, so
|
||||||
|
;;;; the log is a `[20 string]` and a slot holds the literal itself. That is
|
||||||
|
;;;; strictly better than the C — no truncation at 32 bytes, no copy — and it
|
||||||
|
;;;; is only possible because every string that ever goes into the log is
|
||||||
|
;;;; known at compile time. A log of strings the program had BUILT could not be
|
||||||
|
;;;; written at all.
|
||||||
|
;;;;
|
||||||
|
;;;; The C's `switch (currentGesture)` over the ten gesture values is a `cond`
|
||||||
|
;;;; of keyword equalities. `get-gesture-detected` answers an `rl/Gesture` and
|
||||||
|
;;;; `(= g :gesture-tap)` compares against a member by name, checked at
|
||||||
|
;;;; compile time — so a typo here is an error and the C's `default: break`
|
||||||
|
;;;; has nothing to catch.
|
||||||
|
;;;;
|
||||||
|
;;;; A slot that has not been written yet holds a zero-length string, because a
|
||||||
|
;;;; `once` with no initialiser is all-bytes-zero and a string is ptr+len —
|
||||||
|
;;;; a null pointer with a length of 0. draw-text draws nothing for it. That is
|
||||||
|
;;;; the C's `{ "" }` initialiser arriving by a different route, and it is why
|
||||||
|
;;;; resetting the log below only has to reset the counter.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
const max-gesture-strings = 20
|
||||||
|
|
||||||
|
once gesture-log: [max-gesture-strings str]
|
||||||
|
once gestures-count: i32
|
||||||
|
once current-gesture: rl/Gesture
|
||||||
|
once last-gesture: rl/Gesture
|
||||||
|
|
||||||
|
;; The C's switch, as a function. `:else` is its `default:` — an unnamed
|
||||||
|
;; gesture logs the empty string, which draws nothing, which is what falling
|
||||||
|
;; through the C's switch without a TextCopy leaves in the slot.
|
||||||
|
fn gesture-name(g: rl/Gesture) -> str
|
||||||
|
if g == :gesture-tap
|
||||||
|
"GESTURE TAP"
|
||||||
|
elif g == :gesture-double-tap
|
||||||
|
"GESTURE DOUBLETAP"
|
||||||
|
elif g == :gesture-hold
|
||||||
|
"GESTURE HOLD"
|
||||||
|
elif g == :gesture-drag
|
||||||
|
"GESTURE DRAG"
|
||||||
|
elif g == :gesture-swipe-right
|
||||||
|
"GESTURE SWIPE RIGHT"
|
||||||
|
elif g == :gesture-swipe-left
|
||||||
|
"GESTURE SWIPE LEFT"
|
||||||
|
elif g == :gesture-swipe-up
|
||||||
|
"GESTURE SWIPE UP"
|
||||||
|
elif g == :gesture-swipe-down
|
||||||
|
"GESTURE SWIPE DOWN"
|
||||||
|
elif g == :gesture-pinch-in
|
||||||
|
"GESTURE PINCH IN"
|
||||||
|
elif g == :gesture-pinch-out
|
||||||
|
"GESTURE PINCH OUT"
|
||||||
|
else
|
||||||
|
""
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - input gestures")
|
||||||
|
defer rl/close-window()
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
let touch-area = rl/Rectangle{.x 220.0, .y 10.0, .width f32(screen-width) - 230.0, .height f32(screen-height) - 20.0}
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update
|
||||||
|
last-gesture = current-gesture
|
||||||
|
current-gesture = rl/get-gesture-detected()
|
||||||
|
let touch = rl/get-touch-position(0)
|
||||||
|
if rl/check-collision-point-rec(touch, touch-area) and not current-gesture == :gesture-none and not current-gesture == last-gesture
|
||||||
|
gesture-log[gestures-count] = gesture-name(current-gesture)
|
||||||
|
gestures-count += 1
|
||||||
|
;; Full: start over. The stale slots below the counter are never
|
||||||
|
;; drawn, so they do not have to be cleared the way the C clears
|
||||||
|
;; them — the loop below is bounded by gestures-count.
|
||||||
|
if gestures-count >= max-gesture-strings
|
||||||
|
gestures-count = 0
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/draw-rectangle-rec(touch-area, rl/gray)
|
||||||
|
rl/draw-rectangle(225, 15, screen-width - 240, screen-height - 30,
|
||||||
|
rl/raywhite)
|
||||||
|
rl/draw-text("GESTURES TEST AREA", screen-width - 270, screen-height - 40,
|
||||||
|
20, rl/fade(rl/gray, 0.5))
|
||||||
|
for i in 0..gestures-count
|
||||||
|
if 0 == i % 2
|
||||||
|
rl/draw-rectangle(10, 30 + 20 * i, 200, 20,
|
||||||
|
rl/fade(rl/lightgray, 0.5))
|
||||||
|
else
|
||||||
|
rl/draw-rectangle(10, 30 + 20 * i, 200, 20,
|
||||||
|
rl/fade(rl/lightgray, 0.3))
|
||||||
|
;; The newest entry in maroon and the rest in dark grey, as the C
|
||||||
|
;; has it.
|
||||||
|
rl/draw-text(gesture-log[i], 35, 36 + 20 * i, 10,
|
||||||
|
if i < gestures-count - 1 then rl/darkgray else rl/maroon)
|
||||||
|
rl/draw-rectangle-lines(10, 29, 200, screen-height - 50, rl/gray)
|
||||||
|
rl/draw-text("DETECTED GESTURES", 50, 15, 10, rl/gray)
|
||||||
|
unless(current-gesture == :gesture-none):
|
||||||
|
rl/draw-circle-v(touch, 30.0, rl/maroon)
|
||||||
@@ -1,46 +0,0 @@
|
|||||||
;;;; raylib [core] example - input keys
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_input_keys.c. Faithful, and the only thing worth noting
|
|
||||||
;;;; is a Flan rule rather than a raylib one.
|
|
||||||
;;;;
|
|
||||||
;;;; The C moves the ball by writing `ballPosition.x += 2.0f` on a local
|
|
||||||
;;;; struct. Flan has the same thing — a local IS an assignable place
|
|
||||||
;;;; (spec-memory.md) — but the local has to be a `defvar` here rather than a
|
|
||||||
;;;; `let` inside the loop, because a `let` binding is rebound every iteration
|
|
||||||
;;;; and the position has to survive between frames. The C's variable is
|
|
||||||
;;;; outside its while loop for the same reason; this is that, spelled with the
|
|
||||||
;;;; storage the language has.
|
|
||||||
;;;;
|
|
||||||
;;;; `(set (.x ball) ...)` works on a struct field of a global: a field of an
|
|
||||||
;;;; assignable place is itself one.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defvar ball rl/Vector2)
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - input keys")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(set ball (rl/Vector2 {.x (f32 (/ screen-width 2))
|
|
||||||
.y (f32 (/ screen-height 2))}))
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update. key-down? and not key-pressed?: this is meant to repeat for as
|
|
||||||
;; long as the key is held, which is the whole difference between the two.
|
|
||||||
(when (rl/key-down? :right) (set (.x ball) (+ (.x ball) 2.0)))
|
|
||||||
(when (rl/key-down? :left) (set (.x ball) (- (.x ball) 2.0)))
|
|
||||||
(when (rl/key-down? :up) (set (.y ball) (- (.y ball) 2.0)))
|
|
||||||
(when (rl/key-down? :down) (set (.y ball) (+ (.y ball) 2.0)))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
(rl/draw-text "move the ball with arrow keys" 10 10 20 rl/darkgray)
|
|
||||||
(rl/draw-circle-v ball 50.0 rl/maroon))))
|
|
||||||
@@ -0,0 +1,45 @@
|
|||||||
|
;;;; raylib [core] example - input keys
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_input_keys.c. Faithful, and the only thing worth noting
|
||||||
|
;;;; is a Flan rule rather than a raylib one.
|
||||||
|
;;;;
|
||||||
|
;;;; The C moves the ball by writing `ballPosition.x += 2.0f` on a local
|
||||||
|
;;;; struct. Flan has the same thing — a local IS an assignable place
|
||||||
|
;;;; (spec-memory.md) — but the local has to be a `once` here rather than a
|
||||||
|
;;;; `let` inside the loop, because a `let` binding is rebound every iteration
|
||||||
|
;;;; and the position has to survive between frames. The C's variable is
|
||||||
|
;;;; outside its while loop for the same reason; this is that, spelled with the
|
||||||
|
;;;; storage the language has.
|
||||||
|
;;;;
|
||||||
|
;;;; `ball.x = ...` works on a struct field of a global: a field of an
|
||||||
|
;;;; assignable place is itself one.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
once ball: rl/Vector2
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - input keys")
|
||||||
|
defer rl/close-window()
|
||||||
|
ball = rl/Vector2{.x f32(screen-width / 2) .y f32(screen-height / 2)}
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update. is-key-down and not is-key-pressed: this is meant to repeat for as
|
||||||
|
;; long as the key is held, which is the whole difference between the two.
|
||||||
|
if rl/is-key-down(:key-right)
|
||||||
|
ball.x += 2.0
|
||||||
|
if rl/is-key-down(:key-left)
|
||||||
|
ball.x -= 2.0
|
||||||
|
if rl/is-key-down(:key-up)
|
||||||
|
ball.y -= 2.0
|
||||||
|
if rl/is-key-down(:key-down)
|
||||||
|
ball.y += 2.0
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/draw-text("move the ball with arrow keys", 10, 10, 20, rl/darkgray)
|
||||||
|
rl/draw-circle-v(ball, 50.0, rl/maroon)
|
||||||
@@ -10,45 +10,42 @@
|
|||||||
;;;; and the number half of that is now sayable: (string (i64->bytes n)).
|
;;;; and the number half of that is now sayable: (string (i64->bytes n)).
|
||||||
;;;; What is not is the "%03" — i64->bytes has no field width — so the label
|
;;;; What is not is the "%03" — i64->bytes has no field width — so the label
|
||||||
;;;; is drawn with draw-text and the number with draw-int-padded from
|
;;;; is drawn with draw-text and the number with draw-int-padded from
|
||||||
;;;; examples/digits.flan, which draws the leading zeroes itself and then the
|
;;;; examples/digits.fln, which draws the leading zeroes itself and then the
|
||||||
;;;; number in one call. A number wider than three digits is drawn in full,
|
;;;; number in one call. A number wider than three digits is drawn in full,
|
||||||
;;;; exactly as printf's minimum-width means.
|
;;;; exactly as printf's minimum-width means.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; The position is signed and goes negative as soon as the box scrolls past
|
;;;; The position is signed and goes negative as soon as the box scrolls past
|
||||||
;;;; the top, which is why draw-int-padded handles a sign at all.
|
;;;; the top, which is why draw-int-padded handles a sign at all.
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
import rl "vendor:raylib"
|
||||||
(import d "digits.flan")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
import d "digits.fln"
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defconst scroll-speed 4)
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
(defvar box-y i32)
|
const scroll-speed = 4
|
||||||
|
|
||||||
(defn main [] ()
|
once box-y: i32
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - input mouse wheel")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(set box-y (- (/ screen-height 2) 40))
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
(rl/set-target-fps 60)
|
"raylib [core] example - input mouse wheel")
|
||||||
|
defer rl/close-window()
|
||||||
(until (rl/window-should-close?)
|
box-y = screen-height / 2 - 40
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
;; Update. The wheel reading is a per-frame delta, so it is 0.0 on every
|
;; Update. The wheel reading is a per-frame delta, so it is 0.0 on every
|
||||||
;; frame the wheel did not turn and this is a no-op then.
|
;; frame the wheel did not turn and this is a no-op then.
|
||||||
(set box-y (- box-y (i32 (* (rl/get-mouse-wheel-move) (f32 scroll-speed)))))
|
box-y -= i32(rl/get-mouse-wheel-move() * f32(scroll-speed))
|
||||||
|
|
||||||
;; Draw
|
;; Draw
|
||||||
(rl/with-drawing
|
rl/with-drawing:
|
||||||
(rl/clear-background rl/raywhite)
|
rl/clear-background(rl/raywhite)
|
||||||
(rl/draw-rectangle (- (/ screen-width 2) 40) box-y 80 80 rl/maroon)
|
rl/draw-rectangle(screen-width / 2 - 40, box-y, 80, 80, rl/maroon)
|
||||||
(rl/draw-text "Use mouse wheel to move the cube up and down!" 10 10 20
|
rl/draw-text("Use mouse wheel to move the cube up and down!", 10, 10, 20,
|
||||||
rl/gray)
|
rl/gray)
|
||||||
;; The two halves of the C's one TextFormat call: the literal, measured,
|
;; The two halves of the C's one TextFormat call: the literal, measured,
|
||||||
;; and then the number starting where it ended.
|
;; and then the number starting where it ended.
|
||||||
(rl/draw-text "Box position Y: " 10 40 20 rl/lightgray)
|
rl/draw-text("Box position Y: ", 10, 40, 20, rl/lightgray)
|
||||||
(d/draw-int-padded box-y 3 (+ 10 (rl/measure-text "Box position Y: " 20))
|
d/draw-int-padded(box-y, 3, 10 + rl/measure-text("Box position Y: ", 20),
|
||||||
40 20 rl/lightgray))))
|
40, 20, rl/lightgray)
|
||||||
@@ -1,60 +0,0 @@
|
|||||||
;;;; raylib [core] example - input mouse
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_input_mouse.c. Needed three new bindings — show-cursor,
|
|
||||||
;;;; hide-cursor and cursor-hidden? — which are now in vendor/raylib.
|
|
||||||
;;;;
|
|
||||||
;;;; The C's `else if` chain over the seven mouse buttons is a `cond` here.
|
|
||||||
;;;; That is not a workaround: `cond` is what Flan has and it is the same
|
|
||||||
;;;; first-match-wins shape, with `:else` where C falls off the end. The order
|
|
||||||
;;;; matters in both — two buttons pressed on the same frame give the earlier
|
|
||||||
;;;; one, which is the C's behaviour and not an accident of the port.
|
|
||||||
;;;;
|
|
||||||
;;;; The colour has to be a `defvar` rather than a `let`, for the reason
|
|
||||||
;;;; core-input-keys' position does: it is state between frames.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defvar ball-color rl/Color)
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - input mouse")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
;; The C also initialises the ball's POSITION, to {-100,-100} so it starts
|
|
||||||
;; off-screen. That is dead there and is not here: the first thing the loop
|
|
||||||
;; does is overwrite it with get-mouse-position, before anything is drawn.
|
|
||||||
(set ball-color rl/darkblue)
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
|
||||||
(when (rl/key-pressed? :h)
|
|
||||||
(if (rl/cursor-hidden?) (rl/show-cursor) (rl/hide-cursor)))
|
|
||||||
|
|
||||||
(let [ball (rl/get-mouse-position)]
|
|
||||||
(set ball-color
|
|
||||||
(cond
|
|
||||||
(rl/mouse-button-pressed? :left) rl/maroon
|
|
||||||
(rl/mouse-button-pressed? :middle) rl/lime
|
|
||||||
(rl/mouse-button-pressed? :right) rl/darkblue
|
|
||||||
(rl/mouse-button-pressed? :side) rl/purple
|
|
||||||
(rl/mouse-button-pressed? :extra) rl/yellow
|
|
||||||
(rl/mouse-button-pressed? :forward) rl/orange
|
|
||||||
(rl/mouse-button-pressed? :back) rl/beige
|
|
||||||
:else ball-color))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
(rl/draw-circle-v ball 40.0 ball-color)
|
|
||||||
(rl/draw-text "move ball with mouse and click mouse button to change color"
|
|
||||||
10 10 20 rl/darkgray)
|
|
||||||
(rl/draw-text "Press 'H' to toggle cursor visibility" 10 30 20 rl/darkgray)
|
|
||||||
(if (rl/cursor-hidden?)
|
|
||||||
(rl/draw-text "CURSOR HIDDEN" 20 60 20 rl/red)
|
|
||||||
(rl/draw-text "CURSOR VISIBLE" 20 60 20 rl/lime))))))
|
|
||||||
@@ -0,0 +1,64 @@
|
|||||||
|
;;;; raylib [core] example - input mouse
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_input_mouse.c. Needed three new bindings — show-cursor,
|
||||||
|
;;;; hide-cursor and is-cursor-hidden — which are now in vendor/raylib.
|
||||||
|
;;;;
|
||||||
|
;;;; The C's `else if` chain over the seven mouse buttons is a `cond` here.
|
||||||
|
;;;; That is not a workaround: `cond` is what Flan has and it is the same
|
||||||
|
;;;; first-match-wins shape, with `:else` where C falls off the end. The order
|
||||||
|
;;;; matters in both — two buttons pressed on the same frame give the earlier
|
||||||
|
;;;; one, which is the C's behaviour and not an accident of the port.
|
||||||
|
;;;;
|
||||||
|
;;;; The colour has to be a `once` rather than a `let`, for the reason
|
||||||
|
;;;; core-input-keys' position does: it is state between frames.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
once ball-color: rl/Color
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - input mouse")
|
||||||
|
defer rl/close-window()
|
||||||
|
;; The C also initialises the ball's POSITION, to {-100,-100} so it starts
|
||||||
|
;; off-screen. That is dead there and is not here: the first thing the loop
|
||||||
|
;; does is overwrite it with get-mouse-position, before anything is drawn.
|
||||||
|
ball-color = rl/darkblue
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update
|
||||||
|
if rl/is-key-pressed(:key-h)
|
||||||
|
if rl/is-cursor-hidden() then rl/show-cursor() else rl/hide-cursor()
|
||||||
|
let ball = rl/get-mouse-position()
|
||||||
|
ball-color =
|
||||||
|
if rl/is-mouse-button-pressed(:mouse-left)
|
||||||
|
rl/maroon
|
||||||
|
elif rl/is-mouse-button-pressed(:mouse-middle)
|
||||||
|
rl/lime
|
||||||
|
elif rl/is-mouse-button-pressed(:mouse-right)
|
||||||
|
rl/darkblue
|
||||||
|
elif rl/is-mouse-button-pressed(:mouse-side)
|
||||||
|
rl/purple
|
||||||
|
elif rl/is-mouse-button-pressed(:mouse-extra)
|
||||||
|
rl/yellow
|
||||||
|
elif rl/is-mouse-button-pressed(:mouse-forward)
|
||||||
|
rl/orange
|
||||||
|
elif rl/is-mouse-button-pressed(:mouse-back)
|
||||||
|
rl/beige
|
||||||
|
else
|
||||||
|
ball-color
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/draw-circle-v(ball, 40.0, ball-color)
|
||||||
|
rl/draw-text("move ball with mouse and click mouse button to change color",
|
||||||
|
10, 10, 20, rl/darkgray)
|
||||||
|
rl/draw-text("Press 'H' to toggle cursor visibility", 10, 30, 20,
|
||||||
|
rl/darkgray)
|
||||||
|
if rl/is-cursor-hidden()
|
||||||
|
rl/draw-text("CURSOR HIDDEN", 20, 60, 20, rl/red)
|
||||||
|
else
|
||||||
|
rl/draw-text("CURSOR VISIBLE", 20, 60, 20, rl/lime)
|
||||||
@@ -1,68 +0,0 @@
|
|||||||
;;;; raylib [core] example - input multitouch
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_input_multitouch.c. No new bindings: the whole touch
|
|
||||||
;;;; surface was already there for sand.flan's read-out.
|
|
||||||
;;;;
|
|
||||||
;;;; The C keeps `Vector2 touchPositions[MAX_TOUCH_POINTS]`, and this is the
|
|
||||||
;;;; first example that needs a fixed array whose element type is a STRUCT
|
|
||||||
;;;; rather than a number. That works — `[10 rl/Vector2]` is ten Vector2s laid
|
|
||||||
;;;; out flat, no headers, and `(at touch-positions i)` is a place that can be
|
|
||||||
;;;; assigned a whole struct. Nothing in the repository used one before, so it
|
|
||||||
;;;; is worth saying that it does.
|
|
||||||
;;;;
|
|
||||||
;;;; It is a top-level `defvar` and not a local, which is NOT a stylistic
|
|
||||||
;;;; choice. A `let` binding takes no type annotation, so the only way to make
|
|
||||||
;;;; a fixed array inside a function is to initialise it from a literal with
|
|
||||||
;;;; every element written out — ten `(rl/Vector2 {.x 0.0 .y 0.0})`s here, and
|
|
||||||
;;;; thirty-two in the gestures testbed. A zeroed local array of a given type
|
|
||||||
;;;; cannot be spelled. Static storage is what the C's `= { 0 }` gets anyway.
|
|
||||||
;;;;
|
|
||||||
;;;; On a desktop with no touchscreen get-touch-point-count is 0 and this draws
|
|
||||||
;;;; nothing at all, which is correct and is also what the C does. The window
|
|
||||||
;;;; opening and the help text appearing is the whole of what can be checked
|
|
||||||
;;;; without hardware.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defconst max-touch-points 10)
|
|
||||||
|
|
||||||
(defvar touch-positions [max-touch-points rl/Vector2])
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - input multitouch")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
|
||||||
(let [count (min max-touch-points (rl/get-touch-point-count))]
|
|
||||||
(dotimes [i count]
|
|
||||||
(set (at touch-positions i) (rl/get-touch-position i)))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(dotimes [i count]
|
|
||||||
(let [p (at touch-positions i)]
|
|
||||||
;; raylib reports (0,0) for a slot that is not being touched, so the
|
|
||||||
;; C filters on it and so does this. It means a real touch in the
|
|
||||||
;; very top-left corner is dropped; that is raylib's ambiguity, not
|
|
||||||
;; something the port introduced.
|
|
||||||
(when (and (> (.x p) 0.0) (> (.y p) 0.0))
|
|
||||||
(rl/draw-circle-v p 34.0 rl/orange)
|
|
||||||
;; The C's TextFormat("%d", i). This used to need examples/digits.flan
|
|
||||||
;; and a table of one-character strings; (string b) makes the
|
|
||||||
;; number a string with no instructions, so it is one draw-text and
|
|
||||||
;; this file imports nothing but raylib.
|
|
||||||
(rl/draw-text (string (i64->bytes (i64 i)))
|
|
||||||
(- (i32 (.x p)) 10) (- (i32 (.y p)) 70) 40
|
|
||||||
rl/black))))
|
|
||||||
|
|
||||||
(rl/draw-text "touch the screen at multiple locations to get multiple balls"
|
|
||||||
10 10 20 rl/darkgray)))))
|
|
||||||
@@ -0,0 +1,65 @@
|
|||||||
|
;;;; raylib [core] example - input multitouch
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_input_multitouch.c. No new bindings: the whole touch
|
||||||
|
;;;; surface was already there for sand.fln's read-out.
|
||||||
|
;;;;
|
||||||
|
;;;; The C keeps `Vector2 touchPositions[MAX_TOUCH_POINTS]`, and this is the
|
||||||
|
;;;; first example that needs a fixed array whose element type is a STRUCT
|
||||||
|
;;;; rather than a number. That works — `[10 rl/Vector2]` is ten Vector2s laid
|
||||||
|
;;;; out flat, no headers, and `touch-positions[i]` is a place that can be
|
||||||
|
;;;; assigned a whole struct. Nothing in the repository used one before, so it
|
||||||
|
;;;; is worth saying that it does.
|
||||||
|
;;;;
|
||||||
|
;;;; It is a top-level `once` and not a local, which is NOT a stylistic
|
||||||
|
;;;; choice. A `let` binding takes no type annotation, so the only way to make
|
||||||
|
;;;; a fixed array inside a function is to initialise it from a literal with
|
||||||
|
;;;; every element written out — ten `rl/Vector2{.x 0.0 .y 0.0}`s here, and
|
||||||
|
;;;; thirty-two in the gestures testbed. A zeroed local array of a given type
|
||||||
|
;;;; cannot be spelled. Static storage is what the C's `= { 0 }` gets anyway.
|
||||||
|
;;;;
|
||||||
|
;;;; On a desktop with no touchscreen get-touch-point-count is 0 and this draws
|
||||||
|
;;;; nothing at all, which is correct and is also what the C does. The window
|
||||||
|
;;;; opening and the help text appearing is the whole of what can be checked
|
||||||
|
;;;; without hardware.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
const max-touch-points = 10
|
||||||
|
|
||||||
|
once touch-positions: [max-touch-points rl/Vector2]
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - input multitouch")
|
||||||
|
defer rl/close-window()
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update
|
||||||
|
let count = min(max-touch-points, rl/get-touch-point-count())
|
||||||
|
for i in 0..count
|
||||||
|
touch-positions[i] = rl/get-touch-position(i)
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
for i in 0..count
|
||||||
|
let p = touch-positions[i]
|
||||||
|
;; raylib reports (0,0) for a slot that is not being touched, so the
|
||||||
|
;; C filters on it and so does this. It means a real touch in the
|
||||||
|
;; very top-left corner is dropped; that is raylib's ambiguity, not
|
||||||
|
;; something the port introduced.
|
||||||
|
if p.x > 0.0 and p.y > 0.0
|
||||||
|
rl/draw-circle-v(p, 34.0, rl/orange)
|
||||||
|
;; The C's TextFormat("%d", i). This used to need examples/digits.fln
|
||||||
|
;; and a table of one-character strings; (string b) makes the
|
||||||
|
;; number a string with no instructions, so it is one draw-text and
|
||||||
|
;; this file imports nothing but raylib.
|
||||||
|
rl/draw-text(str(i64->bytes(i64(i))), i32(p.x) - 10, i32(p.y) - 70,
|
||||||
|
40, rl/black)
|
||||||
|
rl/draw-text("touch the screen at multiple locations to get multiple balls",
|
||||||
|
10, 10, 20, rl/darkgray)
|
||||||
|
;; The numbers drawn this frame were formatted into the temp allocator;
|
||||||
|
;; this hands that memory back once the frame is drawn.
|
||||||
|
free-temp()
|
||||||
@@ -1,193 +0,0 @@
|
|||||||
;;;; raylib [core] example - input virtual controls
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_input_virtual_controls.c. No new bindings.
|
|
||||||
;;;;
|
|
||||||
;;;; Split the way sand.flan is split: everything above the second banner is
|
|
||||||
;;;; arithmetic with no raylib calls in it, so test/programs/virtual-controls-
|
|
||||||
;;;; headless.flan can import this file as a package, drive the pointer over a
|
|
||||||
;;;; scripted path and hash where the player ended up. That is the only one of
|
|
||||||
;;;; the ten examples with a headless half, and it has one because it is the
|
|
||||||
;;;; only one whose interesting part — which D-pad button is under the pointer,
|
|
||||||
;;;; and what that does to the player — is a function of numbers rather than of
|
|
||||||
;;;; a frame buffer. The link follows what the program reaches, so the headless
|
|
||||||
;;;; driver pulls in neither a window nor libraylib.
|
|
||||||
;;;;
|
|
||||||
;;;; Two language notes, both visible below.
|
|
||||||
;;;;
|
|
||||||
;;;; **No `break`.** The C's nearest-button search is
|
|
||||||
;;;;
|
|
||||||
;;;; for (i = 0; i < BUTTON_MAX; i++) { if (...) { pressedButton = i; break; } }
|
|
||||||
;;;;
|
|
||||||
;;;; and `(break)` is refused: "break is not implemented yet (see the build
|
|
||||||
;;;; sequence in plan.org)". `return` from the function works and is what this
|
|
||||||
;;;; uses — which is why the search is its own `defn` and not written inline
|
|
||||||
;;;; the way the C has it. That is not a loss: the function is the thing the
|
|
||||||
;;;; headless case wants to call anyway. Where a loop genuinely cannot be a
|
|
||||||
;;;; function, the shape left is a flag and a compound loop condition.
|
|
||||||
;;;;
|
|
||||||
;;;; **No `fabsf`.** The prelude has sqrt-f32 and sign-f32 but no absolute
|
|
||||||
;;;; value for floats, and the comment there says why for integers. `(max v
|
|
||||||
;;;; (- 0.0 v))` is it, and unlike the integer case it has no edge: there is no
|
|
||||||
;;;; float whose negation is itself except -0.0, whose absolute value is 0.0
|
|
||||||
;;;; either way.
|
|
||||||
;;;;
|
|
||||||
;;;; The button geometry is `defconst` arrays of struct literals. That works —
|
|
||||||
;;;; and it is the only way a fixed array can be made inside anything but a
|
|
||||||
;;;; top-level `defvar`, since a `let` binding takes no type annotation.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
;; The C's PadButton enum. -1 is BUTTON_NONE and the four directions are 0..3,
|
|
||||||
;; in the order the arrays below are written. A `defenum` would not help: the
|
|
||||||
;; value is used as an index and an enum does not convert to an integer
|
|
||||||
;; ("i32 converts a number, found ..."), so it would have to be turned back
|
|
||||||
;; into one at every use.
|
|
||||||
(defconst button-none -1)
|
|
||||||
(defconst button-up 0)
|
|
||||||
(defconst button-left 1)
|
|
||||||
(defconst button-right 2)
|
|
||||||
(defconst button-down 3)
|
|
||||||
(defconst button-max 4)
|
|
||||||
|
|
||||||
(defconst button-radius f32 30.0)
|
|
||||||
|
|
||||||
;; padPosition is {100, 350} and the buttons sit a radius and a half away from
|
|
||||||
;; it on each axis. The C computes these at run time from padPosition; they are
|
|
||||||
;; written out here because a defconst is compile-time and the numbers are.
|
|
||||||
(defconst button-positions [button-max rl/Vector2]
|
|
||||||
[(rl/Vector2 {.x 100.0 .y 305.0}) ; up
|
|
||||||
(rl/Vector2 {.x 55.0 .y 350.0}) ; left
|
|
||||||
(rl/Vector2 {.x 145.0 .y 350.0}) ; right
|
|
||||||
(rl/Vector2 {.x 100.0 .y 395.0})]) ; down
|
|
||||||
|
|
||||||
(defconst player-speed f32 75.0)
|
|
||||||
|
|
||||||
;;;; ── The part with no raylib in it ──────────────────────────────────
|
|
||||||
|
|
||||||
(defvar player rl/Vector2)
|
|
||||||
|
|
||||||
(defn reset-player [] ()
|
|
||||||
(set player (rl/Vector2 {.x (/ (f32 screen-width) 2.0)
|
|
||||||
.y (/ (f32 screen-height) 2.0)})))
|
|
||||||
|
|
||||||
(defn abs-f32 [v f32] f32
|
|
||||||
(max v (- 0.0 v)))
|
|
||||||
|
|
||||||
;; The C's search, with `return` where it had `break`. Manhattan distance and
|
|
||||||
;; not Euclidean — the C adds the two axis distances and compares against the
|
|
||||||
;; radius — so the hit area is a diamond, which is deliberate: it makes the
|
|
||||||
;; four buttons tile without overlapping.
|
|
||||||
(defn nearest-button [pos rl/Vector2] i32
|
|
||||||
(dotimes [i button-max]
|
|
||||||
(let [b (at button-positions i)
|
|
||||||
dist-x (abs-f32 (- (.x b) (.x pos)))
|
|
||||||
dist-y (abs-f32 (- (.y b) (.y pos)))]
|
|
||||||
(when (< (+ dist-x dist-y) button-radius)
|
|
||||||
(return i))))
|
|
||||||
button-none)
|
|
||||||
|
|
||||||
;; The C's switch on the pressed button. Nothing moves for button-none, which
|
|
||||||
;; is the `default: break`.
|
|
||||||
(defn move-player [button i32 dt f32] ()
|
|
||||||
(let [step (* player-speed dt)]
|
|
||||||
(cond
|
|
||||||
(= button button-up) (set (.y player) (- (.y player) step))
|
|
||||||
(= button button-left) (set (.x player) (- (.x player) step))
|
|
||||||
(= button button-right) (set (.x player) (+ (.x player) step))
|
|
||||||
(= button button-down) (set (.y player) (+ (.y player) step))
|
|
||||||
:else (do))))
|
|
||||||
|
|
||||||
;; FNV-1a over the player's two floats, so the headless driver has one number
|
|
||||||
;; to compare. The floats are read through their bit patterns rather than
|
|
||||||
;; rounded to integers: rounding would hide exactly the kind of drift — a
|
|
||||||
;; crossed x and y, a step applied twice — the case exists to catch.
|
|
||||||
(defconst fnv-offset u64 0xcbf29ce484222325)
|
|
||||||
(defconst fnv-prime u64 1099511628211)
|
|
||||||
|
|
||||||
(defn hash-f32 [h u64 v f32] u64
|
|
||||||
;; No float-to-bits cast in the language, so the value is scaled and
|
|
||||||
;; truncated instead. 1024 keeps three decimal places of a screen
|
|
||||||
;; coordinate, which is finer than any real difference between two correct
|
|
||||||
;; runs and coarser than the last bit of an f32 — so this is reproducible
|
|
||||||
;; across targets where a raw bit pattern would depend on the FPU.
|
|
||||||
(let [n (i64 (* v 1024.0))
|
|
||||||
g h]
|
|
||||||
(dotimes [b 8]
|
|
||||||
(set g (bit-xor g (u64 (bit-and (>> n (i64 (* b 8))) 255))))
|
|
||||||
(set g (* g fnv-prime)))
|
|
||||||
g))
|
|
||||||
|
|
||||||
(defn hash-player [] u64
|
|
||||||
(hash-f32 (hash-f32 fnv-offset (.x player)) (.y player)))
|
|
||||||
|
|
||||||
;;;; ── The raylib front-end ───────────────────────────────────────────
|
|
||||||
|
|
||||||
;; The arrowheads, one triangle of three points per button, in the winding
|
|
||||||
;; raylib wants — counter-clockwise, or it culls them and draws nothing. A
|
|
||||||
;; [4 [3 rl/Vector2]]: a fixed array of fixed arrays of a struct, which is the
|
|
||||||
;; deepest shape any of these ten examples asks for and which works.
|
|
||||||
(defconst arrow-tris [button-max [3 rl/Vector2]]
|
|
||||||
[[(rl/Vector2 {.x 100.0 .y 293.0})
|
|
||||||
(rl/Vector2 {.x 91.0 .y 314.0})
|
|
||||||
(rl/Vector2 {.x 109.0 .y 314.0})]
|
|
||||||
[(rl/Vector2 {.x 64.0 .y 341.0})
|
|
||||||
(rl/Vector2 {.x 43.0 .y 350.0})
|
|
||||||
(rl/Vector2 {.x 64.0 .y 359.0})]
|
|
||||||
[(rl/Vector2 {.x 157.0 .y 350.0})
|
|
||||||
(rl/Vector2 {.x 136.0 .y 341.0})
|
|
||||||
(rl/Vector2 {.x 136.0 .y 359.0})]
|
|
||||||
[(rl/Vector2 {.x 91.0 .y 386.0})
|
|
||||||
(rl/Vector2 {.x 100.0 .y 407.0})
|
|
||||||
(rl/Vector2 {.x 109.0 .y 386.0})]])
|
|
||||||
|
|
||||||
(defconst label-colors [button-max rl/Color]
|
|
||||||
[(rl/Color {.r 253 .g 249 .b 0 .a 255}) ; yellow, up
|
|
||||||
(rl/Color {.r 0 .g 121 .b 241 .a 255}) ; blue, left
|
|
||||||
(rl/Color {.r 230 .g 41 .b 55 .a 255}) ; red, right
|
|
||||||
(rl/Color {.r 0 .g 228 .b 48 .a 255})]) ; green, down
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - input virtual controls")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(reset-player)
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update. Touch first, mouse as the desktop stand-in — and on the desktop
|
|
||||||
;; the left button has to be held, or the player would follow the cursor
|
|
||||||
;; wherever it went.
|
|
||||||
(let [touching (> (rl/get-touch-point-count) 0)
|
|
||||||
input (if touching
|
|
||||||
(rl/get-touch-position 0)
|
|
||||||
(rl/get-mouse-position))
|
|
||||||
pressed (if (or touching (rl/mouse-button-down? :left))
|
|
||||||
(nearest-button input)
|
|
||||||
button-none)]
|
|
||||||
|
|
||||||
(move-player pressed (rl/get-frame-time))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(rl/draw-circle-v player 50.0 rl/maroon)
|
|
||||||
|
|
||||||
(dotimes [i button-max]
|
|
||||||
(rl/draw-circle-v (at button-positions i) button-radius
|
|
||||||
(if (= i pressed) rl/darkgray rl/black))
|
|
||||||
(let [t (at arrow-tris i)]
|
|
||||||
(rl/draw-triangle (at t 0) (at t 1) (at t 2)
|
|
||||||
(at label-colors i))))
|
|
||||||
|
|
||||||
(rl/draw-text "move the player with D-Pad buttons" 10 10 20 rl/darkgray)
|
|
||||||
;; Not in the C: which button the search picked, as a number, so the
|
|
||||||
;; headless case and the window agree about the same thing.
|
|
||||||
(rl/draw-text "button: " 10 34 20 rl/lightgray)
|
|
||||||
(rl/draw-text (string (i64->bytes (i64 pressed)))
|
|
||||||
(+ 10 (rl/measure-text "button: " 20)) 34 20
|
|
||||||
rl/lightgray)))))
|
|
||||||
@@ -0,0 +1,185 @@
|
|||||||
|
;;;; raylib [core] example - input virtual controls
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_input_virtual_controls.c. No new bindings.
|
||||||
|
;;;;
|
||||||
|
;;;; Split the way sand.fln is split: everything above the second banner is
|
||||||
|
;;;; arithmetic with no raylib calls in it, so test/programs/virtual-controls-
|
||||||
|
;;;; headless.flan can import this file as a package, drive the pointer over a
|
||||||
|
;;;; scripted path and hash where the player ended up. That is the only one of
|
||||||
|
;;;; the ten examples with a headless half, and it has one because it is the
|
||||||
|
;;;; only one whose interesting part — which D-pad button is under the pointer,
|
||||||
|
;;;; and what that does to the player — is a function of numbers rather than of
|
||||||
|
;;;; a frame buffer. The link follows what the program reaches, so the headless
|
||||||
|
;;;; driver pulls in neither a window nor libraylib.
|
||||||
|
;;;;
|
||||||
|
;;;; Two language notes, both visible below.
|
||||||
|
;;;;
|
||||||
|
;;;; **No `break`.** The C's nearest-button search is
|
||||||
|
;;;;
|
||||||
|
;;;; for (i = 0; i < BUTTON_MAX; i++) { if (...) { pressedButton = i; break; } }
|
||||||
|
;;;;
|
||||||
|
;;;; and `break()` is refused: "break is not implemented yet (see the build
|
||||||
|
;;;; sequence in plan.org)". `return` from the function works and is what this
|
||||||
|
;;;; uses — which is why the search is its own `defn` and not written inline
|
||||||
|
;;;; the way the C has it. That is not a loss: the function is the thing the
|
||||||
|
;;;; headless case wants to call anyway. Where a loop genuinely cannot be a
|
||||||
|
;;;; function, the shape left is a flag and a compound loop condition.
|
||||||
|
;;;;
|
||||||
|
;;;; **No `fabsf`.** The prelude has sqrt-f32 and sign-f32 but no absolute
|
||||||
|
;;;; value for floats, and the comment there says why for integers.
|
||||||
|
;;;; `max(v, 0.0 - v)` is it, and unlike the integer case it has no edge: there
|
||||||
|
;;;; is no float whose negation is itself except -0.0, whose absolute value is
|
||||||
|
;;;; 0.0 either way.
|
||||||
|
;;;;
|
||||||
|
;;;; The button geometry is `const` arrays of struct literals. That works —
|
||||||
|
;;;; and it is the only way a fixed array can be made inside anything but a
|
||||||
|
;;;; top-level `once`, since a `let` binding takes no type annotation.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
;; The C's PadButton enum. -1 is BUTTON_NONE and the four directions are 0..3,
|
||||||
|
;; in the order the arrays below are written. An `enum` would not help: the
|
||||||
|
;; value is used as an index and an enum does not convert to an integer
|
||||||
|
;; ("i32 converts a number, found ..."), so it would have to be turned back
|
||||||
|
;; into one at every use.
|
||||||
|
const button-none = -1
|
||||||
|
const button-up = 0
|
||||||
|
const button-left = 1
|
||||||
|
const button-right = 2
|
||||||
|
const button-down = 3
|
||||||
|
const button-max = 4
|
||||||
|
|
||||||
|
const button-radius: f32 = 30.0
|
||||||
|
|
||||||
|
;; padPosition is {100, 350} and the buttons sit a radius and a half away from
|
||||||
|
;; it on each axis. The C computes these at run time from padPosition; they are
|
||||||
|
;; written out here because a const is compile-time and the numbers are.
|
||||||
|
const button-positions: [button-max rl/Vector2] = [rl/Vector2{.x 100.0 .y 305.0} ; up
|
||||||
|
; left
|
||||||
|
; right
|
||||||
|
; down
|
||||||
|
rl/Vector2{.x 55.0 .y 350.0}
|
||||||
|
rl/Vector2{.x 145.0 .y 350.0}
|
||||||
|
rl/Vector2{.x 100.0 .y 395.0}]
|
||||||
|
|
||||||
|
const player-speed: f32 = 75.0
|
||||||
|
|
||||||
|
;;;; ── The part with no raylib in it ──────────────────────────────────
|
||||||
|
|
||||||
|
once player: rl/Vector2
|
||||||
|
|
||||||
|
fn reset-player() -> ()
|
||||||
|
player = rl/Vector2{.x f32(screen-width) / 2.0, .y f32(screen-height) / 2.0}
|
||||||
|
|
||||||
|
fn abs-f32(v: f32) -> f32 = max(v, 0.0 - v)
|
||||||
|
|
||||||
|
;; The C's search, with `return` where it had `break`. Manhattan distance and
|
||||||
|
;; not Euclidean — the C adds the two axis distances and compares against the
|
||||||
|
;; radius — so the hit area is a diamond, which is deliberate: it makes the
|
||||||
|
;; four buttons tile without overlapping.
|
||||||
|
fn nearest-button(pos: rl/Vector2) -> i32
|
||||||
|
for i in 0..button-max
|
||||||
|
let b = button-positions[i]
|
||||||
|
dist-x = abs-f32(b.x - pos.x)
|
||||||
|
dist-y = abs-f32(b.y - pos.y)
|
||||||
|
if dist-x + dist-y < button-radius
|
||||||
|
return i
|
||||||
|
button-none
|
||||||
|
|
||||||
|
;; The C's switch on the pressed button. Nothing moves for button-none, which
|
||||||
|
;; is the `default: break`.
|
||||||
|
fn move-player(button: i32, dt: f32) -> ()
|
||||||
|
let step = player-speed * dt
|
||||||
|
if button == button-up
|
||||||
|
player.y -= step
|
||||||
|
elif button == button-left
|
||||||
|
player.x -= step
|
||||||
|
elif button == button-right
|
||||||
|
player.x += step
|
||||||
|
elif button == button-down
|
||||||
|
player.y += step
|
||||||
|
else
|
||||||
|
()
|
||||||
|
|
||||||
|
;; FNV-1a over the player's two floats, so the headless driver has one number
|
||||||
|
;; to compare. The floats are read through their bit patterns rather than
|
||||||
|
;; rounded to integers: rounding would hide exactly the kind of drift — a
|
||||||
|
;; crossed x and y, a step applied twice — the case exists to catch.
|
||||||
|
const fnv-offset: u64 = 0xcbf29ce484222325
|
||||||
|
const fnv-prime: u64 = 1099511628211
|
||||||
|
|
||||||
|
fn hash-f32(h: u64, v: f32) -> u64
|
||||||
|
;; No float-to-bits cast in the language, so the value is scaled and
|
||||||
|
;; truncated instead. 1024 keeps three decimal places of a screen
|
||||||
|
;; coordinate, which is finer than any real difference between two correct
|
||||||
|
;; runs and coarser than the last bit of an f32 — so this is reproducible
|
||||||
|
;; across targets where a raw bit pattern would depend on the FPU.
|
||||||
|
let n = i64(v * 1024.0)
|
||||||
|
g = h
|
||||||
|
for b in 0..8
|
||||||
|
g = g ^ u64(n >> i64(b * 8) & 255)
|
||||||
|
g *%= fnv-prime
|
||||||
|
g
|
||||||
|
|
||||||
|
fn hash-player() -> u64 = hash-f32(hash-f32(fnv-offset, player.x), player.y)
|
||||||
|
|
||||||
|
;;;; ── The raylib front-end ───────────────────────────────────────────
|
||||||
|
|
||||||
|
;; The arrowheads, one triangle of three points per button, in the winding
|
||||||
|
;; raylib wants — counter-clockwise, or it culls them and draws nothing. A
|
||||||
|
;; [4 [3 rl/Vector2]]: a fixed array of fixed arrays of a struct, which is the
|
||||||
|
;; deepest shape any of these ten examples asks for and which works.
|
||||||
|
const arrow-tris: [button-max [3 rl/Vector2]] = [[rl/Vector2{.x 100.0 .y 293.0} rl/Vector2{.x 91.0 .y 314.0} rl/Vector2{.x 109.0 .y 314.0}]
|
||||||
|
[rl/Vector2{.x 64.0 .y 341.0} rl/Vector2{.x 43.0 .y 350.0} rl/Vector2{.x 64.0 .y 359.0}]
|
||||||
|
[rl/Vector2{.x 157.0 .y 350.0} rl/Vector2{.x 136.0 .y 341.0} rl/Vector2{.x 136.0 .y 359.0}]
|
||||||
|
[rl/Vector2{.x 91.0 .y 386.0} rl/Vector2{.x 100.0 .y 407.0} rl/Vector2{.x 109.0 .y 386.0}]]
|
||||||
|
|
||||||
|
const label-colors: [button-max rl/Color] = [rl/Color{.r 253 .g 249 .b 0 .a 255} ; yellow, up
|
||||||
|
; blue, left
|
||||||
|
; red, right
|
||||||
|
; green, down
|
||||||
|
rl/Color{.r 0 .g 121 .b 241 .a 255}
|
||||||
|
rl/Color{.r 230 .g 41 .b 55 .a 255}
|
||||||
|
rl/Color{.r 0 .g 228 .b 48 .a 255}]
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - input virtual controls")
|
||||||
|
defer rl/close-window()
|
||||||
|
reset-player()
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update. Touch first, mouse as the desktop stand-in — and on the desktop
|
||||||
|
;; the left button has to be held, or the player would follow the cursor
|
||||||
|
;; wherever it went.
|
||||||
|
let touching = rl/get-touch-point-count() > 0
|
||||||
|
let input =
|
||||||
|
if touching then rl/get-touch-position(0) else rl/get-mouse-position()
|
||||||
|
let pressed =
|
||||||
|
if touching or rl/is-mouse-button-down(:mouse-left)
|
||||||
|
nearest-button(input)
|
||||||
|
else
|
||||||
|
button-none
|
||||||
|
move-player(pressed, rl/get-frame-time())
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/draw-circle-v(player, 50.0, rl/maroon)
|
||||||
|
for i in 0..button-max
|
||||||
|
rl/draw-circle-v(button-positions[i], button-radius,
|
||||||
|
if i == pressed then rl/darkgray else rl/black)
|
||||||
|
let t = arrow-tris[i]
|
||||||
|
rl/draw-triangle(t[0], t[1], t[2], label-colors[i])
|
||||||
|
rl/draw-text("move the player with D-Pad buttons", 10, 10, 20,
|
||||||
|
rl/darkgray)
|
||||||
|
;; Not in the C: which button the search picked, as a number, so the
|
||||||
|
;; headless case and the window agree about the same thing.
|
||||||
|
rl/draw-text("button: ", 10, 34, 20, rl/lightgray)
|
||||||
|
rl/draw-text(str(i64->bytes(i64(pressed))),
|
||||||
|
10 + rl/measure-text("button: ", 20), 34, 20, rl/lightgray)
|
||||||
|
;; The number drawn this frame was formatted into the temp allocator;
|
||||||
|
;; this hands that memory back once the frame is drawn.
|
||||||
|
free-temp()
|
||||||
@@ -1,8 +1,8 @@
|
|||||||
;;;; raylib [core] example - scissor test
|
;;;; raylib [core] example - scissor test
|
||||||
;;;;
|
;;;;
|
||||||
;;;; examples/core/core_scissor_test.c. Needed begin-scissor-mode and
|
;;;; examples/core/core_scissor_test.c. Needed begin-scissor-mode and
|
||||||
;;;; end-scissor-mode, now hand-written in vendor/raylib/raylib.flan: they are
|
;;;; end-scissor-mode, now hand-written in vendor/raylib/raylib.fln: they are
|
||||||
;;;; a begin/end pair inside a frame, which is the class PORTING.md §1 says
|
;;;; a begin/end pair inside a frame, which is the class docs/PORTING.md §1 says
|
||||||
;;;; belongs in the hand-written half and not in the importer's. get-mouse-x
|
;;;; belongs in the hand-written half and not in the importer's. get-mouse-x
|
||||||
;;;; and get-mouse-y come from the generated half — their Flan face is the C
|
;;;; and get-mouse-y come from the generated half — their Flan face is the C
|
||||||
;;;; one, two plain i32s, and there is nothing for a hand-written line to say
|
;;;; one, two plain i32s, and there is nothing for a hand-written line to say
|
||||||
@@ -24,47 +24,41 @@
|
|||||||
;;;; place — so the only check is the outline drawn around it afterwards
|
;;;; place — so the only check is the outline drawn around it afterwards
|
||||||
;;;; landing on the revealed patch.
|
;;;; landing on the revealed patch.
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
(defconst screen-width 800)
|
const screen-width = 800
|
||||||
(defconst screen-height 450)
|
const screen-height = 450
|
||||||
|
|
||||||
(defvar scissor rl/Rectangle)
|
once scissor: rl/Rectangle
|
||||||
(defvar scissor-mode bool)
|
once scissor-mode: bool
|
||||||
|
|
||||||
(defn main [] ()
|
fn main() -> ()
|
||||||
(rl/init-window screen-width screen-height
|
rl/init-window(screen-width, screen-height,
|
||||||
"raylib [core] example - scissor test")
|
"raylib [core] example - scissor test")
|
||||||
(defer (rl/close-window))
|
defer rl/close-window()
|
||||||
|
scissor = rl/Rectangle{.x 0.0 .y 0.0 .width 300.0 .height 300.0}
|
||||||
(set scissor (rl/Rectangle {.x 0.0 .y 0.0 .width 300.0 .height 300.0}))
|
scissor-mode = true
|
||||||
(set scissor-mode true)
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
;; Update
|
||||||
(when (rl/key-pressed? :s) (set scissor-mode (not scissor-mode)))
|
if rl/is-key-pressed(:key-s)
|
||||||
|
scissor-mode = not scissor-mode
|
||||||
;; Centre the scissor area on the mouse.
|
;; Centre the scissor area on the mouse.
|
||||||
(set (.x scissor) (- (f32 (rl/get-mouse-x)) (/ (.width scissor) 2.0)))
|
scissor.x = f32(rl/get-mouse-x()) - scissor.width / 2.0
|
||||||
(set (.y scissor) (- (f32 (rl/get-mouse-y)) (/ (.height scissor) 2.0)))
|
scissor.y = f32(rl/get-mouse-y()) - scissor.height / 2.0
|
||||||
|
|
||||||
;; Draw
|
;; Draw
|
||||||
(rl/with-drawing
|
rl/with-drawing:
|
||||||
(rl/clear-background rl/raywhite)
|
rl/clear-background(rl/raywhite)
|
||||||
|
if scissor-mode
|
||||||
(when scissor-mode
|
rl/begin-scissor-mode(i32(scissor.x), i32(scissor.y),
|
||||||
(rl/begin-scissor-mode (i32 (.x scissor)) (i32 (.y scissor))
|
i32(scissor.width), i32(scissor.height))
|
||||||
(i32 (.width scissor)) (i32 (.height scissor))))
|
|
||||||
|
|
||||||
;; A full-screen rectangle and a line of text. Only the part inside the
|
;; A full-screen rectangle and a line of text. Only the part inside the
|
||||||
;; scissor rectangle reaches the framebuffer, which is the whole example.
|
;; scissor rectangle reaches the framebuffer, which is the whole example.
|
||||||
(rl/draw-rectangle 0 0 (rl/get-screen-width) (rl/get-screen-height) rl/red)
|
rl/draw-rectangle(0, 0, rl/get-screen-width(), rl/get-screen-height(),
|
||||||
(rl/draw-text "Move the mouse around to reveal this text!" 190 200 20
|
rl/red)
|
||||||
rl/lightgray)
|
rl/draw-text("Move the mouse around to reveal this text!", 190, 200, 20,
|
||||||
|
rl/lightgray)
|
||||||
(when scissor-mode (rl/end-scissor-mode))
|
if scissor-mode
|
||||||
|
rl/end-scissor-mode()
|
||||||
(rl/draw-rectangle-lines-ex scissor 1.0 rl/black)
|
rl/draw-rectangle-lines-ex(scissor, 1.0, rl/black)
|
||||||
(rl/draw-text "Press S to toggle scissor test" 10 10 20 rl/black))))
|
rl/draw-text("Press S to toggle scissor test", 10, 10, 20, rl/black)
|
||||||
@@ -1,177 +0,0 @@
|
|||||||
;;;; raylib [core] example - window flags
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_window_flags.c. The reason to port this one is the
|
|
||||||
;;;; flags themselves: raylib.flan carried four of ConfigFlags' sixteen
|
|
||||||
;;;; members — the four sand.flan sets before the window exists — and this
|
|
||||||
;;;; example reads and writes eleven of them after it exists. All sixteen are
|
|
||||||
;;;; in raylib.flan now, read off raylib.h 5.5, in the header's order and not
|
|
||||||
;;;; in bit order (FLAG_VSYNC_HINT is 0x40 and FLAG_FULLSCREEN_MODE is 0x02,
|
|
||||||
;;;; which is the kind of thing nobody remembers correctly).
|
|
||||||
;;;;
|
|
||||||
;;;; They are `defconst u32`s and not a `defenum` for the reason the file
|
|
||||||
;;;; already gives about gestures: raylib wants the OR of several and a
|
|
||||||
;;;; keyword can only ever name one member.
|
|
||||||
;;;;
|
|
||||||
;;;; window-state?, set-window-state, clear-window-state, toggle-fullscreen,
|
|
||||||
;;;; minimize-window, maximize-window and restore-window all come from the
|
|
||||||
;;;; generated half. That is the line drawn in vendor/raylib/bindings and it
|
|
||||||
;;;; is worth saying why it falls here: the rule in PORTING.md §1 exists so
|
|
||||||
;;;; that a build with no header set can still draw, and generated.flan is
|
|
||||||
;;;; committed, so it can. What a hand-written line adds on top of that is a
|
|
||||||
;;;; Flan face the C signature does not have — a Key instead of an int, a
|
|
||||||
;;;; (Ptr Camera3D) instead of a raw pointer — and these seven have no such
|
|
||||||
;;;; face to add. They are u32 in and bool out in both languages.
|
|
||||||
;;;;
|
|
||||||
;;;; Not faithful in one place, deliberately: the C draws twelve lines of
|
|
||||||
;;;; on/off state through TextFormat and a two-branch if each time. Flan has
|
|
||||||
;;;; no TextFormat, so the pair is one helper here — which also removes the
|
|
||||||
;;;; C's own copy-paste bug, where the UNFOCUSED line says "[G]" when it is on
|
|
||||||
;;;; and "[U]" when it is off.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
(import d "digits.flan")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
;; Frames the window has been hidden or minimized for. H and N both put the
|
|
||||||
;; window somewhere it cannot be typed at, so the only way back is a count.
|
|
||||||
(defconst restore-after 240)
|
|
||||||
|
|
||||||
(defvar ball-pos rl/Vector2)
|
|
||||||
(defvar ball-speed rl/Vector2)
|
|
||||||
(defvar frames i32)
|
|
||||||
|
|
||||||
(defconst ball-radius f32 20.0)
|
|
||||||
|
|
||||||
;; One line of the state list: the label, then "on" or "off" in lime or
|
|
||||||
;; maroon, at the x the label ended. The C writes two whole DrawText calls per
|
|
||||||
;; flag with the text repeated; this says it once.
|
|
||||||
(defn draw-flag [label string flag u32 y i32] ()
|
|
||||||
(rl/draw-text label 10 y 10 rl/gray)
|
|
||||||
(let [x (+ 10 (rl/measure-text label 10))]
|
|
||||||
(if (rl/window-state? flag)
|
|
||||||
(rl/draw-text " on" x y 10 rl/lime)
|
|
||||||
(rl/draw-text " off" x y 10 rl/maroon))))
|
|
||||||
|
|
||||||
;; A flag the program owns: pressing the key turns it off if it is on and on
|
|
||||||
;; if it is off. Nine of the C's eleven key handlers are exactly this.
|
|
||||||
(defn toggle-flag [flag u32] ()
|
|
||||||
(if (rl/window-state? flag)
|
|
||||||
(rl/clear-window-state flag)
|
|
||||||
(rl/set-window-state flag)))
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
;; The C leaves its SetConfigFlags call commented out, so that every flag
|
|
||||||
;; the list shows starts off. Kept that way: the point of the example is
|
|
||||||
;; which of them can be changed afterwards.
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - window flags")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(set ball-pos (rl/Vector2 {.x (/ (f32 (rl/get-screen-width)) 2.0)
|
|
||||||
.y (/ (f32 (rl/get-screen-height)) 2.0)}))
|
|
||||||
(set ball-speed (rl/Vector2 {.x 5.0 .y 4.0}))
|
|
||||||
|
|
||||||
;; No set-target-fps, as in the C: with FLAG_VSYNC_HINT among the flags the
|
|
||||||
;; example toggles, a frame limiter on top of it would hide what V-Sync
|
|
||||||
;; does to the number draw-fps reports.
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
|
||||||
(when (rl/key-pressed? :f) (rl/toggle-fullscreen))
|
|
||||||
(when (rl/key-pressed? :r) (toggle-flag rl/flag-window-resizable))
|
|
||||||
(when (rl/key-pressed? :d) (toggle-flag rl/flag-window-undecorated))
|
|
||||||
(when (rl/key-pressed? :u) (toggle-flag rl/flag-window-unfocused))
|
|
||||||
(when (rl/key-pressed? :t) (toggle-flag rl/flag-window-topmost))
|
|
||||||
(when (rl/key-pressed? :a) (toggle-flag rl/flag-window-always-run))
|
|
||||||
(when (rl/key-pressed? :v) (toggle-flag rl/flag-vsync-hint))
|
|
||||||
|
|
||||||
;; Hidden and minimized are not toggles: the window they hide is also the
|
|
||||||
;; window the key would have to be pressed in, so each comes back on a
|
|
||||||
;; timer instead.
|
|
||||||
(when (rl/key-pressed? :h)
|
|
||||||
(unless (rl/window-state? rl/flag-window-hidden)
|
|
||||||
(rl/set-window-state rl/flag-window-hidden))
|
|
||||||
(set frames 0))
|
|
||||||
|
|
||||||
(when (rl/window-state? rl/flag-window-hidden)
|
|
||||||
(set frames (+ frames 1))
|
|
||||||
(when (>= frames restore-after)
|
|
||||||
(rl/clear-window-state rl/flag-window-hidden)))
|
|
||||||
|
|
||||||
(when (rl/key-pressed? :n)
|
|
||||||
(unless (rl/window-state? rl/flag-window-minimized)
|
|
||||||
(rl/minimize-window))
|
|
||||||
(set frames 0))
|
|
||||||
|
|
||||||
(when (rl/window-state? rl/flag-window-minimized)
|
|
||||||
(set frames (+ frames 1))
|
|
||||||
(when (>= frames restore-after) (rl/restore-window)))
|
|
||||||
|
|
||||||
;; Maximize needs FLAG_WINDOW_RESIZABLE first, which is what R is for.
|
|
||||||
(when (rl/key-pressed? :m)
|
|
||||||
(if (rl/window-state? rl/flag-window-maximized)
|
|
||||||
(rl/restore-window)
|
|
||||||
(rl/maximize-window)))
|
|
||||||
|
|
||||||
;; The ball bounces off whatever the window is right now, so resizing,
|
|
||||||
;; maximizing and going fullscreen all show up in its path.
|
|
||||||
(set (.x ball-pos) (+ (.x ball-pos) (.x ball-speed)))
|
|
||||||
(set (.y ball-pos) (+ (.y ball-pos) (.y ball-speed)))
|
|
||||||
(when (or (>= (.x ball-pos) (- (f32 (rl/get-screen-width)) ball-radius))
|
|
||||||
(<= (.x ball-pos) ball-radius))
|
|
||||||
(set (.x ball-speed) (* (.x ball-speed) -1.0)))
|
|
||||||
(when (or (>= (.y ball-pos) (- (f32 (rl/get-screen-height)) ball-radius))
|
|
||||||
(<= (.y ball-pos) ball-radius))
|
|
||||||
(set (.y ball-speed) (* (.y ball-speed) -1.0)))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
|
|
||||||
;; A transparent framebuffer wants a transparent clear; anything else
|
|
||||||
;; paints over the desktop the flag exists to show.
|
|
||||||
(if (rl/window-state? rl/flag-window-transparent)
|
|
||||||
(rl/clear-background rl/blank)
|
|
||||||
(rl/clear-background rl/raywhite))
|
|
||||||
|
|
||||||
(rl/draw-circle-v ball-pos ball-radius rl/maroon)
|
|
||||||
(rl/draw-rectangle-lines-ex
|
|
||||||
(rl/Rectangle {.x 0.0 .y 0.0
|
|
||||||
.width (f32 (rl/get-screen-width))
|
|
||||||
.height (f32 (rl/get-screen-height))})
|
|
||||||
4.0 rl/raywhite)
|
|
||||||
|
|
||||||
(rl/draw-circle-v (rl/get-mouse-position) 10.0 rl/darkblue)
|
|
||||||
|
|
||||||
(rl/draw-fps 10 10)
|
|
||||||
|
|
||||||
;; The C's TextFormat("Screen Size: [%i, %i]", ...), reassembled out of
|
|
||||||
;; literals and examples/digits.flan the way the other ports do it: `x`
|
|
||||||
;; walks along the line, and draw-int hands back the width it drew.
|
|
||||||
(let [x 10]
|
|
||||||
(rl/draw-text "Screen Size: [" x 40 10 rl/green)
|
|
||||||
(set x (+ x (rl/measure-text "Screen Size: [" 10)))
|
|
||||||
(set x (+ x (d/draw-int (rl/get-screen-width) x 40 10 rl/green)))
|
|
||||||
(rl/draw-text ", " x 40 10 rl/green)
|
|
||||||
(set x (+ x (rl/measure-text ", " 10)))
|
|
||||||
(set x (+ x (d/draw-int (rl/get-screen-height) x 40 10 rl/green)))
|
|
||||||
(rl/draw-text "]" x 40 10 rl/green))
|
|
||||||
(rl/draw-text "Following flags can be set after window creation:"
|
|
||||||
10 60 10 rl/gray)
|
|
||||||
(draw-flag "[F] FLAG_FULLSCREEN_MODE:" rl/flag-fullscreen-mode 80)
|
|
||||||
(draw-flag "[R] FLAG_WINDOW_RESIZABLE:" rl/flag-window-resizable 100)
|
|
||||||
(draw-flag "[D] FLAG_WINDOW_UNDECORATED:" rl/flag-window-undecorated 120)
|
|
||||||
(draw-flag "[H] FLAG_WINDOW_HIDDEN:" rl/flag-window-hidden 140)
|
|
||||||
(draw-flag "[N] FLAG_WINDOW_MINIMIZED:" rl/flag-window-minimized 160)
|
|
||||||
(draw-flag "[M] FLAG_WINDOW_MAXIMIZED:" rl/flag-window-maximized 180)
|
|
||||||
(draw-flag "[U] FLAG_WINDOW_UNFOCUSED:" rl/flag-window-unfocused 200)
|
|
||||||
(draw-flag "[T] FLAG_WINDOW_TOPMOST:" rl/flag-window-topmost 220)
|
|
||||||
(draw-flag "[A] FLAG_WINDOW_ALWAYS_RUN:" rl/flag-window-always-run 240)
|
|
||||||
(draw-flag "[V] FLAG_VSYNC_HINT:" rl/flag-vsync-hint 260)
|
|
||||||
|
|
||||||
(rl/draw-text "Following flags can only be set before window creation:"
|
|
||||||
10 300 10 rl/gray)
|
|
||||||
(draw-flag "FLAG_WINDOW_HIGHDPI:" rl/flag-window-highdpi 320)
|
|
||||||
(draw-flag "FLAG_WINDOW_TRANSPARENT:" rl/flag-window-transparent 340)
|
|
||||||
(draw-flag "FLAG_MSAA_4X_HINT:" rl/flag-msaa-4x-hint 360))))
|
|
||||||
@@ -0,0 +1,168 @@
|
|||||||
|
;;;; raylib [core] example - window flags
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_window_flags.c. The reason to port this one is the
|
||||||
|
;;;; flags themselves: raylib.fln carried four of ConfigFlags' sixteen
|
||||||
|
;;;; members — the four sand.fln sets before the window exists — and this
|
||||||
|
;;;; example reads and writes eleven of them after it exists. All sixteen are
|
||||||
|
;;;; in raylib.fln now, read off raylib.h 5.5, in the header's order and not
|
||||||
|
;;;; in bit order (FLAG_VSYNC_HINT is 0x40 and FLAG_FULLSCREEN_MODE is 0x02,
|
||||||
|
;;;; which is the kind of thing nobody remembers correctly).
|
||||||
|
;;;;
|
||||||
|
;;;; They are `const u32`s and not an `enum` for the reason the file
|
||||||
|
;;;; already gives about gestures: raylib wants the OR of several and a
|
||||||
|
;;;; keyword can only ever name one member.
|
||||||
|
;;;;
|
||||||
|
;;;; is-window-state, set-window-state, clear-window-state, toggle-fullscreen,
|
||||||
|
;;;; minimize-window, maximize-window and restore-window all come from the
|
||||||
|
;;;; generated half. That is the line drawn in vendor/raylib/bindings and it
|
||||||
|
;;;; is worth saying why it falls here: the rule in docs/PORTING.md §1 exists so
|
||||||
|
;;;; that a build with no header set can still draw, and generated.fln is
|
||||||
|
;;;; committed, so it can. What a hand-written line adds on top of that is a
|
||||||
|
;;;; Flan face the C signature does not have — a Key instead of an int, a
|
||||||
|
;;;; (Ptr Camera3D) instead of a raw pointer — and these seven have no such
|
||||||
|
;;;; face to add. They are u32 in and bool out in both languages.
|
||||||
|
;;;;
|
||||||
|
;;;; Not faithful in one place, deliberately: the C draws twelve lines of
|
||||||
|
;;;; on/off state through TextFormat and a two-branch if each time. Flan has
|
||||||
|
;;;; no TextFormat, so the pair is one helper here — which also removes the
|
||||||
|
;;;; C's own copy-paste bug, where the UNFOCUSED line says "[G]" when it is on
|
||||||
|
;;;; and "[U]" when it is off.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
import d "digits.fln"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
;; Frames the window has been hidden or minimized for. H and N both put the
|
||||||
|
;; window somewhere it cannot be typed at, so the only way back is a count.
|
||||||
|
const restore-after = 240
|
||||||
|
|
||||||
|
once ball-pos: rl/Vector2
|
||||||
|
once ball-speed: rl/Vector2
|
||||||
|
once frames: i32
|
||||||
|
|
||||||
|
const ball-radius: f32 = 20.0
|
||||||
|
|
||||||
|
;; One line of the state list: the label, then "on" or "off" in lime or
|
||||||
|
;; maroon, at the x the label ended. The C writes two whole DrawText calls per
|
||||||
|
;; flag with the text repeated; this says it once.
|
||||||
|
fn draw-flag(label: str, flag: u32, y: i32) -> ()
|
||||||
|
rl/draw-text(label, 10, y, 10, rl/gray)
|
||||||
|
let x = 10 + rl/measure-text(label, 10)
|
||||||
|
if rl/is-window-state(flag)
|
||||||
|
rl/draw-text(" on", x, y, 10, rl/lime)
|
||||||
|
else
|
||||||
|
rl/draw-text(" off", x, y, 10, rl/maroon)
|
||||||
|
|
||||||
|
;; A flag the program owns: pressing the key turns it off if it is on and on
|
||||||
|
;; if it is off. Nine of the C's eleven key handlers are exactly this.
|
||||||
|
fn toggle-flag(flag: u32) -> ()
|
||||||
|
if rl/is-window-state(flag)
|
||||||
|
rl/clear-window-state(flag)
|
||||||
|
else
|
||||||
|
rl/set-window-state(flag)
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
;; The C leaves its SetConfigFlags call commented out, so that every flag
|
||||||
|
;; the list shows starts off. Kept that way: the point of the example is
|
||||||
|
;; which of them can be changed afterwards.
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - window flags")
|
||||||
|
defer rl/close-window()
|
||||||
|
ball-pos = rl/Vector2{.x f32(rl/get-screen-width()) / 2.0, .y f32(rl/get-screen-height()) / 2.0}
|
||||||
|
ball-speed = rl/Vector2{.x 5.0 .y 4.0}
|
||||||
|
;; No set-target-fps, as in the C: with FLAG_VSYNC_HINT among the flags the
|
||||||
|
;; example toggles, a frame limiter on top of it would hide what V-Sync
|
||||||
|
;; does to the number draw-fps reports.
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update
|
||||||
|
if rl/is-key-pressed(:key-f)
|
||||||
|
rl/toggle-fullscreen()
|
||||||
|
if rl/is-key-pressed(:key-r)
|
||||||
|
toggle-flag(rl/flag-window-resizable)
|
||||||
|
if rl/is-key-pressed(:key-d)
|
||||||
|
toggle-flag(rl/flag-window-undecorated)
|
||||||
|
if rl/is-key-pressed(:key-u)
|
||||||
|
toggle-flag(rl/flag-window-unfocused)
|
||||||
|
if rl/is-key-pressed(:key-t)
|
||||||
|
toggle-flag(rl/flag-window-topmost)
|
||||||
|
if rl/is-key-pressed(:key-a)
|
||||||
|
toggle-flag(rl/flag-window-always-run)
|
||||||
|
if rl/is-key-pressed(:key-v)
|
||||||
|
toggle-flag(rl/flag-vsync-hint)
|
||||||
|
;; Hidden and minimized are not toggles: the window they hide is also the
|
||||||
|
;; window the key would have to be pressed in, so each comes back on a
|
||||||
|
;; timer instead.
|
||||||
|
if rl/is-key-pressed(:key-h)
|
||||||
|
unless(rl/is-window-state(rl/flag-window-hidden)):
|
||||||
|
rl/set-window-state(rl/flag-window-hidden)
|
||||||
|
frames = 0
|
||||||
|
if rl/is-window-state(rl/flag-window-hidden)
|
||||||
|
frames += 1
|
||||||
|
if frames >= restore-after
|
||||||
|
rl/clear-window-state(rl/flag-window-hidden)
|
||||||
|
if rl/is-key-pressed(:key-n)
|
||||||
|
unless(rl/is-window-state(rl/flag-window-minimized)):
|
||||||
|
rl/minimize-window()
|
||||||
|
frames = 0
|
||||||
|
if rl/is-window-state(rl/flag-window-minimized)
|
||||||
|
frames += 1
|
||||||
|
if frames >= restore-after
|
||||||
|
rl/restore-window()
|
||||||
|
;; Maximize needs FLAG_WINDOW_RESIZABLE first, which is what R is for.
|
||||||
|
if rl/is-key-pressed(:key-m)
|
||||||
|
if rl/is-window-state(rl/flag-window-maximized)
|
||||||
|
rl/restore-window()
|
||||||
|
else
|
||||||
|
rl/maximize-window()
|
||||||
|
;; The ball bounces off whatever the window is right now, so resizing,
|
||||||
|
;; maximizing and going fullscreen all show up in its path.
|
||||||
|
ball-pos.x += ball-speed.x
|
||||||
|
ball-pos.y += ball-speed.y
|
||||||
|
if ball-pos.x >= f32(rl/get-screen-width()) - ball-radius or ball-pos.x <= ball-radius
|
||||||
|
ball-speed.x *= -1.0
|
||||||
|
if ball-pos.y >= f32(rl/get-screen-height()) - ball-radius or ball-pos.y <= ball-radius
|
||||||
|
ball-speed.y *= -1.0
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
;; A transparent framebuffer wants a transparent clear; anything else
|
||||||
|
;; paints over the desktop the flag exists to show.
|
||||||
|
if rl/is-window-state(rl/flag-window-transparent)
|
||||||
|
rl/clear-background(rl/blank)
|
||||||
|
else
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/draw-circle-v(ball-pos, ball-radius, rl/maroon)
|
||||||
|
rl/draw-rectangle-lines-ex(rl/Rectangle{.x 0.0 .y 0.0 .width f32(rl/get-screen-width()) .height f32(rl/get-screen-height())},
|
||||||
|
4.0, rl/raywhite)
|
||||||
|
rl/draw-circle-v(rl/get-mouse-position(), 10.0, rl/darkblue)
|
||||||
|
rl/draw-fps(10, 10)
|
||||||
|
;; The C's TextFormat("Screen Size: [%i, %i]", ...), reassembled out of
|
||||||
|
;; literals and examples/digits.fln the way the other ports do it: `x`
|
||||||
|
;; walks along the line, and draw-int hands back the width it drew.
|
||||||
|
let x = 10
|
||||||
|
rl/draw-text("Screen Size: [", x, 40, 10, rl/green)
|
||||||
|
x += rl/measure-text("Screen Size: [", 10)
|
||||||
|
x += d/draw-int(rl/get-screen-width(), x, 40, 10, rl/green)
|
||||||
|
rl/draw-text(", ", x, 40, 10, rl/green)
|
||||||
|
x += rl/measure-text(", ", 10)
|
||||||
|
x += d/draw-int(rl/get-screen-height(), x, 40, 10, rl/green)
|
||||||
|
rl/draw-text("]", x, 40, 10, rl/green)
|
||||||
|
rl/draw-text("Following flags can be set after window creation:", 10, 60,
|
||||||
|
10, rl/gray)
|
||||||
|
draw-flag("[F] FLAG_FULLSCREEN_MODE:", rl/flag-fullscreen-mode, 80)
|
||||||
|
draw-flag("[R] FLAG_WINDOW_RESIZABLE:", rl/flag-window-resizable, 100)
|
||||||
|
draw-flag("[D] FLAG_WINDOW_UNDECORATED:", rl/flag-window-undecorated, 120)
|
||||||
|
draw-flag("[H] FLAG_WINDOW_HIDDEN:", rl/flag-window-hidden, 140)
|
||||||
|
draw-flag("[N] FLAG_WINDOW_MINIMIZED:", rl/flag-window-minimized, 160)
|
||||||
|
draw-flag("[M] FLAG_WINDOW_MAXIMIZED:", rl/flag-window-maximized, 180)
|
||||||
|
draw-flag("[U] FLAG_WINDOW_UNFOCUSED:", rl/flag-window-unfocused, 200)
|
||||||
|
draw-flag("[T] FLAG_WINDOW_TOPMOST:", rl/flag-window-topmost, 220)
|
||||||
|
draw-flag("[A] FLAG_WINDOW_ALWAYS_RUN:", rl/flag-window-always-run, 240)
|
||||||
|
draw-flag("[V] FLAG_VSYNC_HINT:", rl/flag-vsync-hint, 260)
|
||||||
|
rl/draw-text("Following flags can only be set before window creation:",
|
||||||
|
10, 300, 10, rl/gray)
|
||||||
|
draw-flag("FLAG_WINDOW_HIGHDPI:", rl/flag-window-highdpi, 320)
|
||||||
|
draw-flag("FLAG_WINDOW_TRANSPARENT:", rl/flag-window-transparent, 340)
|
||||||
|
draw-flag("FLAG_MSAA_4X_HINT:", rl/flag-msaa-4x-hint, 360)
|
||||||
@@ -1,66 +0,0 @@
|
|||||||
;;;; raylib [core] example - window should close
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_window_should_close.c. Needed set-exit-key, and one
|
|
||||||
;;;; enum member to go with it: raylib.flan's `Key` now has `null 0`, read off
|
|
||||||
;;;; KEY_NULL in raylib.h. The binding is hand-written rather than taken from
|
|
||||||
;;;; the generated half because the Flan face differs — raylib declares
|
|
||||||
;;;; `void SetExitKey(int key)` and the generated line therefore takes an i32,
|
|
||||||
;;;; where this one takes a Key, so `(rl/set-exit-key :null)` is checked
|
|
||||||
;;;; against the enum and `:nul` is a compile error instead of a 0.
|
|
||||||
;;;;
|
|
||||||
;;;; The whole example is about what window-should-close? means. It is not a
|
|
||||||
;;;; flag raylib latches: it is "the close button was clicked, or the exit key
|
|
||||||
;;;; is down", recomputed each frame, and it goes back to false on its own.
|
|
||||||
;;;; That is what lets this program ask for confirmation and then carry on —
|
|
||||||
;;;; and it is also why the loop is driven by a `defvar` of its own rather
|
|
||||||
;;;; than by the predicate, which is the one structural difference from every
|
|
||||||
;;;; other example in this directory.
|
|
||||||
;;;;
|
|
||||||
;;;; `(set-exit-key :null)` takes ESC away from raylib so the program can read
|
|
||||||
;;;; it itself. The window's X button still works and is still what
|
|
||||||
;;;; window-should-close? reports.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defvar exit-requested bool)
|
|
||||||
(defvar exiting bool)
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - window should close")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
;; No key closes the window any more. ESC is an ordinary key from here on.
|
|
||||||
(rl/set-exit-key :null)
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until exiting
|
|
||||||
;; Update. Either way of asking to leave raises the question; only Y and N
|
|
||||||
;; answer it. window-should-close? is false again on the next frame, so
|
|
||||||
;; the request has to be remembered in a variable.
|
|
||||||
(when (or (rl/window-should-close?) (rl/key-pressed? :escape))
|
|
||||||
(set exit-requested true))
|
|
||||||
|
|
||||||
;; The C's `if (Y) ... else if (N) ...`, which is an `if` with a `when`
|
|
||||||
;; in its else and not a `cond`: a `cond` needs an `:else` arm and there
|
|
||||||
;; is nothing to do when neither key was pressed.
|
|
||||||
(when exit-requested
|
|
||||||
(if (rl/key-pressed? :y)
|
|
||||||
(set exiting true)
|
|
||||||
(when (rl/key-pressed? :n) (set exit-requested false))))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(if exit-requested
|
|
||||||
(do
|
|
||||||
(rl/draw-rectangle 0 100 screen-width 200 rl/black)
|
|
||||||
(rl/draw-text "Are you sure you want to exit program? [Y/N]" 40 180 30
|
|
||||||
rl/white))
|
|
||||||
(rl/draw-text "Try to close the window to get confirmation message!"
|
|
||||||
120 200 20 rl/lightgray)))))
|
|
||||||
@@ -0,0 +1,61 @@
|
|||||||
|
;;;; raylib [core] example - window should close
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_window_should_close.c. Needed set-exit-key, and one
|
||||||
|
;;;; enum member to go with it: raylib.fln's `Key` now has `null 0`, read off
|
||||||
|
;;;; KEY_NULL in raylib.h. The binding is hand-written rather than taken from
|
||||||
|
;;;; the generated half because the Flan face differs — raylib declares
|
||||||
|
;;;; `void SetExitKey(int key)` and the generated line therefore takes an i32,
|
||||||
|
;;;; where this one takes a Key, so `rl/set-exit-key(:key-null)` is checked
|
||||||
|
;;;; against the enum and `:nul` is a compile error instead of a 0.
|
||||||
|
;;;;
|
||||||
|
;;;; The whole example is about what window-should-close means. It is not a
|
||||||
|
;;;; flag raylib latches: it is "the close button was clicked, or the exit key
|
||||||
|
;;;; is down", recomputed each frame, and it goes back to false on its own.
|
||||||
|
;;;; That is what lets this program ask for confirmation and then carry on —
|
||||||
|
;;;; and it is also why the loop is driven by a `once` of its own rather
|
||||||
|
;;;; than by the predicate, which is the one structural difference from every
|
||||||
|
;;;; other example in this directory.
|
||||||
|
;;;;
|
||||||
|
;;;; `set-exit-key(:null)` takes ESC away from raylib so the program can read
|
||||||
|
;;;; it itself. The window's X button still works and is still what
|
||||||
|
;;;; window-should-close reports.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
once exit-requested: bool
|
||||||
|
once exiting: bool
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - window should close")
|
||||||
|
defer rl/close-window()
|
||||||
|
;; No key closes the window any more. ESC is an ordinary key from here on.
|
||||||
|
rl/set-exit-key(:key-null)
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until exiting
|
||||||
|
;; Update. Either way of asking to leave raises the question; only Y and N
|
||||||
|
;; answer it. window-should-close is false again on the next frame, so
|
||||||
|
;; the request has to be remembered in a variable.
|
||||||
|
if rl/window-should-close() or rl/is-key-pressed(:key-escape)
|
||||||
|
exit-requested = true
|
||||||
|
;; The C's `if (Y) ... else if (N) ...`, which is an `if` with a `when`
|
||||||
|
;; in its else and not a `cond`: a `cond` needs an `:else` arm and there
|
||||||
|
;; is nothing to do when neither key was pressed.
|
||||||
|
if exit-requested
|
||||||
|
if rl/is-key-pressed(:key-y)
|
||||||
|
exiting = true
|
||||||
|
elif rl/is-key-pressed(:key-n)
|
||||||
|
exit-requested = false
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
if exit-requested
|
||||||
|
rl/draw-rectangle(0, 100, screen-width, 200, rl/black)
|
||||||
|
rl/draw-text("Are you sure you want to exit program? [Y/N]", 40, 180,
|
||||||
|
30, rl/white)
|
||||||
|
else
|
||||||
|
rl/draw-text("Try to close the window to get confirmation message!",
|
||||||
|
120, 200, 20, rl/lightgray)
|
||||||
@@ -1,111 +0,0 @@
|
|||||||
;;;; raylib [core] example - world to screen
|
|
||||||
;;;;
|
|
||||||
;;;; examples/core/core_world_screen.c, and the first thing in this directory
|
|
||||||
;;;; to draw in 3D at all. That is why it is here: before it, vendor/raylib
|
|
||||||
;;;; described no Vector3, no Camera3D and not one call that takes either, so
|
|
||||||
;;;; the importer refused every 3D function in raylib.h by name — "Vector3 is
|
|
||||||
;;;; a struct the package does not describe". Two defstructs later it refuses
|
|
||||||
;;;; none of them, and the generated half grew the cubes, spheres, cylinders
|
|
||||||
;;;; and billboards along with the eight lines this example needs.
|
|
||||||
;;;;
|
|
||||||
;;;; Hand-written in raylib.flan rather than generated, and why each:
|
|
||||||
;;;;
|
|
||||||
;;;; begin-mode-3d / end-mode-3d a begin/end pair inside a frame, the
|
|
||||||
;;;; class PORTING.md §1 names, and taken
|
|
||||||
;;;; together the way begin-mode-2d is
|
|
||||||
;;;; draw-cube / draw-cube-wires / draw-grid drawn every frame
|
|
||||||
;;;; update-camera the Flan face differs: (Ptr Camera3D),
|
|
||||||
;;;; because it mutates, and a CameraMode
|
|
||||||
;;;; rather than the header's int
|
|
||||||
;;;; get-world-to-screen it reads the same camera as the mode
|
|
||||||
;;;;
|
|
||||||
;;;; What is NOT pinned by anything, and cannot be: Camera3D's first three
|
|
||||||
;;;; fields are all Vector3, so every permutation of position, target and up
|
|
||||||
;;;; has the identical layout and no computed test can tell them apart. A
|
|
||||||
;;;; camera looking from the wrong place is a picture, not a number. The same
|
|
||||||
;;;; is true of Vector3's own x, y and z. Only the screen catches those.
|
|
||||||
;;;;
|
|
||||||
;;;; update-camera in :third-person mode also takes the mouse, which is why
|
|
||||||
;;;; the C calls DisableCursor: the cursor is locked to the window and its
|
|
||||||
;;;; movement becomes camera rotation rather than a pointer. disable-cursor
|
|
||||||
;;;; comes from the generated half — it is called once, before the loop.
|
|
||||||
;;;;
|
|
||||||
;;;; The C's two TextFormats go through examples/digits.flan, as in the other
|
|
||||||
;;;; ports, because Flan has no TextFormat and i64->bytes has no field width.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
(import d "digits.flan")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defvar camera rl/Camera3D)
|
|
||||||
(defvar cube rl/Vector3)
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [core] example - core world screen")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
;; `projection` is a CameraProjection, so the keyword resolves against the
|
|
||||||
;; enum's members right here and a misspelt projection is a compile error
|
|
||||||
;; rather than a 0. raylib's field is `int` and the layout is unchanged —
|
|
||||||
;; an enum is four bytes either way.
|
|
||||||
(set camera
|
|
||||||
(rl/Camera3D {.position (rl/Vector3 {.x 10.0 .y 10.0 .z 10.0})
|
|
||||||
.target (rl/Vector3 {.x 0.0 .y 0.0 .z 0.0})
|
|
||||||
.up (rl/Vector3 {.x 0.0 .y 1.0 .z 0.0})
|
|
||||||
.fovy 45.0
|
|
||||||
.projection :perspective}))
|
|
||||||
|
|
||||||
(set cube (rl/Vector3 {.x 0.0 .y 0.0 .z 0.0}))
|
|
||||||
|
|
||||||
;; The mouse becomes the camera's, not a pointer's.
|
|
||||||
(rl/disable-cursor)
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update. The camera is passed by address because update-camera writes
|
|
||||||
;; to it — a global is an assignable place, so it has an address to take.
|
|
||||||
(rl/update-camera (addr camera) :third-person)
|
|
||||||
|
|
||||||
;; Where the point 2.5 units above the cube lands on the screen. This is
|
|
||||||
;; the whole example: the same transform raylib is about to draw with,
|
|
||||||
;; asked in advance, so a label can be put on a thing in the world.
|
|
||||||
(let [label-pos (rl/get-world-to-screen
|
|
||||||
(rl/Vector3 {.x (.x cube)
|
|
||||||
.y (+ (.y cube) 2.5)
|
|
||||||
.z (.z cube)})
|
|
||||||
camera)]
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(rl/with-mode-3d camera
|
|
||||||
(rl/draw-cube cube 2.0 2.0 2.0 rl/red)
|
|
||||||
(rl/draw-cube-wires cube 2.0 2.0 2.0 rl/maroon)
|
|
||||||
(rl/draw-grid 10 1.0))
|
|
||||||
|
|
||||||
;; And the 2D half, drawn after end-mode-3d and therefore on top of the
|
|
||||||
;; cube whatever the depth buffer says — which is the second half of
|
|
||||||
;; what the example demonstrates.
|
|
||||||
(rl/draw-text "Enemy: 100 / 100"
|
|
||||||
(- (i32 (.x label-pos))
|
|
||||||
(/ (rl/measure-text "Enemy: 100/100" 20) 2))
|
|
||||||
(i32 (.y label-pos)) 20 rl/black)
|
|
||||||
|
|
||||||
(let [x 10]
|
|
||||||
(rl/draw-text "Cube position in screen space coordinates: [" x 10 20
|
|
||||||
rl/lime)
|
|
||||||
(set x (+ x (rl/measure-text
|
|
||||||
"Cube position in screen space coordinates: [" 20)))
|
|
||||||
(set x (+ x (d/draw-int (i32 (.x label-pos)) x 10 20 rl/lime)))
|
|
||||||
(rl/draw-text ", " x 10 20 rl/lime)
|
|
||||||
(set x (+ x (rl/measure-text ", " 20)))
|
|
||||||
(set x (+ x (d/draw-int (i32 (.y label-pos)) x 10 20 rl/lime)))
|
|
||||||
(rl/draw-text "]" x 10 20 rl/lime))
|
|
||||||
|
|
||||||
(rl/draw-text "Text 2d should be always on top of the cube" 10 40 20
|
|
||||||
rl/gray)))))
|
|
||||||
@@ -0,0 +1,91 @@
|
|||||||
|
;;;; raylib [core] example - world to screen
|
||||||
|
;;;;
|
||||||
|
;;;; examples/core/core_world_screen.c, and the first thing in this directory
|
||||||
|
;;;; to draw in 3D at all. That is why it is here: before it, vendor/raylib
|
||||||
|
;;;; described no Vector3, no Camera3D and not one call that takes either, so
|
||||||
|
;;;; the importer refused every 3D function in raylib.h by name — "Vector3 is
|
||||||
|
;;;; a struct the package does not describe". Two defstructs later it refuses
|
||||||
|
;;;; none of them, and the generated half grew the cubes, spheres, cylinders
|
||||||
|
;;;; and billboards along with the eight lines this example needs.
|
||||||
|
;;;;
|
||||||
|
;;;; Hand-written in raylib.fln rather than generated, and why each:
|
||||||
|
;;;;
|
||||||
|
;;;; begin-mode-3d / end-mode-3d a begin/end pair inside a frame, the
|
||||||
|
;;;; class docs/PORTING.md §1 names, and taken
|
||||||
|
;;;; together the way begin-mode-2d is
|
||||||
|
;;;; draw-cube / draw-cube-wires / draw-grid drawn every frame
|
||||||
|
;;;; update-camera the Flan face differs: (Ptr Camera3D),
|
||||||
|
;;;; because it mutates, and a CameraMode
|
||||||
|
;;;; rather than the header's int
|
||||||
|
;;;; get-world-to-screen it reads the same camera as the mode
|
||||||
|
;;;;
|
||||||
|
;;;; What is NOT pinned by anything, and cannot be: Camera3D's first three
|
||||||
|
;;;; fields are all Vector3, so every permutation of position, target and up
|
||||||
|
;;;; has the identical layout and no computed test can tell them apart. A
|
||||||
|
;;;; camera looking from the wrong place is a picture, not a number. The same
|
||||||
|
;;;; is true of Vector3's own x, y and z. Only the screen catches those.
|
||||||
|
;;;;
|
||||||
|
;;;; update-camera in :camera-third-person mode also takes the mouse, which
|
||||||
|
;;;; is why the C calls DisableCursor: the cursor is locked to the window and
|
||||||
|
;;;; its movement becomes camera rotation rather than a pointer. disable-cursor
|
||||||
|
;;;; comes from the generated half — it is called once, before the loop.
|
||||||
|
;;;;
|
||||||
|
;;;; The C's two TextFormats go through examples/digits.fln, as in the other
|
||||||
|
;;;; ports, because Flan has no TextFormat and i64->bytes has no field width.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
import d "digits.fln"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
once camera: rl/Camera3D
|
||||||
|
once cube: rl/Vector3
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [core] example - core world screen")
|
||||||
|
defer rl/close-window()
|
||||||
|
;; `projection` is a CameraProjection, so the keyword resolves against the
|
||||||
|
;; enum's members right here and a misspelt projection is a compile error
|
||||||
|
;; rather than a 0. raylib's field is `int` and the layout is unchanged —
|
||||||
|
;; an enum is four bytes either way.
|
||||||
|
camera = rl/Camera3D{.position rl/Vector3{.x 10.0 .y 10.0 .z 10.0} .target rl/Vector3{.x 0.0 .y 0.0 .z 0.0} .up rl/Vector3{.x 0.0 .y 1.0 .z 0.0} .fovy 45.0 .projection :projection-perspective}
|
||||||
|
cube = rl/Vector3{.x 0.0 .y 0.0 .z 0.0}
|
||||||
|
;; The mouse becomes the camera's, not a pointer's.
|
||||||
|
rl/disable-cursor()
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update. The camera is passed by address because update-camera writes
|
||||||
|
;; to it — a global is an assignable place, so it has an address to take.
|
||||||
|
rl/update-camera(addr(camera), :camera-third-person)
|
||||||
|
;; Where the point 2.5 units above the cube lands on the screen. This is
|
||||||
|
;; the whole example: the same transform raylib is about to draw with,
|
||||||
|
;; asked in advance, so a label can be put on a thing in the world.
|
||||||
|
let label-pos = rl/get-world-to-screen(rl/Vector3{.x cube.x, .y cube.y + 2.5, .z cube.z},
|
||||||
|
camera)
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/with-mode-3d(camera):
|
||||||
|
rl/draw-cube(cube, 2.0, 2.0, 2.0, rl/red)
|
||||||
|
rl/draw-cube-wires(cube, 2.0, 2.0, 2.0, rl/maroon)
|
||||||
|
rl/draw-grid(10, 1.0)
|
||||||
|
;; And the 2D half, drawn after end-mode-3d and therefore on top of the
|
||||||
|
;; cube whatever the depth buffer says — which is the second half of
|
||||||
|
;; what the example demonstrates.
|
||||||
|
rl/draw-text("Enemy: 100 / 100",
|
||||||
|
i32(label-pos.x) - rl/measure-text("Enemy: 100/100", 20) / 2,
|
||||||
|
i32(label-pos.y), 20, rl/black)
|
||||||
|
let x = 10
|
||||||
|
rl/draw-text("Cube position in screen space coordinates: [", x, 10, 20,
|
||||||
|
rl/lime)
|
||||||
|
x += rl/measure-text("Cube position in screen space coordinates: [", 20)
|
||||||
|
x += d/draw-int(i32(label-pos.x), x, 10, 20, rl/lime)
|
||||||
|
rl/draw-text(", ", x, 10, 20, rl/lime)
|
||||||
|
x += rl/measure-text(", ", 20)
|
||||||
|
x += d/draw-int(i32(label-pos.y), x, 10, 20, rl/lime)
|
||||||
|
rl/draw-text("]", x, 10, 20, rl/lime)
|
||||||
|
rl/draw-text("Text 2d should be always on top of the cube", 10, 40, 20,
|
||||||
|
rl/gray)
|
||||||
@@ -7,12 +7,12 @@
|
|||||||
;;;; allocator to build one in. So a number was drawn one glyph at a time out
|
;;;; allocator to build one in. So a number was drawn one glyph at a time out
|
||||||
;;;; of a `[10 string]` table.
|
;;;; of a `[10 string]` table.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; `(string b)` closed that. It is the mirror of `(bytes s)` and costs no
|
;;;; `string(b)` closed that. It is the mirror of `bytes-view(s)` and costs no
|
||||||
;;;; instructions — a `string` and a `[u8]` are the same 16-byte %slice — so
|
;;;; instructions — a `string` and a `[u8]` are the same 16-byte %slice — so
|
||||||
;;;; `(string (i64->bytes n))` draws in one call and the table, the per-glyph
|
;;;; `string(i64->bytes(n))` draws in one call and the table, the per-glyph
|
||||||
;;;; pen and the digit arithmetic behind them are gone.
|
;;;; pen and the digit arithmetic behind them are gone.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; What is left is the part `(string ...)` does not answer, which is
|
;;;; What is left is the part `string(...)` does not answer, which is
|
||||||
;;;; *formatting*: `i64->bytes` has no field width, so "%03i" still has to be
|
;;;; *formatting*: `i64->bytes` has no field width, so "%03i" still has to be
|
||||||
;;;; assembled, and `f64->bytes` is `%g` and not "%.02f", so a fixed number of
|
;;;; assembled, and `f64->bytes` is `%g` and not "%.02f", so a fixed number of
|
||||||
;;;; decimal places still has to be split and drawn in two pieces. Those two
|
;;;; decimal places still has to be split and drawn in two pieces. Those two
|
||||||
@@ -24,23 +24,20 @@
|
|||||||
;;;; a `char *` into a rotating static buffer, which `declare-c` refuses by
|
;;;; a `char *` into a rotating static buffer, which `declare-c` refuses by
|
||||||
;;;; name anyway.
|
;;;; name anyway.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; ONE TRAP, and it is the reason every function below is written as a strict
|
;;;; `i64->bytes` and `f64->bytes` put their text in the temp allocator, where
|
||||||
;;;; sequence of format-draw-measure rather than as a let of several pieces:
|
;;;; it lasts until the next `free-temp()`. A program drawing these every frame
|
||||||
;;;; `i64->bytes` and `f64->bytes` both write into a single shared static
|
;;;; calls `free-temp()` once per frame, after drawing, and clones any text it
|
||||||
;;;; buffer in the runtime, overwritten by the next such call. `(string ...)`
|
;;;; keeps longer.
|
||||||
;;;; does not copy it. So a number must be *drawn before the next one is
|
|
||||||
;;;; formatted* — holding two at once is wrong pixels with no crash and no
|
|
||||||
;;;; diagnostic.
|
|
||||||
;;;;
|
;;;;
|
||||||
;;;; Everything here needs a window: `measure-text` answers 0 for every string
|
;;;; Everything here needs a window: `measure-text` answers 0 for every string
|
||||||
;;;; until init-window has loaded the default font, and a zero advance would
|
;;;; until init-window has loaded the default font, and a zero advance would
|
||||||
;;;; stack every piece on top of the first.
|
;;;; stack every piece on top of the first.
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
;; Padding is drawn from a literal, one zero at a time. This is the last of the
|
;; Padding is drawn from a literal, one zero at a time. This is the last of the
|
||||||
;; old glyph table and it is here only because there is no field width.
|
;; old glyph table and it is here only because there is no field width.
|
||||||
(defconst zero-glyph "0")
|
const zero-glyph = "0"
|
||||||
|
|
||||||
;; One piece of text, and how far the pen moved. raylib's default font is not
|
;; One piece of text, and how far the pen moved. raylib's default font is not
|
||||||
;; monospaced — "1" is narrower than "8" — so the advance is measured rather
|
;; monospaced — "1" is narrower than "8" — so the advance is measured rather
|
||||||
@@ -48,25 +45,25 @@
|
|||||||
;;
|
;;
|
||||||
;; Nothing may be formatted between the draw and the measure: `s` may be a view
|
;; Nothing may be formatted between the draw and the measure: `s` may be a view
|
||||||
;; of the shared buffer, and both calls have to see the same bytes.
|
;; of the shared buffer, and both calls have to see the same bytes.
|
||||||
(defn draw-piece [s string x i32 y i32 size i32 color rl/Color] i32
|
fn draw-piece(s: str, x: i32, y: i32, size: i32, color: rl/Color) -> i32
|
||||||
(rl/draw-text s x y size color)
|
rl/draw-text(s, x, y, size, color)
|
||||||
(rl/measure-text s size))
|
rl/measure-text(s, size)
|
||||||
|
|
||||||
;; How many decimal digits `n` has, for n >= 0. 0 has one. Only the padded
|
;; How many decimal digits `n` has, for n >= 0. 0 has one. Only the padded
|
||||||
;; forms need it now — it is how many zeroes go in front.
|
;; forms need it now — it is how many zeroes go in front.
|
||||||
(defn digit-count [n i32] i32
|
fn digit-count(n: i32) -> i32
|
||||||
(let [d 1
|
let d = 1
|
||||||
r (/ n 10)]
|
r = n / 10
|
||||||
(while (> r 0)
|
while r > 0
|
||||||
(set d (+ d 1))
|
d += 1
|
||||||
(set r (/ r 10)))
|
r /= 10
|
||||||
d))
|
d
|
||||||
|
|
||||||
(defn pow10 [e i32] i32
|
fn pow10(e: i32) -> i32
|
||||||
(let [p 1]
|
let p = 1
|
||||||
(dotimes [i e]
|
for i in 0..e
|
||||||
(set p (* p 10)))
|
p *= 10
|
||||||
p))
|
p
|
||||||
|
|
||||||
;; The whole number, in one draw-text. Answers the width drawn, so a caller can
|
;; The whole number, in one draw-text. Answers the width drawn, so a caller can
|
||||||
;; put something after it — which is how the `TextFormat("%s: %i", ...)` shapes
|
;; put something after it — which is how the `TextFormat("%s: %i", ...)` shapes
|
||||||
@@ -76,8 +73,8 @@
|
|||||||
;; The sign comes free now: i64->bytes renders "-7" itself, which also retires
|
;; The sign comes free now: i64->bytes renders "-7" itself, which also retires
|
||||||
;; the old note about i32's most negative value — it is widened to i64 before
|
;; the old note about i32's most negative value — it is widened to i64 before
|
||||||
;; formatting, so there is no negation to wrap.
|
;; formatting, so there is no negation to wrap.
|
||||||
(defn draw-int [n i32 x i32 y i32 size i32 color rl/Color] i32
|
fn draw-int(n: i32, x: i32, y: i32, size: i32, color: rl/Color) -> i32
|
||||||
(draw-piece (string (i64->bytes (i64 n))) x y size color))
|
draw-piece(str(i64->bytes(i64(n))), x, y, size, color)
|
||||||
|
|
||||||
;; The same with a fixed minimum number of digits — the C's "%03i". A number
|
;; The same with a fixed minimum number of digits — the C's "%03i". A number
|
||||||
;; wider than `width` is drawn in full rather than truncated, which is what
|
;; wider than `width` is drawn in full rather than truncated, which is what
|
||||||
@@ -87,18 +84,17 @@
|
|||||||
;; is still live when it is drawn. A sign goes in front of the padding, as
|
;; is still live when it is drawn. A sign goes in front of the padding, as
|
||||||
;; printf's "%03i" does for -7 → "-07"; hence the magnitude is what gets
|
;; printf's "%03i" does for -7 → "-07"; hence the magnitude is what gets
|
||||||
;; counted and the minus is drawn separately.
|
;; counted and the minus is drawn separately.
|
||||||
(defn draw-int-padded [n i32 width i32 x i32 y i32 size i32 color rl/Color]
|
fn draw-int-padded(n: i32, width: i32, x: i32, y: i32, size: i32, color: rl/Color) -> i32
|
||||||
i32
|
let cx = x
|
||||||
(let [cx x
|
v = n
|
||||||
v n]
|
if v < 0
|
||||||
(when (< v 0)
|
cx += draw-piece("-", cx, y, size, color)
|
||||||
(set cx (+ cx (draw-piece "-" cx y size color)))
|
v = 0 - v
|
||||||
(set v (- 0 v)))
|
let pad = width - digit-count(v)
|
||||||
(let [pad (- width (digit-count v))]
|
for i in 0..pad
|
||||||
(dotimes [i pad]
|
cx += draw-piece(zero-glyph, cx, y, size, color)
|
||||||
(set cx (+ cx (draw-piece zero-glyph cx y size color)))))
|
cx += draw-int(v, cx, y, size, color)
|
||||||
(set cx (+ cx (draw-int v cx y size color)))
|
cx - x
|
||||||
(- cx x)))
|
|
||||||
|
|
||||||
;; "%.02f" and friends. `places` digits after the point, rounded by adding a
|
;; "%.02f" and friends. `places` digits after the point, rounded by adding a
|
||||||
;; half at that scale before the split — so 0.999 at two places is "1.00" and
|
;; half at that scale before the split — so 0.999 at two places is "1.00" and
|
||||||
@@ -113,22 +109,22 @@
|
|||||||
;; value asked for at three places and 1e+06 for a large one. The split into
|
;; value asked for at three places and 1e+06 for a large one. The split into
|
||||||
;; two integers is what buys the fixed width, and it also keeps every formatted
|
;; two integers is what buys the fixed width, and it also keeps every formatted
|
||||||
;; value drawn before the next one is made.
|
;; value drawn before the next one is made.
|
||||||
(defn draw-f32 [v f32 places i32 x i32 y i32 size i32 color rl/Color] i32
|
fn draw-f32(v: f32, places: i32, x: i32, y: i32, size: i32, color: rl/Color) -> i32
|
||||||
(let [cx x
|
let cx = x
|
||||||
av v]
|
av = v
|
||||||
(when (< av 0.0)
|
if av < 0.0
|
||||||
(set cx (+ cx (draw-piece "-" cx y size color)))
|
cx += draw-piece("-", cx, y, size, color)
|
||||||
(set av (- 0.0 av)))
|
av = 0.0 - av
|
||||||
(let [scale (pow10 places)
|
let scale = pow10(places)
|
||||||
;; The rounding and the split happen in one integer so the two halves
|
;; The rounding and the split happen in one integer so the two halves
|
||||||
;; cannot disagree: rounding them separately is how "0.999" becomes
|
;; cannot disagree: rounding them separately is how "0.999" becomes
|
||||||
;; "0.100" — the fraction carries and the whole part does not hear
|
;; "0.100" — the fraction carries and the whole part does not hear
|
||||||
;; about it.
|
;; about it.
|
||||||
total (i32 (+ (* av (f32 scale)) 0.5))
|
total = i32(av * f32(scale) + 0.5)
|
||||||
whole (/ total scale)
|
whole = total / scale
|
||||||
frac (% total scale)]
|
frac = total % scale
|
||||||
(set cx (+ cx (draw-int whole cx y size color)))
|
cx += draw-int(whole, cx, y, size, color)
|
||||||
(when (> places 0)
|
if places > 0
|
||||||
(set cx (+ cx (draw-piece "." cx y size color)))
|
cx += draw-piece(".", cx, y, size, color)
|
||||||
(set cx (+ cx (draw-int-padded frac places cx y size color)))))
|
cx += draw-int-padded(frac, places, cx, y, size, color)
|
||||||
(- cx x)))
|
cx - x
|
||||||
@@ -1,129 +0,0 @@
|
|||||||
;;;; raylib [models] example - box collisions
|
|
||||||
;;;;
|
|
||||||
;;;; examples/models/models_box_collisions.c. The previous lane's finding was
|
|
||||||
;;;; that the whole models category is refused by the importer for want of a
|
|
||||||
;;;; defstruct, and that a models example is therefore mostly a binding
|
|
||||||
;;;; exercise. That is true of the twenty that load a Model — but not of this
|
|
||||||
;;;; one, which is why it is here: nothing in it is a Model, a Mesh or a
|
|
||||||
;;;; Material. It is two cubes, a sphere and one aggregate the package did not
|
|
||||||
;;;; describe.
|
|
||||||
;;;;
|
|
||||||
;;;; That aggregate is BoundingBox, and it is two Vector3s and nothing else —
|
|
||||||
;;;; no owned pointer, no array, no lifetime. One `defstruct` in
|
|
||||||
;;;; vendor/raylib/raylib.flan un-refuses four raylib functions at once
|
|
||||||
;;;; (CheckCollisionBoxes, CheckCollisionBoxSphere, DrawBoundingBox and
|
|
||||||
;;;; GetRayCollisionBox), and that is the cheapest widening of the 3D surface
|
|
||||||
;;;; available anywhere in the tree. Ray and RayCollision went in beside it
|
|
||||||
;;;; for examples/core-3d-picking.flan and for the same reason.
|
|
||||||
;;;;
|
|
||||||
;;;; So the answer to "is a models example just a binding exercise" is: the
|
|
||||||
;;;; ones that need Model are, and this one is the counterexample. What
|
|
||||||
;;;; separates them is not the category, it is whether the struct owns memory.
|
|
||||||
;;;;
|
|
||||||
;;;; What it also exercises, and what needed hand-writing rather than
|
|
||||||
;;;; generating: draw-cube-v, draw-sphere and draw-sphere-wires. All three
|
|
||||||
;;;; were in the generated half already, and all three moved to the
|
|
||||||
;;;; hand-written one here on `bindings`'s own rule — they are inside a frame,
|
|
||||||
;;;; in an example that ships in examples/. draw-cube-v in particular was
|
|
||||||
;;;; named there as generated *because nothing called it*; something calls it
|
|
||||||
;;;; now.
|
|
||||||
;;;;
|
|
||||||
;;;; The collision maths is written twice in the C, once per test, building
|
|
||||||
;;;; the player's box inline both times. It is a function here for the reason
|
|
||||||
;;;; the eyes example gives: two copies of the same eight expressions cannot
|
|
||||||
;;;; be checked against each other by reading them.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
(defvar camera rl/Camera3D)
|
|
||||||
|
|
||||||
(defvar player-position rl/Vector3)
|
|
||||||
(defvar player-size rl/Vector3)
|
|
||||||
(defvar player-color rl/Color)
|
|
||||||
|
|
||||||
(defvar enemy-box-pos rl/Vector3)
|
|
||||||
(defvar enemy-box-size rl/Vector3)
|
|
||||||
(defvar enemy-sphere-pos rl/Vector3)
|
|
||||||
|
|
||||||
(defconst enemy-sphere-size f32 1.5)
|
|
||||||
|
|
||||||
;; A box centred on `centre` with the given extents. raylib's BoundingBox is
|
|
||||||
;; min-corner/max-corner, not centre/size, and every collision call in the
|
|
||||||
;; family takes the corner form — so this is the conversion the C writes out
|
|
||||||
;; longhand at each of its two call sites.
|
|
||||||
;;
|
|
||||||
;; It used to be eight expressions of field arithmetic here too; it is the
|
|
||||||
;; half-extent subtracted and added now that the package carries vector
|
|
||||||
;; arithmetic — see vendor/raylib/vector.flan, which is Flan and not C
|
|
||||||
;; because raymath is `static inline` and has no symbol to bind.
|
|
||||||
(defn box-around [centre rl/Vector3 size rl/Vector3] rl/BoundingBox
|
|
||||||
(let [half (rl/v3-scale size 0.5)]
|
|
||||||
(rl/BoundingBox {.min (rl/v3-sub centre half)
|
|
||||||
.max (rl/v3-add centre half)})))
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [models] example - box collisions")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
;; The C writes this camera as a brace initialiser with a trailing 0 for the
|
|
||||||
;; projection, which is CAMERA_PERSPECTIVE. Named here, because the defenum
|
|
||||||
;; exists precisely so that the 0 does not have to be remembered.
|
|
||||||
(set camera (rl/Camera3D {.position (rl/Vector3 {.x 0.0 .y 10.0 .z 10.0})
|
|
||||||
.target (rl/Vector3 {.x 0.0 .y 0.0 .z 0.0})
|
|
||||||
.up (rl/Vector3 {.x 0.0 .y 1.0 .z 0.0})
|
|
||||||
.fovy 45.0
|
|
||||||
.projection :perspective}))
|
|
||||||
|
|
||||||
(set player-position (rl/Vector3 {.x 0.0 .y 1.0 .z 2.0}))
|
|
||||||
(set player-size (rl/Vector3 {.x 1.0 .y 2.0 .z 1.0}))
|
|
||||||
(set player-color rl/green)
|
|
||||||
|
|
||||||
(set enemy-box-pos (rl/Vector3 {.x -4.0 .y 1.0 .z 0.0}))
|
|
||||||
(set enemy-box-size (rl/Vector3 {.x 2.0 .y 2.0 .z 2.0}))
|
|
||||||
(set enemy-sphere-pos (rl/Vector3 {.x 4.0 .y 0.0 .z 0.0}))
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update. The arrow keys move on the XZ plane, and the C's else-if chain
|
|
||||||
;; means only one direction applies per frame — diagonal movement is not
|
|
||||||
;; possible, deliberately.
|
|
||||||
(cond
|
|
||||||
(rl/key-down? :right) (set (.x player-position) (+ (.x player-position) 0.2))
|
|
||||||
(rl/key-down? :left) (set (.x player-position) (- (.x player-position) 0.2))
|
|
||||||
(rl/key-down? :down) (set (.z player-position) (+ (.z player-position) 0.2))
|
|
||||||
(rl/key-down? :up) (set (.z player-position) (- (.z player-position) 0.2)))
|
|
||||||
|
|
||||||
(let [player-box (box-around player-position player-size)
|
|
||||||
hit (or (rl/check-collision-boxes player-box
|
|
||||||
(box-around enemy-box-pos enemy-box-size))
|
|
||||||
(rl/check-collision-box-sphere player-box enemy-sphere-pos
|
|
||||||
enemy-sphere-size))]
|
|
||||||
(set player-color (if hit rl/red rl/green)))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(rl/with-mode-3d camera
|
|
||||||
(rl/draw-cube enemy-box-pos (.x enemy-box-size) (.y enemy-box-size)
|
|
||||||
(.z enemy-box-size) rl/gray)
|
|
||||||
(rl/draw-cube-wires enemy-box-pos (.x enemy-box-size) (.y enemy-box-size)
|
|
||||||
(.z enemy-box-size) rl/darkgray)
|
|
||||||
|
|
||||||
;; draw-sphere is draw-sphere-ex at 16 rings and 16 slices; the wires form
|
|
||||||
;; takes them because the tessellation is only visible in the wireframe.
|
|
||||||
(rl/draw-sphere enemy-sphere-pos enemy-sphere-size rl/gray)
|
|
||||||
(rl/draw-sphere-wires enemy-sphere-pos enemy-sphere-size 16 16 rl/darkgray)
|
|
||||||
|
|
||||||
(rl/draw-cube-v player-position player-size player-color)
|
|
||||||
|
|
||||||
(rl/draw-grid 10 1.0))
|
|
||||||
|
|
||||||
(rl/draw-text "Move player with arrow keys to collide" 220 40 20 rl/gray)
|
|
||||||
|
|
||||||
(rl/draw-fps 10 10))))
|
|
||||||
@@ -0,0 +1,113 @@
|
|||||||
|
;;;; raylib [models] example - box collisions
|
||||||
|
;;;;
|
||||||
|
;;;; examples/models/models_box_collisions.c. The previous lane's finding was
|
||||||
|
;;;; that the whole models category is refused by the importer for want of a
|
||||||
|
;;;; defstruct, and that a models example is therefore mostly a binding
|
||||||
|
;;;; exercise. That is true of the twenty that load a Model — but not of this
|
||||||
|
;;;; one, which is why it is here: nothing in it is a Model, a Mesh or a
|
||||||
|
;;;; Material. It is two cubes, a sphere and one aggregate the package did not
|
||||||
|
;;;; describe.
|
||||||
|
;;;;
|
||||||
|
;;;; That aggregate is BoundingBox, and it is two Vector3s and nothing else —
|
||||||
|
;;;; no owned pointer, no array, no lifetime. One `defstruct` in
|
||||||
|
;;;; vendor/raylib/raylib.fln un-refuses four raylib functions at once
|
||||||
|
;;;; (CheckCollisionBoxes, CheckCollisionBoxSphere, DrawBoundingBox and
|
||||||
|
;;;; GetRayCollisionBox), and that is the cheapest widening of the 3D surface
|
||||||
|
;;;; available anywhere in the tree. Ray and RayCollision went in beside it
|
||||||
|
;;;; for examples/core-3d-picking.fln and for the same reason.
|
||||||
|
;;;;
|
||||||
|
;;;; So the answer to "is a models example just a binding exercise" is: the
|
||||||
|
;;;; ones that need Model are, and this one is the counterexample. What
|
||||||
|
;;;; separates them is not the category, it is whether the struct owns memory.
|
||||||
|
;;;;
|
||||||
|
;;;; What it also exercises, and what needed hand-writing rather than
|
||||||
|
;;;; generating: draw-cube-v, draw-sphere and draw-sphere-wires. All three
|
||||||
|
;;;; were in the generated half already, and all three moved to the
|
||||||
|
;;;; hand-written one here on `bindings`'s own rule — they are inside a frame,
|
||||||
|
;;;; in an example that ships in examples/. draw-cube-v in particular was
|
||||||
|
;;;; named there as generated *because nothing called it*; something calls it
|
||||||
|
;;;; now.
|
||||||
|
;;;;
|
||||||
|
;;;; The collision maths is written twice in the C, once per test, building
|
||||||
|
;;;; the player's box inline both times. It is a function here for the reason
|
||||||
|
;;;; the eyes example gives: two copies of the same eight expressions cannot
|
||||||
|
;;;; be checked against each other by reading them.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
once camera: rl/Camera3D
|
||||||
|
|
||||||
|
once player-position: rl/Vector3
|
||||||
|
once player-size: rl/Vector3
|
||||||
|
once player-color: rl/Color
|
||||||
|
|
||||||
|
once enemy-box-pos: rl/Vector3
|
||||||
|
once enemy-box-size: rl/Vector3
|
||||||
|
once enemy-sphere-pos: rl/Vector3
|
||||||
|
|
||||||
|
const enemy-sphere-size: f32 = 1.5
|
||||||
|
|
||||||
|
;; A box centred on `centre` with the given extents. raylib's BoundingBox is
|
||||||
|
;; min-corner/max-corner, not centre/size, and every collision call in the
|
||||||
|
;; family takes the corner form — so this is the conversion the C writes out
|
||||||
|
;; longhand at each of its two call sites.
|
||||||
|
;;
|
||||||
|
;; It used to be eight expressions of field arithmetic here too; it is the
|
||||||
|
;; half-extent subtracted and added now that the package carries vector
|
||||||
|
;; arithmetic — see vendor/raylib/vector.fln, which is Flan and not C
|
||||||
|
;; because raymath is `static inline` and has no symbol to bind.
|
||||||
|
fn box-around(centre: rl/Vector3, size: rl/Vector3) -> rl/BoundingBox
|
||||||
|
let half = rl/v3-scale(size, 0.5)
|
||||||
|
rl/BoundingBox{.min rl/v3-sub(centre, half) .max rl/v3-add(centre, half)}
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [models] example - box collisions")
|
||||||
|
defer rl/close-window()
|
||||||
|
;; The C writes this camera as a brace initialiser with a trailing 0 for the
|
||||||
|
;; projection, which is CAMERA_PERSPECTIVE. Named here, because the enum
|
||||||
|
;; exists precisely so that the 0 does not have to be remembered.
|
||||||
|
camera = rl/Camera3D{.position rl/Vector3{.x 0.0 .y 10.0 .z 10.0} .target rl/Vector3{.x 0.0 .y 0.0 .z 0.0} .up rl/Vector3{.x 0.0 .y 1.0 .z 0.0} .fovy 45.0 .projection :projection-perspective}
|
||||||
|
player-position = rl/Vector3{.x 0.0 .y 1.0 .z 2.0}
|
||||||
|
player-size = rl/Vector3{.x 1.0 .y 2.0 .z 1.0}
|
||||||
|
player-color = rl/green
|
||||||
|
enemy-box-pos = rl/Vector3{.x -4.0 .y 1.0 .z 0.0}
|
||||||
|
enemy-box-size = rl/Vector3{.x 2.0 .y 2.0 .z 2.0}
|
||||||
|
enemy-sphere-pos = rl/Vector3{.x 4.0 .y 0.0 .z 0.0}
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update. The arrow keys move on the XZ plane, and the C's else-if chain
|
||||||
|
;; means only one direction applies per frame — diagonal movement is not
|
||||||
|
;; possible, deliberately.
|
||||||
|
if rl/is-key-down(:key-right)
|
||||||
|
player-position.x += 0.2
|
||||||
|
elif rl/is-key-down(:key-left)
|
||||||
|
player-position.x -= 0.2
|
||||||
|
elif rl/is-key-down(:key-down)
|
||||||
|
player-position.z += 0.2
|
||||||
|
elif rl/is-key-down(:key-up)
|
||||||
|
player-position.z -= 0.2
|
||||||
|
let player-box = box-around(player-position, player-size)
|
||||||
|
let hit = rl/check-collision-boxes(player-box, box-around(enemy-box-pos, enemy-box-size)) or rl/check-collision-box-sphere(player-box, enemy-sphere-pos, enemy-sphere-size)
|
||||||
|
player-color = (if hit then rl/red else rl/green)
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/with-mode-3d(camera):
|
||||||
|
rl/draw-cube(enemy-box-pos, enemy-box-size.x, enemy-box-size.y,
|
||||||
|
enemy-box-size.z, rl/gray)
|
||||||
|
rl/draw-cube-wires(enemy-box-pos, enemy-box-size.x, enemy-box-size.y,
|
||||||
|
enemy-box-size.z, rl/darkgray)
|
||||||
|
;; draw-sphere is draw-sphere-ex at 16 rings and 16 slices; the wires form
|
||||||
|
;; takes them because the tessellation is only visible in the wireframe.
|
||||||
|
rl/draw-sphere(enemy-sphere-pos, enemy-sphere-size, rl/gray)
|
||||||
|
rl/draw-sphere-wires(enemy-sphere-pos, enemy-sphere-size, 16, 16,
|
||||||
|
rl/darkgray)
|
||||||
|
rl/draw-cube-v(player-position, player-size, player-color)
|
||||||
|
rl/draw-grid(10, 1.0)
|
||||||
|
rl/draw-text("Move player with arrow keys to collide", 220, 40, 20,
|
||||||
|
rl/gray)
|
||||||
|
rl/draw-fps(10, 10)
|
||||||
@@ -7,17 +7,17 @@
|
|||||||
;;;; poly draws — in one frame, beside the four the core examples already
|
;;;; poly draws — in one frame, beside the four the core examples already
|
||||||
;;;; exercise. Every one of them came out of the generated half of the
|
;;;; exercise. Every one of them came out of the generated half of the
|
||||||
;;;; bindings and none needed a new line anywhere; that is the result worth
|
;;;; bindings and none needed a new line anywhere; that is the result worth
|
||||||
;;;; recording, because the whole point of a committed generated.flan is that
|
;;;; recording, because the whole point of a committed generated.fln is that
|
||||||
;;;; a build with no FLAN_RAYLIB_H set can draw with all of it.
|
;;;; a build with no FLAN_RAYLIB_H set can draw with all of it.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; What it is actually a test of. The gradient calls are the first thing in
|
;;;; What it is actually a test of. The gradient calls are the first thing in
|
||||||
;;;; the corpus to pass *two* Colors in one call, and draw-triangle is the
|
;;;; the corpus to pass *two* Colors in one call, and draw-triangle is the
|
||||||
;;;; first to pass three Vector2s. A struct argument crosses the FFI by
|
;;;; first to pass three Vector2s. A struct argument crosses the FFI by
|
||||||
;;;; pointer into a generated shim (vendor/raylib/raylib.flan's header note),
|
;;;; pointer into a generated shim (vendor/raylib/raylib.fln's header note),
|
||||||
;;;; so the arity of that copying is what a call with several small structs in
|
;;;; so the arity of that copying is what a call with several small structs in
|
||||||
;;;; a row puts under load. Nothing here can be asserted headless — every line
|
;;;; a row puts under load. Nothing here can be asserted headless — every line
|
||||||
;;;; needs a GL context — so the check is the link and the screen, which is
|
;;;; needs a GL context — so the check is the link and the screen, which is
|
||||||
;;;; what the Shapes comment in raylib.flan already says about this family.
|
;;;; what the Shapes comment in raylib.fln already says about this family.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; The one deliberate difference from the C: the C writes `screenWidth/4*2`
|
;;;; The one deliberate difference from the C: the C writes `screenWidth/4*2`
|
||||||
;;;; and `screenWidth/4.0f*3.0f` for the same column and gets 400 and 600 out
|
;;;; and `screenWidth/4.0f*3.0f` for the same column and gets 400 and 600 out
|
||||||
@@ -27,74 +27,63 @@
|
|||||||
;;;; parameters of draw-circle, and the poly centre is built from f32
|
;;;; parameters of draw-circle, and the poly centre is built from f32
|
||||||
;;;; literals because a Vector2 holds f32.
|
;;;; literals because a Vector2 holds f32.
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
(defconst screen-width 800)
|
const screen-width = 800
|
||||||
(defconst screen-height 450)
|
const screen-height = 450
|
||||||
|
|
||||||
;; The three columns the C lays the shapes out in. The middle one is
|
;; The three columns the C lays the shapes out in. The middle one is
|
||||||
;; screenWidth/4*2 and the right one screenWidth/4*3, which is 400 and 600.
|
;; screenWidth/4*2 and the right one screenWidth/4*3, which is 400 and 600.
|
||||||
(defconst col-left 160) ; screen-width / 5
|
const col-left = 160 ; screen-width / 5
|
||||||
(defconst col-mid 400)
|
const col-mid = 400
|
||||||
(defconst col-right 600)
|
const col-right = 600
|
||||||
|
|
||||||
(defvar rotation f32)
|
once rotation: f32
|
||||||
|
|
||||||
(defn main [] ()
|
fn main() -> ()
|
||||||
(rl/init-window screen-width screen-height
|
rl/init-window(screen-width, screen-height,
|
||||||
"raylib [shapes] example - basic shapes drawing")
|
"raylib [shapes] example - basic shapes drawing")
|
||||||
(defer (rl/close-window))
|
defer rl/close-window()
|
||||||
|
rotation = 0.0
|
||||||
(set rotation 0.0)
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update. The polygons spin; nothing else moves.
|
;; Update. The polygons spin; nothing else moves.
|
||||||
(set rotation (+ rotation 0.2))
|
rotation += 0.2
|
||||||
|
|
||||||
;; Draw
|
;; Draw
|
||||||
(rl/with-drawing
|
rl/with-drawing:
|
||||||
(rl/clear-background rl/raywhite)
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/draw-text("some basic shapes available on raylib", 20, 20, 20,
|
||||||
(rl/draw-text "some basic shapes available on raylib" 20 20 20 rl/darkgray)
|
rl/darkgray)
|
||||||
|
|
||||||
;; Circles. The gradient one takes an inner and an outer colour and is the
|
;; Circles. The gradient one takes an inner and an outer colour and is the
|
||||||
;; first call in the corpus to pass two Colors at once.
|
;; first call in the corpus to pass two Colors at once.
|
||||||
(rl/draw-circle col-left 120 35.0 rl/darkblue)
|
rl/draw-circle(col-left, 120, 35.0, rl/darkblue)
|
||||||
(rl/draw-circle-gradient col-left 220 60.0 rl/green rl/skyblue)
|
rl/draw-circle-gradient(col-left, 220, 60.0, rl/green, rl/skyblue)
|
||||||
(rl/draw-circle-lines col-left 340 80.0 rl/darkblue)
|
rl/draw-circle-lines(col-left, 340, 80.0, rl/darkblue)
|
||||||
|
|
||||||
;; Rectangles. draw-rectangle-gradient-h runs the colour left to right;
|
;; Rectangles. draw-rectangle-gradient-h runs the colour left to right;
|
||||||
;; the -v form runs it top to bottom and the -ex form takes all four
|
;; the -v form runs it top to bottom and the -ex form takes all four
|
||||||
;; corners. The C uses the horizontal one here.
|
;; corners. The C uses the horizontal one here.
|
||||||
(rl/draw-rectangle (- col-mid 60) 100 120 60 rl/red)
|
rl/draw-rectangle(col-mid - 60, 100, 120, 60, rl/red)
|
||||||
(rl/draw-rectangle-gradient-h (- col-mid 90) 170 180 130 rl/maroon rl/gold)
|
rl/draw-rectangle-gradient-h(col-mid - 90, 170, 180, 130, rl/maroon,
|
||||||
|
rl/gold)
|
||||||
;; raylib draws this with quads internally rather than with lines, which
|
;; raylib draws this with quads internally rather than with lines, which
|
||||||
;; is why its thickness does not follow the line width anywhere.
|
;; is why its thickness does not follow the line width anywhere.
|
||||||
(rl/draw-rectangle-lines (- col-mid 40) 320 80 60 rl/orange)
|
rl/draw-rectangle-lines(col-mid - 40, 320, 80, 60, rl/orange)
|
||||||
|
|
||||||
;; Triangles. raylib wants the three vertices in counter-clockwise order
|
;; Triangles. raylib wants the three vertices in counter-clockwise order
|
||||||
;; and draws nothing at all for a clockwise one, so the order here is not
|
;; and draws nothing at all for a clockwise one, so the order here is not
|
||||||
;; cosmetic.
|
;; cosmetic.
|
||||||
(rl/draw-triangle (rl/Vector2 {.x 600.0 .y 80.0})
|
rl/draw-triangle(rl/Vector2{.x 600.0 .y 80.0},
|
||||||
(rl/Vector2 {.x 540.0 .y 150.0})
|
rl/Vector2{.x 540.0 .y 150.0},
|
||||||
(rl/Vector2 {.x 660.0 .y 150.0})
|
rl/Vector2{.x 660.0 .y 150.0}, rl/violet)
|
||||||
rl/violet)
|
rl/draw-triangle-lines(rl/Vector2{.x 600.0 .y 160.0},
|
||||||
|
rl/Vector2{.x 580.0 .y 230.0},
|
||||||
(rl/draw-triangle-lines (rl/Vector2 {.x 600.0 .y 160.0})
|
rl/Vector2{.x 620.0 .y 230.0}, rl/darkblue)
|
||||||
(rl/Vector2 {.x 580.0 .y 230.0})
|
|
||||||
(rl/Vector2 {.x 620.0 .y 230.0})
|
|
||||||
rl/darkblue)
|
|
||||||
|
|
||||||
;; Polygons, all three at the same centre and the same rotation, at three
|
;; Polygons, all three at the same centre and the same rotation, at three
|
||||||
;; radii, so the filled hexagon sits inside the two outlines.
|
;; radii, so the filled hexagon sits inside the two outlines.
|
||||||
(let [centre (rl/Vector2 {.x (f32 col-right) .y 330.0})]
|
let centre = rl/Vector2{.x f32(col-right) .y 330.0}
|
||||||
(rl/draw-poly centre 6 80.0 rotation rl/brown)
|
rl/draw-poly(centre, 6, 80.0, rotation, rl/brown)
|
||||||
(rl/draw-poly-lines centre 6 90.0 rotation rl/brown)
|
rl/draw-poly-lines(centre, 6, 90.0, rotation, rl/brown)
|
||||||
(rl/draw-poly-lines-ex centre 6 85.0 rotation 6.0 rl/beige))
|
rl/draw-poly-lines-ex(centre, 6, 85.0, rotation, 6.0, rl/beige)
|
||||||
|
|
||||||
;; The C draws every LINES-based shape together so raylib can batch them
|
;; The C draws every LINES-based shape together so raylib can batch them
|
||||||
;; into one pass. This last line is part of that comment and not an
|
;; into one pass. This last line is part of that comment and not an
|
||||||
;; afterthought, so it stays where the C has it.
|
;; afterthought, so it stays where the C has it.
|
||||||
(rl/draw-line 18 42 (- screen-width 18) 42 rl/black))))
|
rl/draw-line(18, 42, screen-width - 18, 42, rl/black)
|
||||||
@@ -1,127 +0,0 @@
|
|||||||
;;;; raylib [shapes] example - collision area
|
|
||||||
;;;;
|
|
||||||
;;;; examples/shapes/shapes_collision_area.c. Picked for one call:
|
|
||||||
;;;; get-collision-rec, which is the only binding in the package that takes
|
|
||||||
;;;; two Rectangles and answers a third. Everything else in the corpus that
|
|
||||||
;;;; crosses a struct either passes one in (Camera2D, Color) or gets one back
|
|
||||||
;;;; (get-mouse-position, fade) — this is the first per-frame call doing both
|
|
||||||
;;;; at once, and the returned struct comes back through the shim's `out`
|
|
||||||
;;;; pointer rather than in registers, which is a different lowering again.
|
|
||||||
;;;;
|
|
||||||
;;;; It is also the only headless-adjacent thing in the file: both
|
|
||||||
;;;; collision-recs? and get-collision-rec are pure arithmetic over their
|
|
||||||
;;;; arguments and need no window at all. The acceptance table already asserts
|
|
||||||
;;;; the pair; what this adds is the same two calls on a frame path with one
|
|
||||||
;;;; rectangle driven by the mouse, where a permuted Rectangle would put the
|
|
||||||
;;;; green overlap patch somewhere the two boxes are not.
|
|
||||||
;;;;
|
|
||||||
;;;; Both TextFormats go through examples/digits.flan the way the core ports
|
|
||||||
;;;; do it: draw the literal part, then the number at x plus its width.
|
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
|
||||||
(import d "digits.flan")
|
|
||||||
|
|
||||||
(defconst screen-width 800)
|
|
||||||
(defconst screen-height 450)
|
|
||||||
|
|
||||||
;; The top strip the collision message is drawn into, and the floor box B is
|
|
||||||
;; not allowed above.
|
|
||||||
(defconst screen-upper-limit 40)
|
|
||||||
|
|
||||||
(defvar box-a rl/Rectangle) ; moves by itself, bounces off the sides
|
|
||||||
(defvar box-b rl/Rectangle) ; follows the mouse
|
|
||||||
(defvar box-collision rl/Rectangle) ; their overlap, valid only while touching
|
|
||||||
(defvar box-a-speed-x i32)
|
|
||||||
(defvar paused bool)
|
|
||||||
(defvar collision bool)
|
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [shapes] example - collision area")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
(set box-a (rl/Rectangle {.x 10.0
|
|
||||||
.y (- (/ (f32 screen-height) 2.0) 50.0)
|
|
||||||
.width 200.0 .height 100.0}))
|
|
||||||
(set box-a-speed-x 4)
|
|
||||||
|
|
||||||
(set box-b (rl/Rectangle {.x (- (/ (f32 screen-width) 2.0) 30.0)
|
|
||||||
.y (- (/ (f32 screen-height) 2.0) 30.0)
|
|
||||||
.width 60.0 .height 60.0}))
|
|
||||||
|
|
||||||
;; A fresh Rectangle is four zeroes, which is the C's `= { 0 }`. It is never
|
|
||||||
;; drawn before the first collision sets it.
|
|
||||||
(set box-collision (rl/Rectangle {.x 0.0 .y 0.0 .width 0.0 .height 0.0}))
|
|
||||||
|
|
||||||
(set paused false)
|
|
||||||
(set collision false)
|
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
|
||||||
(when (not paused)
|
|
||||||
(set (.x box-a) (+ (.x box-a) (f32 box-a-speed-x))))
|
|
||||||
|
|
||||||
;; Bounce at either edge. The test is on the far edge going right and on
|
|
||||||
;; the near one going left, so the box reverses on whichever it reaches.
|
|
||||||
(when (or (>= (+ (.x box-a) (.width box-a)) (f32 (rl/get-screen-width)))
|
|
||||||
(<= (.x box-a) 0.0))
|
|
||||||
(set box-a-speed-x (* box-a-speed-x -1)))
|
|
||||||
|
|
||||||
;; Box B is centred on the mouse and then clamped back inside the play
|
|
||||||
;; area — which is the window minus the top strip.
|
|
||||||
(set (.x box-b) (- (f32 (rl/get-mouse-x)) (/ (.width box-b) 2.0)))
|
|
||||||
(set (.y box-b) (- (f32 (rl/get-mouse-y)) (/ (.height box-b) 2.0)))
|
|
||||||
|
|
||||||
(if (>= (+ (.x box-b) (.width box-b)) (f32 (rl/get-screen-width)))
|
|
||||||
(set (.x box-b) (- (f32 (rl/get-screen-width)) (.width box-b)))
|
|
||||||
(when (<= (.x box-b) 0.0) (set (.x box-b) 0.0)))
|
|
||||||
|
|
||||||
(if (>= (+ (.y box-b) (.height box-b)) (f32 (rl/get-screen-height)))
|
|
||||||
(set (.y box-b) (- (f32 (rl/get-screen-height)) (.height box-b)))
|
|
||||||
(when (<= (.y box-b) (f32 screen-upper-limit))
|
|
||||||
(set (.y box-b) (f32 screen-upper-limit))))
|
|
||||||
|
|
||||||
(set collision (rl/collision-recs? box-a box-b))
|
|
||||||
|
|
||||||
;; Only meaningful while they touch: raylib answers a zero rectangle for
|
|
||||||
;; two boxes that do not, and the C leaves the previous one in place
|
|
||||||
;; rather than reading that back. This follows it.
|
|
||||||
(when collision (set box-collision (rl/get-collision-rec box-a box-b)))
|
|
||||||
|
|
||||||
(when (rl/key-pressed? :space) (set paused (not paused)))
|
|
||||||
|
|
||||||
;; Draw
|
|
||||||
(rl/with-drawing
|
|
||||||
(rl/clear-background rl/raywhite)
|
|
||||||
|
|
||||||
(rl/draw-rectangle 0 0 screen-width screen-upper-limit
|
|
||||||
(if collision rl/red rl/black))
|
|
||||||
|
|
||||||
(rl/draw-rectangle-rec box-a rl/gold)
|
|
||||||
(rl/draw-rectangle-rec box-b rl/blue)
|
|
||||||
|
|
||||||
(when collision
|
|
||||||
;; The overlap itself, drawn over both boxes. This patch landing
|
|
||||||
;; anywhere other than where the gold and the blue cross is what a
|
|
||||||
;; permuted Rectangle would look like.
|
|
||||||
(rl/draw-rectangle-rec box-collision rl/lime)
|
|
||||||
|
|
||||||
(rl/draw-text "COLLISION!"
|
|
||||||
(- (/ (rl/get-screen-width) 2)
|
|
||||||
(/ (rl/measure-text "COLLISION!" 20) 2))
|
|
||||||
(- (/ screen-upper-limit 2) 10) 20 rl/black)
|
|
||||||
|
|
||||||
;; The C's TextFormat("Collision Area: %i", ...). Both dimensions are
|
|
||||||
;; truncated to int before multiplying, as the C's two casts do.
|
|
||||||
(let [x (- (/ (rl/get-screen-width) 2) 100)
|
|
||||||
y (+ screen-upper-limit 10)]
|
|
||||||
(set x (+ x (d/draw-piece "Collision Area: " x y 20 rl/black)))
|
|
||||||
(d/draw-int (* (i32 (.width box-collision)) (i32 (.height box-collision)))
|
|
||||||
x y 20 rl/black)))
|
|
||||||
|
|
||||||
(rl/draw-text "Press SPACE to PAUSE/RESUME" 20 (- screen-height 35) 20
|
|
||||||
rl/lightgray)
|
|
||||||
|
|
||||||
(rl/draw-fps 10 10))))
|
|
||||||
@@ -0,0 +1,104 @@
|
|||||||
|
;;;; raylib [shapes] example - collision area
|
||||||
|
;;;;
|
||||||
|
;;;; examples/shapes/shapes_collision_area.c. Picked for one call:
|
||||||
|
;;;; get-collision-rec, which is the only binding in the package that takes
|
||||||
|
;;;; two Rectangles and answers a third. Everything else in the corpus that
|
||||||
|
;;;; crosses a struct either passes one in (Camera2D, Color) or gets one back
|
||||||
|
;;;; (get-mouse-position, fade) — this is the first per-frame call doing both
|
||||||
|
;;;; at once, and the returned struct comes back through the shim's `out`
|
||||||
|
;;;; pointer rather than in registers, which is a different lowering again.
|
||||||
|
;;;;
|
||||||
|
;;;; It is also the only headless-adjacent thing in the file: both
|
||||||
|
;;;; check-collision-recs and get-collision-rec are pure arithmetic over their
|
||||||
|
;;;; arguments and need no window at all. The acceptance table already asserts
|
||||||
|
;;;; the pair; what this adds is the same two calls on a frame path with one
|
||||||
|
;;;; rectangle driven by the mouse, where a permuted Rectangle would put the
|
||||||
|
;;;; green overlap patch somewhere the two boxes are not.
|
||||||
|
;;;;
|
||||||
|
;;;; Both TextFormats go through examples/digits.fln the way the core ports
|
||||||
|
;;;; do it: draw the literal part, then the number at x plus its width.
|
||||||
|
|
||||||
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
|
import d "digits.fln"
|
||||||
|
|
||||||
|
const screen-width = 800
|
||||||
|
const screen-height = 450
|
||||||
|
|
||||||
|
;; The top strip the collision message is drawn into, and the floor box B is
|
||||||
|
;; not allowed above.
|
||||||
|
const screen-upper-limit = 40
|
||||||
|
|
||||||
|
once box-a: rl/Rectangle ; moves by itself, bounces off the sides
|
||||||
|
once box-b: rl/Rectangle ; follows the mouse
|
||||||
|
once box-collision: rl/Rectangle ; their overlap, valid only while touching
|
||||||
|
once box-a-speed-x: i32
|
||||||
|
once paused: bool
|
||||||
|
once collision: bool
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [shapes] example - collision area")
|
||||||
|
defer rl/close-window()
|
||||||
|
box-a = rl/Rectangle{.x 10.0, .y f32(screen-height) / 2.0 - 50.0, .width 200.0, .height 100.0}
|
||||||
|
box-a-speed-x = 4
|
||||||
|
box-b = rl/Rectangle{.x f32(screen-width) / 2.0 - 30.0, .y f32(screen-height) / 2.0 - 30.0, .width 60.0, .height 60.0}
|
||||||
|
;; A fresh Rectangle is four zeroes, which is the C's `= { 0 }`. It is never
|
||||||
|
;; drawn before the first collision sets it.
|
||||||
|
box-collision = rl/Rectangle{.x 0.0 .y 0.0 .width 0.0 .height 0.0}
|
||||||
|
paused = false
|
||||||
|
collision = false
|
||||||
|
rl/set-target-fps(60)
|
||||||
|
until rl/window-should-close()
|
||||||
|
;; Update
|
||||||
|
if not paused
|
||||||
|
box-a.x += f32(box-a-speed-x)
|
||||||
|
;; Bounce at either edge. The test is on the far edge going right and on
|
||||||
|
;; the near one going left, so the box reverses on whichever it reaches.
|
||||||
|
if box-a.x + box-a.width >= f32(rl/get-screen-width()) or box-a.x <= 0.0
|
||||||
|
box-a-speed-x *= -1
|
||||||
|
;; Box B is centred on the mouse and then clamped back inside the play
|
||||||
|
;; area — which is the window minus the top strip.
|
||||||
|
box-b.x = f32(rl/get-mouse-x()) - box-b.width / 2.0
|
||||||
|
box-b.y = f32(rl/get-mouse-y()) - box-b.height / 2.0
|
||||||
|
if box-b.x + box-b.width >= f32(rl/get-screen-width())
|
||||||
|
box-b.x = f32(rl/get-screen-width()) - box-b.width
|
||||||
|
elif box-b.x <= 0.0
|
||||||
|
box-b.x = 0.0
|
||||||
|
if box-b.y + box-b.height >= f32(rl/get-screen-height())
|
||||||
|
box-b.y = f32(rl/get-screen-height()) - box-b.height
|
||||||
|
elif box-b.y <= f32(screen-upper-limit)
|
||||||
|
box-b.y = f32(screen-upper-limit)
|
||||||
|
collision = rl/check-collision-recs(box-a, box-b)
|
||||||
|
;; Only meaningful while they touch: raylib answers a zero rectangle for
|
||||||
|
;; two boxes that do not, and the C leaves the previous one in place
|
||||||
|
;; rather than reading that back. This follows it.
|
||||||
|
if collision
|
||||||
|
box-collision = rl/get-collision-rec(box-a, box-b)
|
||||||
|
if rl/is-key-pressed(:key-space)
|
||||||
|
paused = not paused
|
||||||
|
;; Draw
|
||||||
|
rl/with-drawing:
|
||||||
|
rl/clear-background(rl/raywhite)
|
||||||
|
rl/draw-rectangle(0, 0, screen-width, screen-upper-limit,
|
||||||
|
if collision then rl/red else rl/black)
|
||||||
|
rl/draw-rectangle-rec(box-a, rl/gold)
|
||||||
|
rl/draw-rectangle-rec(box-b, rl/blue)
|
||||||
|
if collision
|
||||||
|
;; The overlap itself, drawn over both boxes. This patch landing
|
||||||
|
;; anywhere other than where the gold and the blue cross is what a
|
||||||
|
;; permuted Rectangle would look like.
|
||||||
|
rl/draw-rectangle-rec(box-collision, rl/lime)
|
||||||
|
rl/draw-text("COLLISION!",
|
||||||
|
rl/get-screen-width() / 2 - rl/measure-text("COLLISION!", 20) / 2,
|
||||||
|
screen-upper-limit / 2 - 10, 20, rl/black)
|
||||||
|
;; The C's TextFormat("Collision Area: %i", ...). Both dimensions are
|
||||||
|
;; truncated to int before multiplying, as the C's two casts do.
|
||||||
|
let x = rl/get-screen-width() / 2 - 100
|
||||||
|
y = screen-upper-limit + 10
|
||||||
|
x += d/draw-piece("Collision Area: ", x, y, 20, rl/black)
|
||||||
|
d/draw-int(i32(box-collision.width) * i32(box-collision.height), x, y,
|
||||||
|
20, rl/black)
|
||||||
|
rl/draw-text("Press SPACE to PAUSE/RESUME", 20, screen-height - 35, 20,
|
||||||
|
rl/lightgray)
|
||||||
|
rl/draw-fps(10, 10)
|
||||||
@@ -5,8 +5,8 @@
|
|||||||
;;;; subtract two points, take the angle, walk back out along it — and every
|
;;;; subtract two points, take the angle, walk back out along it — and every
|
||||||
;;;; one of those steps is raymath. raymath is `static inline` in
|
;;;; one of those steps is raymath. raymath is `static inline` in
|
||||||
;;;; raymath.h, so Vector2Subtract and Vector2Angle have no symbol in
|
;;;; raymath.h, so Vector2Subtract and Vector2Angle have no symbol in
|
||||||
;;;; libraylib at all and there is nothing for declare-c to bind. NEXT.md
|
;;;; libraylib at all and there is nothing for declare-c to bind. TODO.org,
|
||||||
;;;; names this as one of the three open gaps.
|
;;;; "raymath is written in Flan, because static inline has no symbol".
|
||||||
;;;;
|
;;;;
|
||||||
;;;; What that costs here is nothing, because the C does not use raymath
|
;;;; What that costs here is nothing, because the C does not use raymath
|
||||||
;;;; either — it writes the four subtractions out and calls atan2f, cosf and
|
;;;; either — it writes the four subtractions out and calls atan2f, cosf and
|
||||||
@@ -18,7 +18,7 @@
|
|||||||
;;;; file.
|
;;;; file.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; That measurement is what decided the answer, and the answer landed:
|
;;;; That measurement is what decided the answer, and the answer landed:
|
||||||
;;;; vendor/raylib/vector.flan is raymath written in Flan, since a C shim
|
;;;; vendor/raylib/vector.fln is raymath written in Flan, since a C shim
|
||||||
;;;; re-exporting the inlines would have bought identical arithmetic at the
|
;;;; re-exporting the inlines would have bought identical arithmetic at the
|
||||||
;;;; price of a compilation unit and a second place raylib's semantics live.
|
;;;; price of a compilation unit and a second place raylib's semantics live.
|
||||||
;;;; The measurement is left standing rather than rewritten away — one
|
;;;; The measurement is left standing rather than rewritten away — one
|
||||||
@@ -27,7 +27,7 @@
|
|||||||
;;;; for a zero-length vector where a normalise would. One line saved, in a
|
;;;; for a zero-length vector where a normalise would. One line saved, in a
|
||||||
;;;; file that is nothing but vector maths, is the honest size of the gap.
|
;;;; file that is nothing but vector maths, is the honest size of the gap.
|
||||||
;;;;
|
;;;;
|
||||||
;;;; The raylib call it does exercise is collision-point-circle?, which no
|
;;;; The raylib call it does exercise is check-collision-point-circle, which no
|
||||||
;;;; ported example had called, on a frame path, with the point coming
|
;;;; ported example had called, on a frame path, with the point coming
|
||||||
;;;; straight out of get-mouse-position — one struct out of raylib and back
|
;;;; straight out of get-mouse-position — one struct out of raylib and back
|
||||||
;;;; into it untouched.
|
;;;; into it untouched.
|
||||||
@@ -37,18 +37,18 @@
|
|||||||
;;;; centre, so the iris disc is tangent to the sclera's edge at the extreme
|
;;;; centre, so the iris disc is tangent to the sclera's edge at the extreme
|
||||||
;;;; rather than hanging over it.
|
;;;; rather than hanging over it.
|
||||||
|
|
||||||
(import rl "vendor:raylib")
|
import rl "vendor:raylib"
|
||||||
|
|
||||||
(defconst screen-width 800)
|
const screen-width = 800
|
||||||
(defconst screen-height 450)
|
const screen-height = 450
|
||||||
|
|
||||||
(defconst sclera-radius f32 80.0)
|
const sclera-radius: f32 = 80.0
|
||||||
(defconst iris-radius f32 24.0)
|
const iris-radius: f32 = 24.0
|
||||||
|
|
||||||
(defvar sclera-left rl/Vector2)
|
once sclera-left: rl/Vector2
|
||||||
(defvar sclera-right rl/Vector2)
|
once sclera-right: rl/Vector2
|
||||||
(defvar iris-left rl/Vector2)
|
once iris-left: rl/Vector2
|
||||||
(defvar iris-right rl/Vector2)
|
once iris-right: rl/Vector2
|
||||||
|
|
||||||
;; One eye's pupil, given where the mouse is and where the eye is. Answers the
|
;; One eye's pupil, given where the mouse is and where the eye is. Answers the
|
||||||
;; mouse position unchanged while it is inside the eye, and the point on the
|
;; mouse position unchanged while it is inside the eye, and the point on the
|
||||||
@@ -57,54 +57,45 @@
|
|||||||
;; The C repeats this block twice with different variables; it is one function
|
;; The C repeats this block twice with different variables; it is one function
|
||||||
;; here because the two copies are identical and a difference between them
|
;; here because the two copies are identical and a difference between them
|
||||||
;; would be invisible.
|
;; would be invisible.
|
||||||
(defn track [mouse rl/Vector2 centre rl/Vector2] rl/Vector2
|
fn track(mouse: rl/Vector2, centre: rl/Vector2) -> rl/Vector2
|
||||||
(let [limit (- sclera-radius iris-radius)]
|
let limit = sclera-radius - iris-radius
|
||||||
(if (rl/collision-point-circle? mouse centre limit)
|
if rl/check-collision-point-circle(mouse, centre, limit)
|
||||||
mouse
|
mouse
|
||||||
;; Outside: the direction from the eye to the mouse, and then `limit`
|
;; Outside: the direction from the eye to the mouse, and then `limit`
|
||||||
;; units back out along it. atan2 then cos/sin rather than a normalise,
|
;; units back out along it. atan2 then cos/sin rather than a normalise,
|
||||||
;; because that is what the C does and because it needs no guard for a
|
;; because that is what the C does and because it needs no guard for a
|
||||||
;; zero-length vector — atan2(0,0) is 0 and the pupil sits at the right
|
;; zero-length vector — atan2(0,0) is 0 and the pupil sits at the right
|
||||||
;; of the eye, which is unreachable anyway since (0,0) is inside.
|
;; of the eye, which is unreachable anyway since (0,0) is inside.
|
||||||
(let [d (rl/v2-sub mouse centre)
|
else
|
||||||
angle (atan2-f32 (.y d) (.x d))]
|
let d = rl/v2-sub(mouse, centre)
|
||||||
(rl/Vector2 {.x (+ (.x centre) (* limit (cos-f32 angle)))
|
angle = atan2-f32(d.y, d.x)
|
||||||
.y (+ (.y centre) (* limit (sin-f32 angle)))})))))
|
rl/Vector2{.x centre.x + limit * cos-f32(angle), .y centre.y + limit * sin-f32(angle)}
|
||||||
|
|
||||||
(defn main [] ()
|
|
||||||
(rl/init-window screen-width screen-height
|
|
||||||
"raylib [shapes] example - following eyes")
|
|
||||||
(defer (rl/close-window))
|
|
||||||
|
|
||||||
|
fn main() -> ()
|
||||||
|
rl/init-window(screen-width, screen-height,
|
||||||
|
"raylib [shapes] example - following eyes")
|
||||||
|
defer rl/close-window()
|
||||||
;; The C reads these off get-screen-width/get-screen-height after the window
|
;; The C reads these off get-screen-width/get-screen-height after the window
|
||||||
;; is open rather than off the constants, and so does this: on a high-DPI
|
;; is open rather than off the constants, and so does this: on a high-DPI
|
||||||
;; display the two can differ.
|
;; display the two can differ.
|
||||||
(set sclera-left (rl/Vector2 {.x (- (/ (f32 (rl/get-screen-width)) 2.0) 100.0)
|
sclera-left = rl/Vector2{.x f32(rl/get-screen-width()) / 2.0 - 100.0, .y f32(rl/get-screen-height()) / 2.0}
|
||||||
.y (/ (f32 (rl/get-screen-height)) 2.0)}))
|
sclera-right = rl/Vector2{.x f32(rl/get-screen-width()) / 2.0 + 100.0, .y f32(rl/get-screen-height()) / 2.0}
|
||||||
(set sclera-right (rl/Vector2 {.x (+ (/ (f32 (rl/get-screen-width)) 2.0) 100.0)
|
iris-left = sclera-left
|
||||||
.y (/ (f32 (rl/get-screen-height)) 2.0)}))
|
iris-right = sclera-right
|
||||||
(set iris-left sclera-left)
|
rl/set-target-fps(60)
|
||||||
(set iris-right sclera-right)
|
until rl/window-should-close()
|
||||||
|
|
||||||
(rl/set-target-fps 60)
|
|
||||||
|
|
||||||
(until (rl/window-should-close?)
|
|
||||||
;; Update
|
;; Update
|
||||||
(let [mouse (rl/get-mouse-position)]
|
let mouse = rl/get-mouse-position()
|
||||||
(set iris-left (track mouse sclera-left))
|
iris-left = track(mouse, sclera-left)
|
||||||
(set iris-right (track mouse sclera-right)))
|
iris-right = track(mouse, sclera-right)
|
||||||
|
|
||||||
;; Draw
|
;; Draw
|
||||||
(rl/with-drawing
|
rl/with-drawing:
|
||||||
(rl/clear-background rl/raywhite)
|
rl/clear-background(rl/raywhite)
|
||||||
|
|
||||||
;; White of the eye, iris, pupil — in that order, each over the last.
|
;; White of the eye, iris, pupil — in that order, each over the last.
|
||||||
(rl/draw-circle-v sclera-left sclera-radius rl/lightgray)
|
rl/draw-circle-v(sclera-left, sclera-radius, rl/lightgray)
|
||||||
(rl/draw-circle-v iris-left iris-radius rl/brown)
|
rl/draw-circle-v(iris-left, iris-radius, rl/brown)
|
||||||
(rl/draw-circle-v iris-left 10.0 rl/black)
|
rl/draw-circle-v(iris-left, 10.0, rl/black)
|
||||||
|
rl/draw-circle-v(sclera-right, sclera-radius, rl/lightgray)
|
||||||
(rl/draw-circle-v sclera-right sclera-radius rl/lightgray)
|
rl/draw-circle-v(iris-right, iris-radius, rl/darkgreen)
|
||||||
(rl/draw-circle-v iris-right iris-radius rl/darkgreen)
|
rl/draw-circle-v(iris-right, 10.0, rl/black)
|
||||||
(rl/draw-circle-v iris-right 10.0 rl/black)
|
rl/draw-fps(10, 10)
|
||||||
|
|
||||||
(rl/draw-fps 10 10))))
|
|
||||||
Loaded 100 of 863 files, more files were not shown because too many files have changed in this diff.
Show more
Reference in new issue
Block a user