Merge master into the dyn char lane
This commit is contained in:
commit
f35a2b240a
10
CLAUDE.md
10
CLAUDE.md
@ -23,10 +23,12 @@ saying what is now true, not what was done.
|
||||
|
||||
## Tests
|
||||
|
||||
`dune test --root .` must be green before a lane reports; grep its output for
|
||||
FAIL, since the exit code alone has lied. `@checks` (`@page`, `@x86`, `@cells`),
|
||||
`@sanitize` and `@valgrind` are slow and run once between batches of lanes, with
|
||||
the author's permission, never inside a lane. ASan misses uninitialised stack
|
||||
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.
|
||||
|
||||
## Evidence
|
||||
|
||||
41
TODO.org
41
TODO.org
@ -10,6 +10,12 @@ pointing at it. A CANCELLED entry carries the one-line reason, because an idea
|
||||
rejected without a record is an idea that gets re-proposed.
|
||||
|
||||
* Language surface
|
||||
** NEXT A typed char
|
||||
Decided 2026-09-26 (127): =char= is a typed code point. A char literal is typed by local
|
||||
inference like a number literal: u8 or i32 where typed code wants a number (a literal
|
||||
above 127 is refused as a u8), =char= otherwise; a =char= crossing into dyn stays a char.
|
||||
Rules out the fork where =f(\a)= printed =\a= and =let c = \a= then =f(c)= printed 97.
|
||||
Waits on the dyn char lane and the literal inference lane.
|
||||
** NEXT if let
|
||||
Decided 2026-09-26 (126), Rust's spelling: =if let Some(g) = left= plus a block tests
|
||||
the pattern and binds =g= in that block only; =elif=/=else= follow as for =if=. Any
|
||||
@ -45,14 +51,28 @@ class's float slot's rule), and a u64 above the largest i64 traps when read. A v
|
||||
storage its own dyn global's initialiser built is refused. Rules out copying at the
|
||||
crossing, a dyn big int for u64, and any check in a release build.
|
||||
|
||||
** DONE A dyn value crosses into a str, a slice, an array or a struct
|
||||
CLOSED: [2026-09-26]
|
||||
A writable [T] is never a copy: a plain dyn vec into one traps and names [const T], so a
|
||||
write can never miss the vec. A str from a text is its own bytes, live at least until the
|
||||
next free-temp. Rules out copy-in/copy-out at a call, and rooting the text in the crossing's frame.
|
||||
|
||||
** NEXT Dyn unless annotated
|
||||
Decided 2026-09-26, replacing the plain rule: number, bool and char literals are typed,
|
||||
their type inferred from their uses inside the function (never across functions); an
|
||||
unconstrained integer literal is int (i32) and a float literal float (f32); uses that
|
||||
unconstrained integer literal is int (i32) and a float literal f64 (decision 121); uses that
|
||||
disagree are refused with a request for an annotation. Vector, map and text literals
|
||||
are dyn unless something typed wants them. A typed value is boxed where it goes into
|
||||
dyn, and a dyn unboxed (checked) where typed code needs it; typed beside dyn in an
|
||||
operator gives dyn. Dyn integers stay i64 and dyn floats f64.
|
||||
Decision 121: f64 and not f32, because f32 locals lost precision silently — 0.1 summed a
|
||||
million times printed 100958. A float literal is f32 only where inference finds typed code
|
||||
wanting f32 (a parameter, field, return or operand). A literal local fed only by dyn takes
|
||||
the dyn width, i64 or f64.
|
||||
Done: local inference (check.ml [lit_session]), an integer and a float literal meeting
|
||||
at the float. Waiting: text and vector literals dyn by default, on
|
||||
dyn text to str and dyn vec to slice conversion (a lane after views); =FLAN_LIT=dyn=
|
||||
measures it, and under it a let-bound one some typed use wants already stays typed.
|
||||
** DONE Dynamic-first, and the dyn half of the language
|
||||
CLOSED: [2026-09-20]
|
||||
An unannotated parameter or return is =dyn=: a NaN-boxed value over a mark-sweep
|
||||
@ -145,6 +165,14 @@ expansion that defines a macro re-runs the expander, in a build and in a session
|
||||
no =,',x=, since =quote= takes a symbol, and a macro defined by an expansion is
|
||||
not exported from a package. docs/BUILT.md, "Quasiquote runs before the walk".
|
||||
|
||||
** DONE Bit operators are && || ^^ ~~ in .fln (decision 123)
|
||||
CLOSED: [2026-09-26]
|
||||
Tighter than a comparison, looser than a shift, =&&= then =^^= then =||=
|
||||
(Python and Rust), so =x && mask == 0= tests the masked bits. Integers only, a
|
||||
bool refused toward =and=/=or=/=not=; a dyn shift count outside 0..63 traps.
|
||||
=~~= is one token, so a nested .fln unquote is =~(~x)=; the paren reader keeps
|
||||
=~~x= as unquote twice and reads =^^= as a name. Rules out C's precedence.
|
||||
|
||||
** DONE A form the prelude relies on is built in; a form only programs use is a macro
|
||||
CLOSED: [2026-09-25]
|
||||
=cond=, =when= and =dotimes= are special forms in parse.ml; =inc=, =++=, =into=,
|
||||
@ -696,6 +724,10 @@ consecutive lets this way.
|
||||
Rules out ~loop~/~recur~ anywhere the .fln reader reads, ~quote~ included; loops are
|
||||
~while~/~until~/~dotimes~/~for~. The Lisp syntax and its macros' expansions keep them.
|
||||
|
||||
** DONE A .fln chain may mix < with <=, or > with >= (decision 124)
|
||||
~0 <= r < rows~ is the ~and~ of its tests; like ~(< a b c)~ every operand runs once, left to right,
|
||||
with no short-circuit. Direction changes and ~==~/~!=~ in a mix stay refused.
|
||||
|
||||
** TODO Hard-coded code in messages is still paren syntax in a .fln file
|
||||
Types follow the code's syntax now (=Types.spell=). Hints written into a message's
|
||||
text — =(Ptr %s)=, =(clone v)=, =(the T x)= in most of =check.ml= and =parse.ml=, the
|
||||
@ -738,6 +770,9 @@ One spelling for one operation; != stays, and not= is refused with a suggestion
|
||||
of !=.
|
||||
|
||||
* Checker
|
||||
** TODO Checking a wide fold of let operands is slow
|
||||
A 2000-operand (bit-and (let …) …) takes 32 s to check (37 s before the bit operators);
|
||||
2000 plain names take 0.03 s. Something per operand is quadratic or worse.
|
||||
|
||||
** DONE A dyn value takes .field and [:key]
|
||||
CLOSED: [2026-09-26]
|
||||
@ -1539,6 +1574,10 @@ are a dyn vector, except numbers with no common type, which are refused. Rules
|
||||
out the first element typing the rest.
|
||||
|
||||
* Dev loop
|
||||
** TODO --dev bookkeeping per temp allocation grows without free-temp
|
||||
Under --dev each temp allocation (i64->bytes, dyn text crossing into str) costs about
|
||||
340 bytes of registry notes until free-temp; a loop passing dyn text as str 4M times
|
||||
without free-temp reaches 2.7 GB. Release stays flat. A CLI that never frees temp hits it.
|
||||
|
||||
** WAIT A _ caller whose type follows a redefined callee
|
||||
Its signature changes in the session but its body is not recompiled, so every call
|
||||
|
||||
@ -77,7 +77,8 @@ fine here. Brackets and strings are still paired."
|
||||
;; that starts with one, or follows a line that ends with one, continues the
|
||||
;; line above.
|
||||
(defconst flan-fln--binops
|
||||
'("or" "and" "==" "!=" "<" "<=" ">" ">=" "<<" ">>" "+" "-" "*" "/" "%"))
|
||||
'("or" "and" "==" "!=" "<" "<=" ">" ">=" "||" "^^" "&&" "<<" ">>" "+" "-" "*"
|
||||
"/" "%"))
|
||||
|
||||
(defconst flan-fln--binop-re (regexp-opt flan-fln--binops))
|
||||
|
||||
|
||||
@ -154,7 +154,9 @@ face says.")
|
||||
(defconst flan--builtins
|
||||
'(;; arithmetic, comparison, bits
|
||||
"+" "-" "*" "/" "%" "=" "!=" "<" "<=" ">" ">=" "not"
|
||||
"bit-and" "bit-or" "bit-xor" "<<" ">>" "min" "max"
|
||||
"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
|
||||
|
||||
@ -188,6 +188,21 @@ fn step() -> ()
|
||||
(test-flan-fln--is "and not the start of the body"
|
||||
(test-flan-fln--thing 'flan-fln-body) "grid[r, c] = 1"))
|
||||
|
||||
;; The bit operators continue a line as the other spaced operators do.
|
||||
;; Not through `test-flan-fln--in', whose `|' marks point and would eat one
|
||||
;; half of `||'.
|
||||
(dolist (op '("&&" "||" "^^"))
|
||||
(with-temp-buffer
|
||||
(insert "x = a " op "\n b\ny = a\n " op " b\n")
|
||||
(flan-fln-mode)
|
||||
(goto-char (point-min))
|
||||
(forward-line 1)
|
||||
(test-flan--check (concat "a line after a trailing " op " continues it")
|
||||
(flan-fln--continuation-p (point)))
|
||||
(forward-line 2)
|
||||
(test-flan--check (concat "a line starting with " op " continues")
|
||||
(flan-fln--continuation-p (point)))))
|
||||
|
||||
(test-flan-fln--in (test-flan-fln--at test-flan-fln--settle "velocity[row, col] = 0.0")
|
||||
(test-flan-fln--is "a top-level form ends before trailing comment lines"
|
||||
(test-flan-fln--thing 'flan-fln-toplevel)
|
||||
|
||||
1070
lib/check.ml
1070
lib/check.ml
File diff suppressed because it is too large
Load Diff
60
lib/emit.ml
60
lib/emit.ml
@ -1478,6 +1478,7 @@ let settled_prim (p : Tast.prim) =
|
||||
| Tast.Add | Tast.Sub | Tast.Mul
|
||||
| Tast.Eq | Tast.Ne | Tast.Lt | Tast.Le | Tast.Gt | Tast.Ge | Tast.Not
|
||||
| Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr
|
||||
| Tast.BitNot | Tast.Popcount | Tast.Clz | Tast.Ctz | Tast.Rotl | Tast.Rotr
|
||||
(* Questions about a value's shape, answered from the layout tables. *)
|
||||
| Tast.Len | Tast.SizeOf _ | Tast.AlignOf _ | Tast.AddrOf -> true
|
||||
(* Everything else reaches C, signals, or both: an index and a slice are
|
||||
@ -3873,6 +3874,33 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
|
||||
let t = fresh f in
|
||||
ins f "%s = xor i1 %s, true" t a;
|
||||
t
|
||||
| Tast.BitNot, [ x ] ->
|
||||
let a = value f x in
|
||||
let t = fresh f in
|
||||
ins f "%s = xor %s %s, -1" t (ll x.Tast.ty) a;
|
||||
t
|
||||
(* [i1 false] says a zero operand is defined — the width — rather than
|
||||
poison, which is the language's answer for 0. *)
|
||||
| (Tast.Popcount | Tast.Clz | Tast.Ctz), [ x ] ->
|
||||
let a = value f x in
|
||||
let ty = ll x.Tast.ty in
|
||||
let t = fresh f in
|
||||
(match p with
|
||||
| Tast.Popcount -> ins f "%s = call %s @llvm.ctpop.%s(%s %s)" t ty ty ty a
|
||||
| Tast.Clz ->
|
||||
ins f "%s = call %s @llvm.ctlz.%s(%s %s, i1 false)" t ty ty ty a
|
||||
| _ -> ins f "%s = call %s @llvm.cttz.%s(%s %s, i1 false)" t ty ty ty a);
|
||||
t
|
||||
(* A funnel shift of a value with itself is a rotation, and the funnel
|
||||
shifts take their count modulo the width, which is the rotation's rule. *)
|
||||
| (Tast.Rotl | Tast.Rotr), [ x; y ] ->
|
||||
let a = value f x in
|
||||
let b = value f y in
|
||||
let ty = ll x.Tast.ty in
|
||||
let t = fresh f in
|
||||
ins f "%s = call %s @llvm.%s.%s(%s %s, %s %s, %s %s)" t ty
|
||||
(if p = Tast.Rotl then "fshl" else "fshr") ty ty a ty a ty b;
|
||||
t
|
||||
| Tast.Len, [ x ] ->
|
||||
(match x.Tast.ty with
|
||||
| Types.Array (n, _) -> Int64.to_string n
|
||||
@ -4931,6 +4959,26 @@ let header = {|; Generated by flan. The layout is C's: no object headers anywher
|
||||
|
||||
declare void @llvm.memset.p0.i64(ptr nocapture writeonly, i8, i64, i1 immarg)
|
||||
declare i32 @llvm.bswap.i32(i32)
|
||||
declare i8 @llvm.ctpop.i8(i8)
|
||||
declare i8 @llvm.ctlz.i8(i8, i1 immarg)
|
||||
declare i8 @llvm.cttz.i8(i8, i1 immarg)
|
||||
declare i8 @llvm.fshl.i8(i8, i8, i8)
|
||||
declare i8 @llvm.fshr.i8(i8, i8, i8)
|
||||
declare i16 @llvm.ctpop.i16(i16)
|
||||
declare i16 @llvm.ctlz.i16(i16, i1 immarg)
|
||||
declare i16 @llvm.cttz.i16(i16, i1 immarg)
|
||||
declare i16 @llvm.fshl.i16(i16, i16, i16)
|
||||
declare i16 @llvm.fshr.i16(i16, i16, i16)
|
||||
declare i32 @llvm.ctpop.i32(i32)
|
||||
declare i32 @llvm.ctlz.i32(i32, i1 immarg)
|
||||
declare i32 @llvm.cttz.i32(i32, i1 immarg)
|
||||
declare i32 @llvm.fshl.i32(i32, i32, i32)
|
||||
declare i32 @llvm.fshr.i32(i32, i32, i32)
|
||||
declare i64 @llvm.ctpop.i64(i64)
|
||||
declare i64 @llvm.ctlz.i64(i64, i1 immarg)
|
||||
declare i64 @llvm.cttz.i64(i64, i1 immarg)
|
||||
declare i64 @llvm.fshl.i64(i64, i64, i64)
|
||||
declare i64 @llvm.fshr.i64(i64, i64, i64)
|
||||
declare ptr @llvm.frameaddress.p0(i32 immarg)
|
||||
declare void @flan_rt_init(i32, ptr)
|
||||
declare void @flan_argv(ptr)
|
||||
@ -5037,6 +5085,17 @@ declare i64 @flan_dyn_mul(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_div(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_rem(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_neg(i64, ptr, i64)
|
||||
declare i64 @flan_dyn_bitand(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_bitor(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_bitxor(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_bitnot(i64, ptr, i64)
|
||||
declare i64 @flan_dyn_shl(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_shr(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_rotl(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_rotr(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_popcount(i64, ptr, i64)
|
||||
declare i64 @flan_dyn_clz(i64, ptr, i64)
|
||||
declare i64 @flan_dyn_ctz(i64, ptr, i64)
|
||||
declare i64 @flan_dyn_lt(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_le(i64, i64, ptr, i64)
|
||||
declare i64 @flan_dyn_gt(i64, i64, ptr, i64)
|
||||
@ -5085,6 +5144,7 @@ declare i64 @flan_dyn_need_not_nil(i64)
|
||||
declare i32 @flan_dyn_truthy(i64)
|
||||
declare i64 @flan_dyn_view_slice(ptr, i64, ptr, i64, i32)
|
||||
declare i64 @flan_dyn_view_at(ptr, i64, ptr, i64, i32, i32)
|
||||
declare void @flan_dyn_need_as(i64, ptr, i64, ptr, ptr, i64)
|
||||
declare void @flan_dyn_root_push(ptr)
|
||||
declare void @flan_dyn_root_push_desc(ptr, ptr)
|
||||
declare ptr @flan_dyn_env_new(i64, ptr)
|
||||
|
||||
@ -173,6 +173,92 @@ let rec pat_names (t : Form.t) : string list option =
|
||||
|
||||
let binds n t = match pat_names t with Some ns -> List.mem n ns | None -> false
|
||||
|
||||
(* [f] as a comparison chain that mixes < with <=, or > with >=: its operands
|
||||
and operators, when the reader would read the chain back as [f] itself.
|
||||
The candidate is rebuilt by the reader's own [cmp_chain] and compared up to
|
||||
the names its [let]s bind, so an [and] of tests that only looks like a
|
||||
chain, or a [let] the reader would not have made, prints as it is. *)
|
||||
let chain_of (f : Form.t) =
|
||||
let rec eq env (a : Form.t) (b : Form.t) =
|
||||
match a.v, b.v with
|
||||
| Form.Sym x, Form.Sym y ->
|
||||
(match List.assoc_opt x env with
|
||||
| Some y' -> y = y'
|
||||
| None -> x = y && not (List.exists (fun (_, y') -> y' = y) env))
|
||||
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bx; _ } :: xs),
|
||||
Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec by; _ } :: ys) ->
|
||||
let rec binds env bx by =
|
||||
match bx, by with
|
||||
| ({ Form.v = Form.Sym tx; _ }) :: vx :: bx', ({ Form.v = Form.Sym ty; _ }) :: vy :: by' ->
|
||||
if eq env vx vy then binds ((tx, ty) :: env) bx' by' else None
|
||||
| [], [] -> Some env
|
||||
| _ -> None
|
||||
in
|
||||
(match binds env bx by with
|
||||
| Some env -> List.length xs = List.length ys && List.for_all2 (eq env) xs ys
|
||||
| None -> false)
|
||||
| Form.List xs, Form.List ys | Form.Vec xs, Form.Vec ys | Form.Map xs, Form.Map ys ->
|
||||
List.length xs = List.length ys && List.for_all2 (eq env) xs ys
|
||||
| x, y -> x = y
|
||||
in
|
||||
let subst env (x : Form.t) =
|
||||
match x.v with
|
||||
| Form.Sym s -> Option.value (List.assoc_opt s env) ~default:x
|
||||
| _ -> x
|
||||
in
|
||||
(* The tests, left to right, with each bound name replaced by its value. *)
|
||||
let rec tests env (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym "let"; _ }; { v = Form.Vec bs; _ }; body ] ->
|
||||
let rec binds env = function
|
||||
| ({ Form.v = Form.Sym t; _ }) :: v :: rest -> binds ((t, subst env v) :: env) rest
|
||||
| [] -> Some env
|
||||
| _ -> None
|
||||
in
|
||||
Option.bind (binds env bs) (fun env -> tests env body)
|
||||
| Form.List ({ v = Form.Sym "and"; _ } :: (_ :: _ :: _ as cs)) ->
|
||||
List.fold_left
|
||||
(fun acc c -> Option.bind acc (fun l -> Option.map (( @ ) l) (tests env c)))
|
||||
(Some []) cs
|
||||
| Form.List [ { v = Form.Sym op; _ }; a; b ] when R.cmp_dir op <> None ->
|
||||
Some [ (op, subst env a, subst env b) ]
|
||||
| _ -> None
|
||||
in
|
||||
let rec linked = function
|
||||
| (_, _, b) :: ((_, a, _) :: _ as rest) -> eq [] b a && linked rest
|
||||
| _ -> true
|
||||
in
|
||||
(* In a template the paren text spells a [~cmp] name as the unquoted call
|
||||
that makes it, [~(Form.Sym {.s "~cmp1"})]: read it as the name. *)
|
||||
let rec unwrap (x : Form.t) =
|
||||
match x.v with
|
||||
| Form.List [ { v = Form.Sym "unquote"; _ };
|
||||
{ v = Form.List [ { v = Form.Sym "Form.Sym"; _ };
|
||||
{ v = Form.Map [ { v = Form.Sym ".s"; _ };
|
||||
{ v = Form.Str n; _ } ]; _ } ]; _ } ]
|
||||
when String.length n > 4 && String.sub n 0 4 = "~cmp" -> { x with v = Form.Sym n }
|
||||
| Form.List l -> { x with v = Form.List (List.map unwrap l) }
|
||||
| Form.Vec l -> { x with v = Form.Vec (List.map unwrap l) }
|
||||
| _ -> x
|
||||
in
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym ("and" | "let"); _ } :: _) ->
|
||||
let f = unwrap f in
|
||||
(match tests [] f with
|
||||
| Some (((op1, x0, _) :: _ :: _) as ts)
|
||||
when linked ts
|
||||
&& List.for_all (fun (op, _, _) -> R.cmp_dir op = R.cmp_dir op1) ts
|
||||
&& List.exists (fun (op, _, _) -> op <> op1) ts ->
|
||||
let xs = x0 :: List.map (fun (_, _, b) -> b) ts in
|
||||
let ops = List.map (fun (op, _, _) -> op) ts in
|
||||
let n = ref 0 in
|
||||
let fresh () = incr n; Printf.sprintf "~cmp%d" !n in
|
||||
if eq [] f (R.cmp_chain ~fresh f.loc xs ops) then Some (xs, ops) else None
|
||||
| _ -> None)
|
||||
| _ -> None
|
||||
|
||||
let is_chain f = chain_of f <> None
|
||||
|
||||
(* Whether [f] mentions [n]: the name, or a field path or qualified name
|
||||
starting with it. Any occurrence counts, a quoted one or one under an
|
||||
unquote included. A macro whose expansion names a variable its call does
|
||||
@ -266,7 +352,7 @@ let rename_let n n' (bs : Form.t list) (body : Form.t list) =
|
||||
let flatten (f : Form.t) (rest : Form.t list) =
|
||||
match f.v with
|
||||
| Form.List (({ v = Form.Sym "let"; _ } as h) :: ({ v = Form.Vec bs; _ } as bv) :: (_ :: _ as body))
|
||||
when rest <> [] && bs <> [] && List.length bs mod 2 = 0 ->
|
||||
when rest <> [] && bs <> [] && List.length bs mod 2 = 0 && not (is_chain f) ->
|
||||
Option.bind
|
||||
(all pat_names (List.filteri (fun i _ -> i mod 2 = 0) bs))
|
||||
(fun names ->
|
||||
@ -296,36 +382,49 @@ let flatten (f : Form.t) (rest : Form.t list) =
|
||||
|
||||
(* ── Expressions ───────────────────────────────────────────────────── *)
|
||||
|
||||
(* Text and syntactic level, the same scale [Indent_reader] reads: 10 an atom
|
||||
or bracket, 9 a postfix chain, 8 a unary minus, 1-7 binary, 3 [not], 0 a
|
||||
one-line [if] or a lambda. *)
|
||||
(* Text and syntactic level, the same scale [Indent_reader] reads: 13 an atom
|
||||
or bracket, 12 a postfix chain, 11 a prefix [-] or [~~], 1-10 binary, 3
|
||||
[not], 0 a one-line [if] or a lambda. *)
|
||||
(* The operator a head prints as: [=] is [==], and the bit words are the
|
||||
operators the reader turns into them. *)
|
||||
let infix_op = function
|
||||
| "=" -> "==" | "bit-and" -> "&&" | "bit-or" -> "||" | "bit-xor" -> "^^"
|
||||
| s -> s
|
||||
|
||||
let rec expr (f : Form.t) : string * int =
|
||||
match f.v with
|
||||
| Form.Sym s when !hole && s = hole_sym -> (s, 0)
|
||||
| Form.Sym s -> sym f s
|
||||
| Form.Kw k ->
|
||||
if kw_ok k then (":" ^ k, 10) else unprintable f "a keyword with no spelling"
|
||||
if kw_ok k then (":" ^ k, 13) else unprintable f "a keyword with no spelling"
|
||||
| Form.Int i ->
|
||||
let t = Option.value (!spelling f) ~default:(Int64.to_string i) in
|
||||
(t, if t.[0] = '-' then 8 else 10)
|
||||
| Form.UInt (_, s) -> (s, 10)
|
||||
(t, if t.[0] = '-' then 11 else 13)
|
||||
| Form.UInt (_, s) -> (s, 13)
|
||||
| Form.Float x ->
|
||||
let s = Option.value (!spelling f) ~default:(Form.float_repr x) in
|
||||
if not (Reader.is_digit s.[0] || (s.[0] = '-' && String.length s > 1
|
||||
&& Reader.is_digit s.[1]))
|
||||
then unprintable f "a float with no literal";
|
||||
(s, if s.[0] = '-' then 8 else 10)
|
||||
| Form.Str s -> ("\"" ^ Form.escape s ^ "\"", 10)
|
||||
| Form.Byte b -> (Form.byte_repr b, 10)
|
||||
| Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 10)
|
||||
| Form.Map xs -> ("{" ^ map_text xs ^ "}", 10)
|
||||
| Form.List [] -> ("()", 10)
|
||||
(s, if s.[0] = '-' then 11 else 13)
|
||||
| Form.Str s -> ("\"" ^ Form.escape s ^ "\"", 13)
|
||||
| Form.Byte b -> (Form.byte_repr b, 13)
|
||||
| Form.Vec xs -> ("[" ^ vec_text xs ^ "]", 13)
|
||||
| Form.Map xs -> ("{" ^ map_text xs ^ "}", 13)
|
||||
| Form.List [] -> ("()", 13)
|
||||
| Form.List _ when is_chain f ->
|
||||
let xs, ops = Option.get (chain_of f) in
|
||||
let lvl = Option.get (R.binop_level (List.hd ops)) in
|
||||
let ts = List.map (at (lvl + 1)) xs in
|
||||
(List.hd ts
|
||||
^ String.concat "" (List.map2 (fun op t -> " " ^ op ^ " " ^ t) ops (List.tl ts)),
|
||||
lvl)
|
||||
| Form.List (h :: args) -> in_quasi f (fun () -> list f h args)
|
||||
|
||||
and sym f s =
|
||||
if s = "==" then unprintable f "the name == (it reads as =)"
|
||||
else if R.is_op_word s || s = "if" then (paren s, 10)
|
||||
else if name_ok s then (s, 10)
|
||||
else if R.is_op_word s || s = "if" then (paren s, 13)
|
||||
else if name_ok s then (s, 13)
|
||||
else unprintable f (Printf.sprintf "the name %s" s)
|
||||
|
||||
and at lvl f =
|
||||
@ -347,16 +446,16 @@ and commas xs = String.concat ", " (comma_items xs)
|
||||
as soon as one element has an operator in it. *)
|
||||
and vec_text xs =
|
||||
let ts = List.map expr xs in
|
||||
if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts)
|
||||
if List.for_all (fun (_, l) -> l >= 11) ts then String.concat " " (List.map fst ts)
|
||||
else String.concat ", " (List.map (fun (t, _) -> t) ts)
|
||||
|
||||
and map_text xs =
|
||||
let ts = List.map expr xs in
|
||||
if List.for_all (fun (_, l) -> l >= 8) ts then String.concat " " (List.map fst ts)
|
||||
if List.for_all (fun (_, l) -> l >= 11) ts then String.concat " " (List.map fst ts)
|
||||
else
|
||||
let rec pairs = function
|
||||
| (k, kl) :: (v, _) :: rest ->
|
||||
((if kl < 8 then paren k else k) ^ " " ^ v) :: pairs rest
|
||||
((if kl < 11 then paren k else k) ^ " " ^ v) :: pairs rest
|
||||
| [ (k, _) ] -> [ k ]
|
||||
| [] -> []
|
||||
in
|
||||
@ -367,22 +466,26 @@ and head_text (h : Form.t) =
|
||||
| Form.Sym "==" -> unprintable h "the name =="
|
||||
| Form.Sym s when R.is_op_word s -> s
|
||||
| Form.Sym s -> fst (sym h s)
|
||||
| _ -> at 9 h
|
||||
| _ -> at 12 h
|
||||
|
||||
and list f h args =
|
||||
let call () = (head_text h ^ "(" ^ commas args ^ ")", 9) in
|
||||
let call () = (head_text h ^ "(" ^ commas args ^ ")", 12) in
|
||||
match h.v, args with
|
||||
| Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 10)
|
||||
| Form.Sym "unquote", [ x ] -> ("~" ^ at 10 x, 10)
|
||||
| Form.Sym "unquote-splicing", [ x ] -> ("~@" ^ at 10 x, 10)
|
||||
| Form.Sym "quote", [ x ] -> ("'" ^ Form.to_source x, 13)
|
||||
(* [~~] is bit-not, so an unquote of anything that starts with [~] is
|
||||
parenthesised: [~(~x)]. *)
|
||||
| Form.Sym "unquote", [ x ] ->
|
||||
let t = at 13 x in
|
||||
((if t <> "" && t.[0] = '~' then "~(" ^ t ^ ")" else "~" ^ t), 13)
|
||||
| Form.Sym "unquote-splicing", [ x ] -> ("~@" ^ at 13 x, 13)
|
||||
| Form.Sym s, _ :: _ :: _
|
||||
when (R.is_binop s || s = "=") && s <> "==" && not (s = "!=" && List.length args > 2) ->
|
||||
let op = if s = "=" then "==" else s in
|
||||
when R.is_binop (infix_op s) && s <> "==" && not (s = "!=" && List.length args > 2) ->
|
||||
let op = infix_op s in
|
||||
let lvl = Option.get (R.binop_level op) in
|
||||
let first = List.hd args and rest = List.tl args in
|
||||
let ft, fl = expr first in
|
||||
let same = match first.v with
|
||||
| Form.List (h' :: _ :: _ :: _) -> is_sym s h' || lvl = 4
|
||||
| Form.List (h' :: _ :: _ :: _) -> (match h'.v with Form.Sym s' -> infix_op s' = op | _ -> false) || lvl = 4
|
||||
| _ -> false
|
||||
in
|
||||
let ft = if fl < lvl || (fl = lvl && same) then paren ft else ft in
|
||||
@ -398,18 +501,19 @@ and list f h args =
|
||||
(ft :: List.map (fun x -> and_in_or x (at (lvl + 1) x)) rest), lvl)
|
||||
| Form.Sym "-", [ x ] ->
|
||||
let t, l = expr x in
|
||||
if l >= 9 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 8)
|
||||
else ("-(" ^ at 0 x ^ ")", 9)
|
||||
if l >= 12 && t <> "" && R.is_neg_char t.[0] then ("-" ^ t, 11)
|
||||
else ("-(" ^ at 0 x ^ ")", 12)
|
||||
| Form.Sym "not", [ x ] -> ("not " ^ at 3 x, 3)
|
||||
| Form.Sym ("bit-not" | "~~"), [ x ] -> ("~~" ^ at 11 x, 11)
|
||||
(* [and] or [or] of one value is that value. *)
|
||||
| Form.Sym ("and" | "or"), [ x ] when !quasi = 0 -> expr x
|
||||
| Form.Sym "at", t :: (_ :: _ as idx) -> (at 9 t ^ "[" ^ commas idx ^ "]", 9)
|
||||
| Form.Sym "at", t :: (_ :: _ as idx) -> (at 12 t ^ "[" ^ commas idx ^ "]", 12)
|
||||
| Form.Sym s, [ t ]
|
||||
when String.length s > 1 && s.[0] = '.' && name_ok s
|
||||
&& not (String.contains (String.sub s 1 (String.length s - 1)) '.') ->
|
||||
let tt, tl = expr t in
|
||||
let glued =
|
||||
tl >= 9
|
||||
tl >= 12
|
||||
&& (match t.v with
|
||||
| Form.Byte _ -> false
|
||||
| Form.Sym x -> name_ok x && not (String.contains x '.') && not (R.capitalised x)
|
||||
@ -421,9 +525,9 @@ and list f h args =
|
||||
let c = tt.[String.length tt - 1] in
|
||||
c = ')' || c = ']' || c = '}' || c = '"')
|
||||
in
|
||||
if glued then (tt ^ s, 9) else call ()
|
||||
if glued then (tt ^ s, 12) else call ()
|
||||
| Form.Sym s, [ ({ v = Form.Map _; _ } as m) ] when name_ok s && R.capitalised s ->
|
||||
(s ^ fst (expr m), 9)
|
||||
(s ^ fst (expr m), 12)
|
||||
| Form.Sym "the", _ when (match typed_lambda f with Some (_, [ _ ]) -> true | _ -> false) ->
|
||||
(match typed_lambda f with
|
||||
| Some (head, [ body ]) -> (head ^ " => " ^ unit_text body, 0)
|
||||
@ -451,7 +555,7 @@ and inline_text ?(lvl = 0) (f : Form.t) =
|
||||
| Form.List [ { v = Form.Sym "set"; _ }; t; v ] -> assign_text ~lvl t v
|
||||
| Form.List [ { v = Form.Sym "update"; _ }; t; { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; w ]
|
||||
when not (R.simple_place t) ->
|
||||
at 9 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w
|
||||
at 12 t ^ " " ^ op ^ "= " ^ at (max lvl 1) w
|
||||
| _ -> at lvl f
|
||||
|
||||
(* A body after [=]: [()] there reads as [(do)]. *)
|
||||
@ -463,7 +567,7 @@ and unit_text (f : Form.t) =
|
||||
|
||||
(* [t = v], or [t += w] when [v] is [(+ t w)]. *)
|
||||
and assign_text ?(lvl = 0) t v =
|
||||
let tt = at 9 t in
|
||||
let tt = at 12 t in
|
||||
match v.v with
|
||||
| Form.List [ { v = Form.Sym (("+" | "-" | "*" | "/") as op); _ }; a; w ]
|
||||
when same a t && R.simple_place t ->
|
||||
@ -480,7 +584,7 @@ and typed_lambda (f : Form.t) =
|
||||
match t.v with
|
||||
| Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
|
||||
h ^ "(" ^ String.concat ", " (List.map tyt ps) ^ ") -> " ^ tyt r
|
||||
| _ -> at 9 t
|
||||
| _ -> at 12 t
|
||||
in
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym "the"; _ };
|
||||
@ -499,7 +603,7 @@ let rec ty (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List [ { v = Form.Sym (("Fn" | "CFn") as h); _ }; { v = Form.Vec ps; _ }; r ] ->
|
||||
h ^ "(" ^ commas ps ^ ") -> " ^ ty r
|
||||
| _ -> at 9 f
|
||||
| _ -> at 12 f
|
||||
|
||||
(* A [defn]'s parameter type the reader could not mistake for a name: a
|
||||
primitive, a capitalised or [$] name, or a bracket. [[x y]] with a
|
||||
@ -594,6 +698,7 @@ let body_guess (h : Form.t) args =
|
||||
lists goes in the block. *)
|
||||
let stmt_like (a : Form.t) =
|
||||
match a.v with
|
||||
| Form.List _ when is_chain a -> false
|
||||
| Form.List ({ v = Form.Sym h; _ } :: _) ->
|
||||
List.mem h [ "let"; "set"; "when"; "unless"; "cond"; "while";
|
||||
"until"; "dotimes"; "match"; "handler-case";
|
||||
@ -630,7 +735,8 @@ let body_guess (h : Form.t) args =
|
||||
|
||||
let let_sugar (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: _ :: _) ->
|
||||
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: _ :: _)
|
||||
when not (is_chain f) ->
|
||||
(match pairs bs with None | Some [] -> false | Some _ -> true)
|
||||
| _ -> false
|
||||
|
||||
@ -739,7 +845,9 @@ and wrapped n prefix (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.List (h :: (_ :: _ as args)) when (match h.v with
|
||||
| Form.Sym ("at" | "quote" | "unquote" | "unquote-splicing") -> false
|
||||
| Form.Sym s -> not (R.is_op_word s) && not (String.length s > 1 && s.[0] = '.')
|
||||
| Form.Sym s ->
|
||||
not (R.is_op_word (infix_op s)) && s <> "bit-not"
|
||||
&& not (String.length s > 1 && s.[0] = '.')
|
||||
| _ -> false) ->
|
||||
let open_ = prefix ^ head_text h ^ "(" in
|
||||
let col = n + String.length open_ in
|
||||
@ -771,7 +879,7 @@ and wrapped n prefix (f : Form.t) =
|
||||
let open_ = prefix ^ "[" in
|
||||
let col = n + String.length open_ in
|
||||
let ts = List.map expr xs in
|
||||
let sep = if List.for_all (fun (_, l) -> l >= 8) ts then "" else "," in
|
||||
let sep = if List.for_all (fun (_, l) -> l >= 11) ts then "" else "," in
|
||||
let rec go line acc = function
|
||||
| [] -> List.rev ((line ^ "]") :: acc)
|
||||
| (t, _) :: rest ->
|
||||
@ -927,6 +1035,7 @@ and value_lines n prefix (v : Form.t) =
|
||||
if n + String.length inline <= width then [ ind n ^ inline ]
|
||||
else
|
||||
match v.v with
|
||||
| _ when is_chain v -> [ ind n ^ inline ]
|
||||
| Form.List ({ v = Form.Sym h; _ } :: _)
|
||||
when not (List.mem h sugar_heads || h = "fn" || h = "if") ->
|
||||
wrapped n (prefix ^ " = ") v
|
||||
@ -943,7 +1052,8 @@ and label_of = function
|
||||
and sugar n (f : Form.t) : string list option =
|
||||
let i = ind n in
|
||||
match f.v with
|
||||
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body)) ->
|
||||
| Form.List ({ v = Form.Sym "let"; _ } :: { v = Form.Vec bs; _ } :: (_ :: _ as body))
|
||||
when not (is_chain f) ->
|
||||
(match pairs bs with
|
||||
| None | Some [] -> None
|
||||
| Some prs -> Some (let_lines n prs body))
|
||||
@ -952,9 +1062,9 @@ and sugar n (f : Form.t) : string list option =
|
||||
Some [ i ^ guard (inline_text f) ]
|
||||
| Form.List [ { v = Form.Sym "set"; _ }; t; v ] ->
|
||||
let line = i ^ guard (assign_text t v) in
|
||||
if String.length line <= width && lambda_value n (guard (at 9 t)) v = None
|
||||
if String.length line <= width && lambda_value n (guard (at 12 t)) v = None
|
||||
then Some [ line ]
|
||||
else Some (value_lines n (guard (at 9 t)) v)
|
||||
else Some (value_lines n (guard (at 12 t)) v)
|
||||
| Form.List [ { v = Form.Sym "if"; _ }; c; a; b ] ->
|
||||
let simple (x : Form.t) =
|
||||
match x.v with
|
||||
@ -1048,7 +1158,7 @@ and sugar n (f : Form.t) : string list option =
|
||||
:: List.concat_map
|
||||
(fun ((pat : Form.t), body) ->
|
||||
List.mapi (fun k l -> if k = 0 then Source_text.tag pat.loc.Loc.line l else l) @@
|
||||
let pt = at 8 pat in
|
||||
let pt = at 11 pat in
|
||||
let line = ind (n + 2) ^ pt ^ " -> " ^ inline_text body in
|
||||
match body.v with
|
||||
| Form.List ({ v = Form.Sym "do"; _ } :: _ :: _ :: _) ->
|
||||
@ -1251,7 +1361,7 @@ and sugar n (f : Form.t) : string list option =
|
||||
Some ("(" ^ fst (expr p0) ^ ": " ^ ty key
|
||||
^ String.concat "" (List.map (fun p -> ", " ^ fst (expr p)) rest) ^ ")")
|
||||
| (Form.Kw _ | Form.Str _ | Form.Int _ | Form.Sym _), _ ->
|
||||
Some ("(" ^ commas ps ^ ") when " ^ at 9 key)
|
||||
Some ("(" ^ commas ps ^ ") when " ^ at 12 key)
|
||||
| _ -> None
|
||||
in
|
||||
Option.map (fun h -> fn_like n f (i ^ "method " ^ name ^ h) body) head
|
||||
@ -1316,7 +1426,7 @@ and handler_clauses n cls =
|
||||
match c.v with
|
||||
| Form.List (t :: { v = Form.Vec [ { v = Form.Sym v; _ } ]; _ } :: (_ :: _ as b))
|
||||
when def_name v ->
|
||||
Some ((ind n ^ "on " ^ at 9 t ^ "(" ^ v ^ ")") :: block (n + 2) b)
|
||||
Some ((ind n ^ "on " ^ at 12 t ^ "(" ^ v ^ ")") :: block (n + 2) b)
|
||||
| _ -> None
|
||||
in
|
||||
let cs = List.map clause cls in
|
||||
@ -1331,7 +1441,7 @@ and let_lines n prs body =
|
||||
| Form.Sym x, Form.List [ { v = Form.Sym "the"; _ }; ty_; w ]
|
||||
when def_name x && typed_lambda v = None ->
|
||||
("let " ^ x ^ ": " ^ ty ty_, w)
|
||||
| _ -> ("let " ^ guard (at 8 t), v)
|
||||
| _ -> ("let " ^ guard (at 11 t), v)
|
||||
in
|
||||
(* Each binding line carries its own source line, so a comment written
|
||||
after a binding stays on it. *)
|
||||
|
||||
@ -23,6 +23,7 @@ type tok =
|
||||
| COMMA
|
||||
| COLON (* x: T, and the trailing : of a call's block *)
|
||||
| UNQ | SPLICE (* ~ and ~@ *)
|
||||
| BNOT (* ~~, bit-not; a nested unquote is ~(~x) *)
|
||||
| NEG (* the - glued to the front of a name *)
|
||||
| NEWLINE | INDENT | DEDENT | EOF
|
||||
|
||||
@ -36,7 +37,7 @@ let show = function
|
||||
| ATOM v -> Form.to_source (Form.make v Loc.unknown)
|
||||
| DATUM f -> Form.to_source f
|
||||
| LP -> "(" | RP -> ")" | LB -> "[" | RB -> "]" | LC -> "{" | RC -> "}"
|
||||
| COMMA -> "," | COLON -> ":" | UNQ -> "~" | SPLICE -> "~@" | NEG -> "-"
|
||||
| COMMA -> "," | COLON -> ":" | UNQ -> "~" | SPLICE -> "~@" | BNOT -> "~~" | NEG -> "-"
|
||||
| NEWLINE -> "the end of the line"
|
||||
| INDENT -> "an indented line"
|
||||
| DEDENT -> "the end of the block"
|
||||
@ -45,17 +46,23 @@ let show = function
|
||||
(* ── Names ─────────────────────────────────────────────────────────── *)
|
||||
|
||||
(* Binary operators and their levels, low to high (spec §2 "Precedence").
|
||||
[not] sits at 3 and unary minus at 8; neither is binary. *)
|
||||
[not] sits at 3 and the prefix [-] and [~~] at 11; neither is binary. The
|
||||
bit operators sit between the comparisons and the shifts, Python's and
|
||||
Rust's order, so [x && mask == 0] is [(x && mask) == 0]. *)
|
||||
let binops =
|
||||
[ ("or", 1); ("and", 2);
|
||||
("==", 4); ("!=", 4); ("<", 4); ("<=", 4); (">", 4); (">=", 4);
|
||||
("<<", 5); (">>", 5); ("+", 6); ("-", 6); ("*", 7); ("/", 7); ("%", 7) ]
|
||||
("||", 5); ("^^", 6); ("&&", 7);
|
||||
("<<", 8); (">>", 8); ("+", 9); ("-", 9); ("*", 10); ("/", 10); ("%", 10) ]
|
||||
|
||||
let binop_level s = List.assoc_opt s binops
|
||||
let is_binop s = binop_level s <> None
|
||||
|
||||
(* [==] is Flan's [=]; every other operator is its own name. *)
|
||||
let op_sym = function "==" -> "=" | s -> s
|
||||
(* [==] is Flan's [=], and the bit operators are the words the Lisp side
|
||||
writes; every other operator is its own name. *)
|
||||
let op_sym = function
|
||||
| "==" -> "=" | "&&" -> "bit-and" | "||" -> "bit-or" | "^^" -> "bit-xor"
|
||||
| s -> s
|
||||
|
||||
(* Words that are operators rather than names wherever a value is read. Alone
|
||||
before a comma or a closer they are the symbol itself, [reduce(+, 0, xs)];
|
||||
@ -93,6 +100,49 @@ let compound (at : Loc.t) op (e : Form.t) (v : Form.t) span =
|
||||
Form.List
|
||||
[ Form.make (Form.Sym "update") at; e; Form.make (Form.Sym op) at; v ]
|
||||
|
||||
(* A comparison chain that mixes [<] with [<=], or [>] with [>=], is the
|
||||
[and] of its neighbouring pairs: [0 <= r < rows] is
|
||||
[(and (<= 0 r) (< r rows))]. It is evaluated as [(< a b c)] is: every
|
||||
operand once, left to right, before any test, with no short-circuit. When
|
||||
an operand is more than a name or a literal, every operand but a literal
|
||||
is bound first, in order, to a fresh [~cmp] name, which no reader can
|
||||
produce: a name too, since a call to its right may change it. The printer
|
||||
rebuilds a candidate with this same function and prints the chain only
|
||||
when the two agree. *)
|
||||
let cmp_dir = function
|
||||
| "<" | "<=" -> Some `Up
|
||||
| ">" | ">=" -> Some `Down
|
||||
| _ -> None
|
||||
|
||||
let cmp_chain ~fresh (l : Loc.t) (xs : Form.t list) (ops : string list) =
|
||||
let mkf v = Form.make v l in
|
||||
let s x = mkf (Form.Sym x) in
|
||||
let literal (x : Form.t) =
|
||||
match x.v with
|
||||
| Form.Int _ | Form.UInt _ | Form.Float _ | Form.Str _ | Form.Byte _
|
||||
| Form.Kw _ | Form.Sym ("true" | "false" | "nil") -> true
|
||||
| _ -> false
|
||||
in
|
||||
let simple (x : Form.t) = literal x || (match x.v with Form.Sym _ -> true | _ -> false) in
|
||||
let keep = if List.for_all simple xs then simple else literal in
|
||||
let bound =
|
||||
List.map (fun x -> if keep x then (None, x) else
|
||||
let t = s (fresh ()) in (Some (t, x), t)) xs
|
||||
in
|
||||
let refs = List.map snd bound in
|
||||
let rec tests = function
|
||||
| a :: (b :: _ as rest), op :: ops -> mkf (Form.List [ s op; a; b ]) :: tests (rest, ops)
|
||||
| _ -> []
|
||||
in
|
||||
let body = mkf (Form.List (s "and" :: tests (refs, ops))) in
|
||||
match List.concat_map (function (Some (t, x), _) -> [ t; x ] | _ -> []) bound with
|
||||
| [] -> body
|
||||
| bs -> mkf (Form.List [ s "let"; mkf (Form.Vec bs); body ])
|
||||
|
||||
(* The reader's fresh names for [cmp_chain], counted per [read_all]. *)
|
||||
let cmp_n = ref 0
|
||||
let cmp_fresh () = incr cmp_n; Printf.sprintf "~cmp%d" !cmp_n
|
||||
|
||||
(* A [-] glued to one of these starts a negation: [-x] is [(- x)]. Anything
|
||||
else keeps the Lisp reading, so [--], [->] and [-=] stay names. *)
|
||||
let is_neg_char c =
|
||||
@ -185,7 +235,11 @@ let lex ?(line = 1) ?(col = 1) ~file src : token list =
|
||||
indented block, or quasiquote(x) on one line"
|
||||
| '~' ->
|
||||
Reader.advance st;
|
||||
if Reader.peek st = '@' then begin
|
||||
if Reader.peek st = '~' then begin
|
||||
Reader.advance st;
|
||||
emit BNOT (Loc.upto l0 (Reader.here st))
|
||||
end
|
||||
else if Reader.peek st = '@' then begin
|
||||
Reader.advance st;
|
||||
emit SPLICE (Loc.upto l0 (Reader.here st))
|
||||
end
|
||||
@ -521,7 +575,7 @@ let where_ p =
|
||||
| _ -> t.loc
|
||||
|
||||
let starts_value = function
|
||||
| NAME _ | KW _ | ATOM _ | DATUM _ | LP | LB | LC | UNQ | SPLICE | NEG -> true
|
||||
| NAME _ | KW _ | ATOM _ | DATUM _ | LP | LB | LC | UNQ | SPLICE | BNOT | NEG -> true
|
||||
| _ -> false
|
||||
|
||||
let ends_value = function
|
||||
@ -654,11 +708,6 @@ let refuse_ws ?(brace = false) loc e =
|
||||
(if brace then "entries" else "elements")
|
||||
(if brace then "{.x a + 1, .y 2}" else "[a - 1, b]")
|
||||
|
||||
(* Expressions come back with their syntactic level: 10 an atom or a bracket,
|
||||
9 a postfix chain, 8 a unary minus, 1-7 a binary operator's level, 3 a
|
||||
[not], 0 a one-line [if] or a lambda. Anything under 8 is "compound": it
|
||||
has an operator at its top, so it cannot sit in a list separated only by
|
||||
whitespace. *)
|
||||
(* [loop] and [recur] are Lisp-syntax forms. A .fln loop is a [while],
|
||||
[until], [dotimes] or [for]; [read_all] refuses any that gets past the
|
||||
parser, in a [quote] or a quoted datum too. *)
|
||||
@ -670,11 +719,40 @@ let no_loop loc word =
|
||||
break leaves the loop early, and continue goes on to the next round."
|
||||
word
|
||||
|
||||
(* A refused chain written out as the [and] of all its tests. A middle
|
||||
operand that is more than a name or a literal is named by a [let] first,
|
||||
so the rewrite does not run it twice. *)
|
||||
let and_rewrite (xs : Form.t list) ops =
|
||||
let n = List.length xs in
|
||||
let lets = ref [] in
|
||||
let texts =
|
||||
List.mapi
|
||||
(fun i (x : Form.t) ->
|
||||
let plain = match x.v with Form.List _ | Form.Vec _ | Form.Map _ -> false | _ -> true in
|
||||
if plain || i = 0 || i = n - 1 then text_of x
|
||||
else begin
|
||||
let m = if !lets = [] then "mid" else Printf.sprintf "mid%d" (List.length !lets + 1) in
|
||||
lets := Printf.sprintf " let %s = %s\n" m (text_of x) :: !lets;
|
||||
m
|
||||
end)
|
||||
xs
|
||||
in
|
||||
let rec tests = function
|
||||
| a :: (b :: _ as rest), op :: ops -> Printf.sprintf "%s %s %s" a op b :: tests (rest, ops)
|
||||
| _ -> []
|
||||
in
|
||||
String.concat "" (List.rev !lets) ^ " " ^ String.concat " and " (tests (texts, ops))
|
||||
|
||||
(* Expressions come back with their syntactic level: 13 an atom or a bracket,
|
||||
12 a postfix chain, 11 a prefix [-] or [~~], 1-10 a binary operator's
|
||||
level, 3 a [not], 0 a one-line [if] or a lambda. Anything under 11 is
|
||||
"compound": it has an operator at its top, so it cannot sit in a list
|
||||
separated only by whitespace. *)
|
||||
let rec expr p : Form.t * int = binary p 1
|
||||
|
||||
and binary p lvl : Form.t * int =
|
||||
if lvl = 3 then not_ p
|
||||
else if lvl > 7 then unary p
|
||||
else if lvl > 10 then unary p
|
||||
else
|
||||
let l0 = (peek p).loc in
|
||||
let ((first, _) as fst_) = binary p (lvl + 1) in
|
||||
@ -695,31 +773,62 @@ and binary p lvl : Form.t * int =
|
||||
binop_level s = Some lvl
|
||||
&& not ((peek_at p 1).tok = LP && not (peek_at p 1).sp)
|
||||
in
|
||||
let operator s =
|
||||
let ot = advance p in
|
||||
if not (ot.sp && (peek p).sp) then
|
||||
failk "unspaced-operator" ot.loc
|
||||
"%s is an operator here, and a binary operator has a space on each \
|
||||
side: a %s b. Without them a-b is one name"
|
||||
s s;
|
||||
let rhs, _ = binary p (lvl + 1) in
|
||||
(ot, rhs)
|
||||
in
|
||||
let rec run op operands =
|
||||
match (peek p).tok with
|
||||
| NAME s when binary_here s ->
|
||||
let ot = advance p in
|
||||
if not (ot.sp && (peek p).sp) then
|
||||
failk "unspaced-operator" ot.loc
|
||||
"%s is an operator here, and a binary operator has a space on each \
|
||||
side: a %s b. Without them a-b is one name"
|
||||
s s;
|
||||
let rhs, _ = binary p (lvl + 1) in
|
||||
let _, rhs = operator s in
|
||||
if s = op then run op (rhs :: operands)
|
||||
else begin
|
||||
if lvl = 4 then
|
||||
failk "mixed-comparison" ot.loc
|
||||
"%s follows %s in one chain, and a chain compares with one \
|
||||
operator. Join the tests with and, or parenthesise one side"
|
||||
s op;
|
||||
else
|
||||
let folded, _ = close op operands in
|
||||
run s [ rhs; folded ]
|
||||
end
|
||||
| _ -> close op operands
|
||||
in
|
||||
(* A comparison chain is read whole, then judged: one operator throughout
|
||||
is the variadic call, one direction is [cmp_chain], anything else is
|
||||
refused at the first operator that breaks it. *)
|
||||
let rec chain acc =
|
||||
match (peek p).tok with
|
||||
| NAME s when binary_here s ->
|
||||
let ot, rhs = operator s in
|
||||
chain ((s, ot, rhs) :: acc)
|
||||
| _ -> List.rev acc
|
||||
in
|
||||
let comparison () =
|
||||
let links = chain [] in
|
||||
let ops = List.map (fun (s, _, _) -> s) links in
|
||||
let xs = first :: List.map (fun (_, _, x) -> x) links in
|
||||
let op1 = List.hd ops in
|
||||
if List.for_all (( = ) op1) ops then close op1 (List.rev xs)
|
||||
else
|
||||
let d = cmp_dir op1 in
|
||||
Array.iteri
|
||||
(fun i (op, (ot : token), _) ->
|
||||
if i > 0 && (d = None || cmp_dir op <> d) then begin
|
||||
let prev, _, _ = List.nth links (i - 1) in
|
||||
failk "mixed-comparison" ot.loc
|
||||
"%s follows %s in one chain. A chain may repeat one operator, \
|
||||
or mix < with <=, or > with >=, as in 0 <= i < n. Write this \
|
||||
one as tests joined with and:\n\n%s"
|
||||
op prev (and_rewrite xs ops)
|
||||
end)
|
||||
(Array.of_list links);
|
||||
(cmp_chain ~fresh:cmp_fresh (span p l0) xs ops, lvl)
|
||||
in
|
||||
(* [run] folds a different operator at the same level into the left
|
||||
operand, so the first operator here only starts the first run. *)
|
||||
match (peek p).tok with
|
||||
| NAME s when binary_here s && (cmp_dir s <> None || s = "==" || s = "!=") ->
|
||||
comparison ()
|
||||
| NAME s when binary_here s -> run s [ first ]
|
||||
| _ -> fst_
|
||||
|
||||
@ -738,7 +847,11 @@ and unary p =
|
||||
| NEG ->
|
||||
ignore (advance p);
|
||||
let x, _ = postfix p in
|
||||
(mk p t.loc (Form.List [ sym t.loc "-"; x ]), 8)
|
||||
(mk p t.loc (Form.List [ sym t.loc "-"; x ]), 11)
|
||||
| BNOT ->
|
||||
ignore (advance p);
|
||||
let x, _ = unary p in
|
||||
(mk p t.loc (Form.List [ sym t.loc "bit-not"; x ]), 11)
|
||||
| _ -> postfix p
|
||||
|
||||
and postfix p =
|
||||
@ -751,18 +864,18 @@ and postfix p =
|
||||
| LP ->
|
||||
ignore (advance p);
|
||||
let args = items p RP t.loc ~what:"arguments" in
|
||||
loop (mk p l0 (Form.List (f :: args)), 9)
|
||||
loop (mk p l0 (Form.List (f :: args)), 12)
|
||||
| LB ->
|
||||
ignore (advance p);
|
||||
let idx = items p RB t.loc ~what:"indices" ~head:(text_of f) in
|
||||
loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 9)
|
||||
loop (mk p l0 (Form.List (sym t.loc "at" :: f :: idx)), 12)
|
||||
| NAME s when String.length s > 1 && s.[0] = '.' ->
|
||||
ignore (advance p);
|
||||
loop (mk p l0 (Form.List [ sym t.loc s; f ]), 9)
|
||||
loop (mk p l0 (Form.List [ sym t.loc s; f ]), 12)
|
||||
| LC ->
|
||||
ignore (advance p);
|
||||
let m = map_items p t.loc in
|
||||
loop (mk p l0 (Form.List [ f; Form.make (Form.Map m) (span p t.loc) ]), 9)
|
||||
loop (mk p l0 (Form.List [ f; Form.make (Form.Map m) (span p t.loc) ]), 12)
|
||||
| _ -> fp
|
||||
in
|
||||
loop (primary p)
|
||||
@ -794,7 +907,7 @@ and primary p : Form.t * int =
|
||||
else if is_op_word s then begin
|
||||
if glued_lp || ends_value nxt.tok then begin
|
||||
ignore (advance p);
|
||||
(sym l0 (op_sym s), 10)
|
||||
(sym l0 (op_sym s), 13)
|
||||
end
|
||||
else
|
||||
failk "operator-operand" l0
|
||||
@ -806,18 +919,18 @@ and primary p : Form.t * int =
|
||||
else begin
|
||||
ignore (advance p);
|
||||
check_name t s;
|
||||
(sym l0 s, 10)
|
||||
(sym l0 s, 13)
|
||||
end
|
||||
| KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 10)
|
||||
| KW k -> ignore (advance p); (Form.make (Form.Kw k) l0, 13)
|
||||
| ATOM v ->
|
||||
ignore (advance p);
|
||||
(Form.make v l0, if negative_literal t.tok then 8 else 10)
|
||||
| DATUM f -> ignore (advance p); (f, 10)
|
||||
(Form.make v l0, if negative_literal t.tok then 11 else 13)
|
||||
| DATUM f -> ignore (advance p); (f, 13)
|
||||
| LP ->
|
||||
ignore (advance p);
|
||||
if (peek p).tok = RP then begin
|
||||
ignore (advance p);
|
||||
(mk p l0 (Form.List []), 10)
|
||||
(mk p l0 (Form.List []), 13)
|
||||
end
|
||||
else
|
||||
let e, _ = expr p in
|
||||
@ -830,21 +943,21 @@ and primary p : Form.t * int =
|
||||
Several values in a list are written in brackets, [a, b]; \
|
||||
arguments go glued to a name, f(a, b)"
|
||||
| _ -> stray p ~after:(text_of e));
|
||||
(e, 10)
|
||||
(e, 13)
|
||||
| LB ->
|
||||
ignore (advance p);
|
||||
let xs = vec_items p l0 in
|
||||
(mk p l0 (Form.Vec xs), 10)
|
||||
(mk p l0 (Form.Vec xs), 13)
|
||||
| LC ->
|
||||
ignore (advance p);
|
||||
let xs = map_items p l0 in
|
||||
(mk p l0 (Form.Map xs), 10)
|
||||
(mk p l0 (Form.Map xs), 13)
|
||||
| UNQ | SPLICE ->
|
||||
ignore (advance p);
|
||||
let x, _ = primary p in
|
||||
let name = if t.tok = UNQ then "unquote" else "unquote-splicing" in
|
||||
(mk p l0 (Form.List [ sym l0 name; x ]), 10)
|
||||
| NEG -> unary p
|
||||
(mk p l0 (Form.List [ sym l0 name; x ]), 13)
|
||||
| NEG | BNOT -> unary p
|
||||
| tk ->
|
||||
failk "expected-value" (where_ p) "expected a value here, and found %s"
|
||||
(show tk)
|
||||
@ -945,7 +1058,7 @@ and fn_expr p =
|
||||
is what follows. *)
|
||||
| tk when names && n.loc.Loc.line > rp.loc.Loc.eline && starts_value tk ->
|
||||
lambda_arrow n.loc (header ())
|
||||
| _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 9)
|
||||
| _ -> (mk p t.loc (Form.List (sym t.loc "fn" :: args)), 12)
|
||||
|
||||
(* What follows a lambda's [=>]: a value on the line, or the indented block
|
||||
under it. [header] is the lambda's header as written, for a message. *)
|
||||
@ -1089,7 +1202,7 @@ and vec_items p open_loc =
|
||||
| EOF -> unclosed p '[' open_loc
|
||||
| _ ->
|
||||
let e, lvl = expr p in
|
||||
if lvl < 8 && prev_ws then refuse_ws t.loc e;
|
||||
if lvl < 11 && prev_ws then refuse_ws t.loc e;
|
||||
(match (peek p).tok with
|
||||
| COMMA ->
|
||||
if !spaces then mixed (peek p).loc;
|
||||
@ -1098,7 +1211,7 @@ and vec_items p open_loc =
|
||||
| RB -> ignore (advance p); List.rev (e :: acc)
|
||||
| EOF -> unclosed p '[' open_loc
|
||||
| tk when starts_value tk && (peek p).sp ->
|
||||
if lvl < 8 then refuse_ws t.loc e;
|
||||
if lvl < 11 then refuse_ws t.loc e;
|
||||
if !commas then mixed (peek p).loc;
|
||||
spaces := true;
|
||||
go (e :: acc) true
|
||||
@ -1129,7 +1242,7 @@ and map_items p open_loc =
|
||||
and no %s between it and the value"
|
||||
n (if tk = COLON then "colon" else "= sign")
|
||||
| tk when starts_value tk && (peek p).sp ->
|
||||
if lvl < 8 then refuse_ws ~brace:true t.loc e;
|
||||
if lvl < 11 then refuse_ws ~brace:true t.loc e;
|
||||
go (e :: acc)
|
||||
| _ -> stray p ~after:(text_of e))
|
||||
in
|
||||
@ -2280,12 +2393,14 @@ let read_all ?(line = 1) ?col ?indent ?(global_let = true) ~file src =
|
||||
let snippet = col <> None in
|
||||
let col = Option.value col ~default:1 in
|
||||
let saved = !source in
|
||||
let saved_n = !cmp_n in
|
||||
cmp_n := 0;
|
||||
(* The quoted text is indexed by the buffer's lines, so a snippet that
|
||||
starts on line 40 is padded to start there. *)
|
||||
source :=
|
||||
(file, Array.of_list (String.split_on_char '\n'
|
||||
(String.make (line - 1) '\n' ^ String.make (col - 1) ' ' ^ src)));
|
||||
Fun.protect ~finally:(fun () -> source := saved) (fun () ->
|
||||
Fun.protect ~finally:(fun () -> source := saved; cmp_n := saved_n) (fun () ->
|
||||
let toks = layout ~snippet ~base:col ?indent (lex ~line ~col ~file src) in
|
||||
let s = { p = { toks; i = 0; closed = -1 }; lets = [] } in
|
||||
(* At the top level, a [let] is a global, [(def x dyn v)]: a let there has
|
||||
|
||||
@ -889,6 +889,12 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) =
|
||||
| Tast.Not, [ x ] -> Printf.sprintf "(!%s)" (value f x)
|
||||
| (Tast.BitAnd | Tast.BitOr | Tast.BitXor | Tast.Shl | Tast.Shr), [ x; y ]
|
||||
-> bitwise f e p x y
|
||||
| Tast.BitNot, [ x ] -> (
|
||||
match x.Tast.ty with
|
||||
| Types.Int k -> norm k (Printf.sprintf "~(%s)" (value f x))
|
||||
| t -> at loc "a bitwise operation on %s" (Types.to_string t))
|
||||
| (Tast.Popcount | Tast.Clz | Tast.Ctz | Tast.Rotl | Tast.Rotr), _ ->
|
||||
at loc "the bit counts and rotations are not in the JS dialect"
|
||||
| Tast.Len, [ x ] -> (
|
||||
match x.Tast.ty with
|
||||
| Types.Array (n, _) -> Printf.sprintf "%Ld" n
|
||||
|
||||
@ -315,7 +315,60 @@ let rec layout ?(inside = fun _ -> false) spell col (f : Form.t) : string list =
|
||||
| _ -> [ one ]
|
||||
|
||||
(** A whole file, with [source]'s comments and spellings when given. *)
|
||||
(* A .fln comparison chain binds its operands to [~cmp] names, which paren
|
||||
text cannot spell ([~] opens an unquote). Outside a template each gets a
|
||||
name that nothing in its top-level form uses, so no reference there is
|
||||
captured. Inside one a plain name would capture the caller's variable of
|
||||
that name, and the paren syntax has no auto-gensym, so the name is made
|
||||
where it lands: [~(Form.Sym {.s "~cmp1"})], a name no caller can write. *)
|
||||
let readable_temps (f : Form.t) =
|
||||
let is_temp s = String.length s > 4 && String.sub s 0 4 = "~cmp" in
|
||||
let rec syms acc (f : Form.t) =
|
||||
match f.v with
|
||||
| Form.Sym s -> s :: acc
|
||||
| Form.List l | Form.Vec l | Form.Map l -> List.fold_left syms acc l
|
||||
| _ -> acc
|
||||
in
|
||||
let all = syms [] f in
|
||||
let temps =
|
||||
List.fold_left
|
||||
(fun acc s -> if is_temp s && not (List.mem s acc) then s :: acc else acc)
|
||||
[] (List.rev all)
|
||||
|> List.rev
|
||||
in
|
||||
if temps = [] then f
|
||||
else
|
||||
let taken = ref all in
|
||||
let rec pick i =
|
||||
let n = if i = 1 then "mid" else Printf.sprintf "mid%d" i in
|
||||
if List.mem n !taken then pick (i + 1) else (taken := n :: !taken; n)
|
||||
in
|
||||
let names = List.map (fun t -> (t, pick 1)) temps in
|
||||
let rec go depth (f : Form.t) =
|
||||
let sub l = List.map (go depth) l in
|
||||
match f.v with
|
||||
| Form.Sym s when is_temp s && depth > 0 ->
|
||||
let m v = Form.make v f.loc in
|
||||
m (Form.List
|
||||
[ m (Form.Sym "unquote");
|
||||
m (Form.List [ m (Form.Sym "Form.Sym");
|
||||
m (Form.Map [ m (Form.Sym ".s"); m (Form.Str s) ]) ]) ])
|
||||
| Form.Sym s ->
|
||||
(match List.assoc_opt s names with Some n -> { f with v = Form.Sym n } | None -> f)
|
||||
| Form.List [ ({ v = Form.Sym "quasiquote"; _ } as h); x ] ->
|
||||
{ f with v = Form.List [ h; go (depth + 1) x ] }
|
||||
| Form.List [ ({ v = Form.Sym ("unquote" | "unquote-splicing"); _ } as h); x ]
|
||||
when depth > 0 ->
|
||||
{ f with v = Form.List [ h; go (depth - 1) x ] }
|
||||
| Form.List l -> { f with v = Form.List (sub l) }
|
||||
| Form.Vec l -> { f with v = Form.Vec (sub l) }
|
||||
| Form.Map l -> { f with v = Form.Map (sub l) }
|
||||
| _ -> f
|
||||
in
|
||||
go 0 f
|
||||
|
||||
let program ?source (fs : Form.t list) : string =
|
||||
let fs = List.map readable_temps fs in
|
||||
let spell =
|
||||
match source with Some src -> Source_text.spelling src | None -> fun _ -> None
|
||||
in
|
||||
|
||||
@ -226,6 +226,9 @@ let rec read_form st =
|
||||
advance st;
|
||||
if peek st = '@' then (advance st; read_wrapped st loc "unquote-splicing")
|
||||
else read_wrapped st loc "unquote"
|
||||
(* [^^] is bit-xor's other name, and metadata on a form that starts with
|
||||
[^] would mean nothing, so the two cannot collide. *)
|
||||
| '^' when peek2 st = '^' -> read_symbol_or_keyword st
|
||||
| '^' ->
|
||||
Loc.failk "reader/metadata" loc "metadata (^) is not supported yet"
|
||||
|
||||
|
||||
@ -23,6 +23,10 @@ type prim =
|
||||
(* bitwise, integers only. [Shr] is arithmetic on a signed type and logical
|
||||
on an unsigned one, which is what the operand's own kind already says. *)
|
||||
| BitAnd | BitOr | BitXor | Shl | Shr
|
||||
(* One operand each, and the answer has the operand's type. [Clz] and [Ctz]
|
||||
answer the width for zero. [Rotl] and [Rotr] take the count modulo the
|
||||
width, so no count is out of range. *)
|
||||
| BitNot | Popcount | Clz | Ctz | Rotl | Rotr
|
||||
(* containers: fixed arrays and slices only at milestone 2 *)
|
||||
| Len | At | Slice
|
||||
(* (slice-from p n): a [T] made out of a (Ptr T) and a length the caller
|
||||
|
||||
87
lib/x86.ml
87
lib/x86.ml
@ -386,6 +386,32 @@ let shift_cl b ~ext ~dst = rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b
|
||||
let shl_cl b ~dst = shift_cl b ~ext:4 ~dst
|
||||
let shr_cl b ~dst = shift_cl b ~ext:5 ~dst
|
||||
let sar_cl b ~dst = shift_cl b ~ext:7 ~dst
|
||||
let shift_imm b ~ext ~dst n =
|
||||
rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xc1; modrm_r b ~r:ext ~m:dst; u8 b n
|
||||
|
||||
(* bsf (0xbc) and bsr (0xbd): the index of the lowest or highest set bit, with
|
||||
ZF set and the destination undefined when the source is zero. Both are in
|
||||
every x86-64 CPU, which tzcnt, lzcnt and popcnt are not. *)
|
||||
let bitscan b ~op ~dst ~src =
|
||||
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b op; modrm_r b ~r:dst ~m:src
|
||||
|
||||
let cmovz_rr b ~dst ~src =
|
||||
rex b ~w:true ~r:dst ~x:0 ~m:src; u8 b 0x0f; u8 b 0x44; modrm_r b ~r:dst ~m:src
|
||||
|
||||
(* rol (ext 0) and ror (ext 1) by cl at the operand's own width, unlike the
|
||||
shifts above: a rotation at 64 bits of a value that is 8 wide would bring
|
||||
the wrong bits round. The hardware masks cl to 5 bits (6 at 64) and then
|
||||
rotates modulo the width, which is the language's rule for every width. *)
|
||||
let rot_cl b ~ext ~bits ~dst =
|
||||
match bits with
|
||||
| 8 ->
|
||||
rex ~force:(dst >= 4) b ~w:false ~r:0 ~x:0 ~m:dst; u8 b 0xd2;
|
||||
modrm_r b ~r:ext ~m:dst
|
||||
| 16 ->
|
||||
u8 b 0x66; rex b ~w:false ~r:0 ~x:0 ~m:dst; u8 b 0xd3;
|
||||
modrm_r b ~r:ext ~m:dst
|
||||
| 32 -> rex b ~w:false ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b ~r:ext ~m:dst
|
||||
| _ -> rex b ~w:true ~r:0 ~x:0 ~m:dst; u8 b 0xd3; modrm_r b ~r:ext ~m:dst
|
||||
|
||||
let setcc b ~cc ~dst =
|
||||
rex ~force:(dst >= 4) b ~w:false ~r:0 ~x:0 ~m:dst;
|
||||
@ -3402,7 +3428,66 @@ and prim f (e : Tast.expr) (p : Tast.prim) (args : Tast.expr list) dst =
|
||||
end;
|
||||
movzx8 f.b ~dst:rax ~src:rax;
|
||||
store_loc f ~reg:rax dst Types.Bool
|
||||
| Tast.Not, [ a ] ->
|
||||
(* Zero-extended to 64 bits first, so a negative i8 counts eight bits and
|
||||
not sixty-four. Every sequence below is baseline x86-64, the target LLVM
|
||||
is given too: popcount is the SWAR sum LLVM writes for [ctpop] without
|
||||
popcnt, and the two scans answer the width for zero through a cmov on the
|
||||
flag bsr and bsf set. *)
|
||||
| (Tast.Popcount | Tast.Clz | Tast.Ctz), [ a ] ->
|
||||
let la = eval f a in
|
||||
let w =
|
||||
match a.Tast.ty with
|
||||
| Types.Int k -> Types.bits k
|
||||
| t -> unsupported "a bit count of %s" (Types.to_string t)
|
||||
in
|
||||
load_int f.b ~dst:rax ~mm:(lmem f la ~scratch:r11) ~size:(w / 8)
|
||||
~signed:false;
|
||||
(match p with
|
||||
| Tast.Popcount ->
|
||||
mov_rr f.b ~dst:rcx ~src:rax;
|
||||
shift_imm f.b ~ext:5 ~dst:rcx 1;
|
||||
imm_into f ~reg:rdx 0x5555555555555555L;
|
||||
and_rr f.b ~dst:rcx ~src:rdx;
|
||||
sub_rr f.b ~dst:rax ~src:rcx;
|
||||
imm_into f ~reg:rdx 0x3333333333333333L;
|
||||
mov_rr f.b ~dst:rcx ~src:rax;
|
||||
and_rr f.b ~dst:rcx ~src:rdx;
|
||||
shift_imm f.b ~ext:5 ~dst:rax 2;
|
||||
and_rr f.b ~dst:rax ~src:rdx;
|
||||
add_rr f.b ~dst:rax ~src:rcx;
|
||||
mov_rr f.b ~dst:rcx ~src:rax;
|
||||
shift_imm f.b ~ext:5 ~dst:rcx 4;
|
||||
add_rr f.b ~dst:rax ~src:rcx;
|
||||
imm_into f ~reg:rdx 0x0f0f0f0f0f0f0f0fL;
|
||||
and_rr f.b ~dst:rax ~src:rdx;
|
||||
imm_into f ~reg:rdx 0x0101010101010101L;
|
||||
imul_rr f.b ~dst:rax ~src:rdx;
|
||||
shift_imm f.b ~ext:5 ~dst:rax 56
|
||||
| Tast.Clz ->
|
||||
bitscan f.b ~op:0xbd ~dst:rcx ~src:rax;
|
||||
imm_into f ~reg:rdx (-1L);
|
||||
cmovz_rr f.b ~dst:rcx ~src:rdx;
|
||||
imm_into f ~reg:rax (Int64.of_int (w - 1));
|
||||
sub_rr f.b ~dst:rax ~src:rcx
|
||||
| _ ->
|
||||
bitscan f.b ~op:0xbc ~dst:rcx ~src:rax;
|
||||
imm_into f ~reg:rdx (Int64.of_int w);
|
||||
cmovz_rr f.b ~dst:rcx ~src:rdx;
|
||||
mov_rr f.b ~dst:rax ~src:rcx);
|
||||
store_loc f ~reg:rax dst t
|
||||
| (Tast.Rotl | Tast.Rotr), [ a; b ] ->
|
||||
let la = eval f a in
|
||||
let lb = eval f b in
|
||||
let w =
|
||||
match a.Tast.ty with
|
||||
| Types.Int k -> Types.bits k
|
||||
| t -> unsupported "a rotation of %s" (Types.to_string t)
|
||||
in
|
||||
load_loc f ~reg:rax la a.Tast.ty;
|
||||
load_loc f ~reg:rcx lb b.Tast.ty;
|
||||
rot_cl f.b ~ext:(if p = Tast.Rotl then 0 else 1) ~bits:w ~dst:rax;
|
||||
store_loc f ~reg:rax dst t
|
||||
| (Tast.Not | Tast.BitNot), [ a ] ->
|
||||
let la = eval f a in
|
||||
if Types.equal a.Tast.ty Types.Bool then begin
|
||||
load_loc f ~reg:rax la Types.Bool;
|
||||
|
||||
@ -1657,9 +1657,112 @@ static void mark_desc(char *base, const flan_desc *d) {
|
||||
}
|
||||
}
|
||||
|
||||
/* ── Texts a str was taken from ────────────────────────────────────────
|
||||
*
|
||||
* A dyn text crossing into a str ([flan_dyn_need_as]) is not copied: the str
|
||||
* is the text's own bytes, which never move, since this collector never
|
||||
* moves anything. What could happen is a free — a str in a typed local,
|
||||
* field or Vec is not a root, and typed storage is never scanned — so the
|
||||
* crossing pins the text here, keyed by the temp arena's stamp, and every
|
||||
* collection marks the pins whose stamp is still live. The str then lasts
|
||||
* as long as the text is reachable from dyn or until the next free-temp,
|
||||
* whichever is later: the lifetime i64->bytes's text already has, and text
|
||||
* kept longer is cloned, as there.
|
||||
*
|
||||
* Rooting the text in the crossing's frame would be shorter than that and
|
||||
* wrong for a str returned or stored, and a pin for good would keep every
|
||||
* text a frame loop ever crossed. A copy into the temp arena would be sound
|
||||
* too; this is the same lifetime without the copy, and a dev build takes the
|
||||
* copy instead ([into_text]) so that a str kept past free-temp reads the
|
||||
* arena's poison, as i64->bytes's text does, rather than whatever text the
|
||||
* allocator put there next.
|
||||
*
|
||||
* A text is pinned once per stamp, however often it crosses: the stamp's
|
||||
* number is written into the text's [gen], which nothing else reads for a
|
||||
* text, so a program that never calls free-temp and passes the same texts
|
||||
* in a loop keeps a flat list. Distinct texts cost one pointer each here,
|
||||
* and each keeps its own object alive until the stamp ends — heavier than
|
||||
* i64->bytes's few bytes of arena, since the object has a header. The pins
|
||||
* sit in runs, one per stamp, so an entry is a pointer and a run's stamp is
|
||||
* kept once. */
|
||||
const void *flan_temp_stamp(uint64_t *inc, uint64_t *epoch);
|
||||
int32_t flan_temp_stamp_live(const void *a, uint64_t inc, uint64_t epoch);
|
||||
|
||||
typedef struct pin_run {
|
||||
const void *a;
|
||||
uint64_t inc, epoch;
|
||||
int64_t start; /* its first entry in [pins] */
|
||||
} pin_run;
|
||||
|
||||
static flan_obj **pins;
|
||||
static int64_t pins_n, pins_cap;
|
||||
static pin_run *runs;
|
||||
static int64_t runs_n, runs_cap;
|
||||
/* The number the newest run's texts carry in [gen]; never 0, which is what
|
||||
a text is made with. A wrap would take four billion stamps, and costs one
|
||||
duplicate entry when it lands on an old text's number. */
|
||||
static uint32_t pin_gen;
|
||||
|
||||
static int64_t pins_count(void) { return pins_n; }
|
||||
|
||||
static void pins_prune(void) {
|
||||
int64_t r, k = 0, rk = 0;
|
||||
for (r = 0; r < runs_n; r++) {
|
||||
int64_t lo = runs[r].start;
|
||||
int64_t hi = r + 1 < runs_n ? runs[r + 1].start : pins_n;
|
||||
if (!flan_temp_stamp_live(runs[r].a, runs[r].inc, runs[r].epoch)) continue;
|
||||
memmove(pins + k, pins + lo, (size_t)(hi - lo) * sizeof *pins);
|
||||
runs[rk] = runs[r];
|
||||
runs[rk].start = k;
|
||||
k += hi - lo;
|
||||
rk++;
|
||||
}
|
||||
pins_n = k;
|
||||
runs_n = rk;
|
||||
}
|
||||
|
||||
static void *pins_grow(void *p, int64_t *cap, size_t each) {
|
||||
int64_t c = *cap ? *cap * 2 : 64;
|
||||
void *q = realloc(p, (size_t)c * each);
|
||||
if (q == NULL) trap_oom(NULL, 0, c * (int64_t)each);
|
||||
*cap = c;
|
||||
return q;
|
||||
}
|
||||
|
||||
static void pin_text(flan_obj *o) {
|
||||
uint64_t inc, epoch;
|
||||
const void *a = flan_temp_stamp(&inc, &epoch);
|
||||
pin_run *last = runs_n > 0 ? &runs[runs_n - 1] : NULL;
|
||||
if (last == NULL || last->a != a || last->inc != inc
|
||||
|| last->epoch != epoch) {
|
||||
if (runs_n == runs_cap) {
|
||||
pins_prune();
|
||||
if (runs_n == runs_cap) runs = pins_grow(runs, &runs_cap, sizeof *runs);
|
||||
}
|
||||
runs[runs_n].a = a;
|
||||
runs[runs_n].inc = inc;
|
||||
runs[runs_n].epoch = epoch;
|
||||
runs[runs_n].start = pins_n;
|
||||
runs_n++;
|
||||
if (++pin_gen == 0) pin_gen = 1;
|
||||
} else if (o->gen == pin_gen)
|
||||
return;
|
||||
if (pins_n == pins_cap) {
|
||||
pins_prune();
|
||||
if (pins_n == pins_cap) pins = pins_grow(pins, &pins_cap, sizeof *pins);
|
||||
}
|
||||
o->gen = pin_gen;
|
||||
pins[pins_n++] = o;
|
||||
}
|
||||
|
||||
/* How many texts are pinned now, for a test that the list stays flat. */
|
||||
int64_t flan_dyn_pin_count(void) { return pins_count(); }
|
||||
|
||||
static void gc_mark_all(void) {
|
||||
int64_t i;
|
||||
unsigned k;
|
||||
pins_prune();
|
||||
for (i = 0; i < pins_n; i++) mark_push(pins[i]);
|
||||
for (i = 0; i < roots_n; i++) {
|
||||
const flan_desc *d = roots[i].desc;
|
||||
if (d == NULL) mark_value(*(flan_dyn *)roots[i].base);
|
||||
@ -3030,6 +3133,118 @@ flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
||||
return arith(loc, loclen, "%", a, b);
|
||||
}
|
||||
|
||||
/* ── Bits ──────────────────────────────────────────────────────────────
|
||||
*
|
||||
* Ints only: a float has no bits a program means, and a bool is most likely
|
||||
* a reach for logical and from C, so its trap says which operator that is.
|
||||
* Every answer is the one typed i64 code gives for the same operands. A shift
|
||||
* count outside 0..63 traps rather than being masked as typed code masks it:
|
||||
* there is no width here to have been chosen, and a count out of range is a
|
||||
* mistake the value cannot show. */
|
||||
|
||||
#define BITS_INT "it takes integers"
|
||||
#define BITS_BOOL "it takes integers; true and false are combined with and, or and not"
|
||||
|
||||
static int is_int(flan_dyn v) { return flan_dyn_tag(v) == FLAN_DYN_TAG_INT; }
|
||||
static int is_bool(flan_dyn v) { return flan_dyn_tag(v) == FLAN_DYN_TAG_BOOL; }
|
||||
|
||||
static void want_ints(const uint8_t *loc, int64_t loclen, const char *op,
|
||||
flan_dyn a, flan_dyn b) {
|
||||
if (!is_int(a) || !is_int(b))
|
||||
trap2(loc, loclen, TYPE_TRAP, op,
|
||||
is_bool(a) || is_bool(b) ? BITS_BOOL : BITS_INT, a, b);
|
||||
}
|
||||
|
||||
static void want_int(const uint8_t *loc, int64_t loclen, const char *op,
|
||||
flan_dyn a) {
|
||||
if (!is_int(a))
|
||||
trap1(loc, loclen, TYPE_TRAP, op, is_bool(a) ? BITS_BOOL : BITS_INT, a);
|
||||
}
|
||||
|
||||
flan_dyn flan_dyn_bitand(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
||||
int64_t loclen) {
|
||||
want_ints(loc, loclen, "bit-and", a, b);
|
||||
return flan_dyn_from_i64(dyn_int_value(a) & dyn_int_value(b));
|
||||
}
|
||||
flan_dyn flan_dyn_bitor(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
||||
int64_t loclen) {
|
||||
want_ints(loc, loclen, "bit-or", a, b);
|
||||
return flan_dyn_from_i64(dyn_int_value(a) | dyn_int_value(b));
|
||||
}
|
||||
flan_dyn flan_dyn_bitxor(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
||||
int64_t loclen) {
|
||||
want_ints(loc, loclen, "bit-xor", a, b);
|
||||
return flan_dyn_from_i64(dyn_int_value(a) ^ dyn_int_value(b));
|
||||
}
|
||||
flan_dyn flan_dyn_bitnot(flan_dyn a, const uint8_t *loc, int64_t loclen) {
|
||||
want_int(loc, loclen, "bit-not", a);
|
||||
return flan_dyn_from_i64(~dyn_int_value(a));
|
||||
}
|
||||
|
||||
static uint64_t shift_count(const uint8_t *loc, int64_t loclen, const char *op,
|
||||
flan_dyn a, flan_dyn b) {
|
||||
int64_t n;
|
||||
want_ints(loc, loclen, op, a, b);
|
||||
n = dyn_int_value(b);
|
||||
if (n < 0 || n > 63)
|
||||
trap2(loc, loclen, ARITH_TRAP, op,
|
||||
"the count is outside 0 to 63, the bits an int has", a, b);
|
||||
return (uint64_t)n;
|
||||
}
|
||||
|
||||
flan_dyn flan_dyn_shl(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
||||
int64_t loclen) {
|
||||
uint64_t n = shift_count(loc, loclen, "<<", a, b);
|
||||
return flan_dyn_from_i64((int64_t)((uint64_t)dyn_int_value(a) << n));
|
||||
}
|
||||
/* Arithmetic, as >> on a typed i64 is. */
|
||||
flan_dyn flan_dyn_shr(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
||||
int64_t loclen) {
|
||||
uint64_t n = shift_count(loc, loclen, ">>", a, b);
|
||||
int64_t x = dyn_int_value(a);
|
||||
/* >> on a negative int64_t is implementation-defined in C before C23;
|
||||
* the complement trick is arithmetic on every compiler. */
|
||||
if (x < 0) return flan_dyn_from_i64(~(int64_t)(~(uint64_t)x >> n));
|
||||
return flan_dyn_from_i64((int64_t)((uint64_t)x >> n));
|
||||
}
|
||||
|
||||
static uint64_t rot(uint64_t x, uint64_t n, int left) {
|
||||
n &= 63;
|
||||
if (n == 0) return x;
|
||||
return left ? (x << n) | (x >> (64 - n)) : (x >> n) | (x << (64 - n));
|
||||
}
|
||||
|
||||
flan_dyn flan_dyn_rotl(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
||||
int64_t loclen) {
|
||||
want_ints(loc, loclen, "rotate-left", a, b);
|
||||
return flan_dyn_from_i64((int64_t)rot((uint64_t)dyn_int_value(a),
|
||||
(uint64_t)dyn_int_value(b), 1));
|
||||
}
|
||||
flan_dyn flan_dyn_rotr(flan_dyn a, flan_dyn b, const uint8_t *loc,
|
||||
int64_t loclen) {
|
||||
want_ints(loc, loclen, "rotate-right", a, b);
|
||||
return flan_dyn_from_i64((int64_t)rot((uint64_t)dyn_int_value(a),
|
||||
(uint64_t)dyn_int_value(b), 0));
|
||||
}
|
||||
|
||||
flan_dyn flan_dyn_popcount(flan_dyn a, const uint8_t *loc, int64_t loclen) {
|
||||
want_int(loc, loclen, "popcount", a);
|
||||
return flan_dyn_from_i64(__builtin_popcountll((uint64_t)dyn_int_value(a)));
|
||||
}
|
||||
/* 64 for zero, which the builtins leave undefined. */
|
||||
flan_dyn flan_dyn_clz(flan_dyn a, const uint8_t *loc, int64_t loclen) {
|
||||
uint64_t x;
|
||||
want_int(loc, loclen, "leading-zeros", a);
|
||||
x = (uint64_t)dyn_int_value(a);
|
||||
return flan_dyn_from_i64(x == 0 ? 64 : __builtin_clzll(x));
|
||||
}
|
||||
flan_dyn flan_dyn_ctz(flan_dyn a, const uint8_t *loc, int64_t loclen) {
|
||||
uint64_t x;
|
||||
want_int(loc, loclen, "trailing-zeros", a);
|
||||
x = (uint64_t)dyn_int_value(a);
|
||||
return flan_dyn_from_i64(x == 0 ? 64 : __builtin_ctzll(x));
|
||||
}
|
||||
|
||||
/* ── Ordering ──────────────────────────────────────────────────────────
|
||||
*
|
||||
* Numbers against numbers, text against text, and nothing else. Text orders
|
||||
@ -3340,6 +3555,9 @@ static inline int is_map(flan_dyn v) {
|
||||
* t str (read as a copy; never written from here)
|
||||
* a<n>;T a fixed [n T]
|
||||
* sT a slice [T]
|
||||
* cT a [const T]: only in what a crossing *into* a
|
||||
* written type wants ([flan_dyn_need_as]); no view
|
||||
* is ever of one
|
||||
* vT a (Vec T)
|
||||
* {Name;f1;T1f2;T2} a struct, its fields in declaration order
|
||||
*
|
||||
@ -3370,7 +3588,7 @@ static const uint8_t *desc_name_end(const uint8_t *d) {
|
||||
static const uint8_t *desc_skip(const uint8_t *d) {
|
||||
switch (*d) {
|
||||
case 'a': d++; desc_int(&d); return desc_skip(d);
|
||||
case 's': case 'v': return desc_skip(d + 1);
|
||||
case 's': case 'c': case 'v': return desc_skip(d + 1);
|
||||
case '{':
|
||||
d = desc_name_end(d + 1);
|
||||
while (*d != '}') d = desc_skip(desc_name_end(d));
|
||||
@ -3386,7 +3604,7 @@ static void desc_lay(const uint8_t *d, int64_t *size, int64_t *align) {
|
||||
case 'b': case 'B': case '?': *size = 1; *align = 1; return;
|
||||
case 'h': case 'H': *size = 2; *align = 2; return;
|
||||
case 'i': case 'I': case 'f': *size = 4; *align = 4; return;
|
||||
case 't': case 's': *size = 16; *align = 8; return;
|
||||
case 't': case 's': case 'c': *size = 16; *align = 8; return;
|
||||
case 'v': *size = 40; *align = 8; return;
|
||||
case 'a': {
|
||||
int64_t n, s, a;
|
||||
@ -3505,6 +3723,10 @@ static void desc_spell(const uint8_t *d, char *buf, size_t cap) {
|
||||
desc_spell(d + 1, inner, sizeof inner);
|
||||
snprintf(buf, cap, "[%s]", inner);
|
||||
return;
|
||||
case 'c':
|
||||
desc_spell(d + 1, inner, sizeof inner);
|
||||
snprintf(buf, cap, "[const %s]", inner);
|
||||
return;
|
||||
case 'v':
|
||||
desc_spell(d + 1, inner, sizeof inner);
|
||||
snprintf(buf, cap, "(Vec %s)", inner);
|
||||
@ -4150,6 +4372,445 @@ flan_dyn flan_dyn_view_flat(void *data, int64_t len, int32_t elem) {
|
||||
return view_make(data, len, old_elem_desc(elem), VIEW_FLAT, 0);
|
||||
}
|
||||
|
||||
/* ── Dyn into a written type ───────────────────────────────────────────
|
||||
*
|
||||
* The reverse of a view: a dyn value reaching typed code that wrote a str, a
|
||||
* slice, a fixed array or a struct (lib/check.ml, [into_typed]). [want] is
|
||||
* the written type's descriptor, the prefix code above, with [c] for a
|
||||
* [const T]; [out] is where the typed value goes — a str's or slice's two
|
||||
* words, or the array's or struct's bytes. Four answers, in order:
|
||||
*
|
||||
* a text its own bytes, for a str or a [const u8], pinned
|
||||
* ([pin_text]) and never copied;
|
||||
* a view of typed storage whose element type is the one wanted: that
|
||||
* storage, checked for staleness in a dev build, never copied;
|
||||
* a vec, map copied and unboxed element by element, each checked, for a
|
||||
* [const T], a fixed array or a struct — a [const T]'s block
|
||||
* in the temp arena ([flan_temp_block]);
|
||||
* anything else traps, naming the element and what it is.
|
||||
*
|
||||
* A [T] that can be written through is never a copy. A write through a copy
|
||||
* would not reach the dyn vec, and the same program would then answer
|
||||
* differently with the vec typed or dyn; so a plain dyn vec, or a view of
|
||||
* other elements, into a [T] traps and names [const T]. A fixed array and a
|
||||
* struct are values, copied on the typed side as well, so a copy there
|
||||
* changes nothing. */
|
||||
|
||||
void *flan_temp_block(int64_t bytes, int64_t align, int64_t elem,
|
||||
const char *type, int64_t typelen);
|
||||
|
||||
typedef struct into_site {
|
||||
const uint8_t *loc;
|
||||
int64_t loclen;
|
||||
char op[140]; /* "into [const i64]" */
|
||||
char where[192]; /* "element 2", "field :x of element 2"; "" */
|
||||
} into_site;
|
||||
|
||||
static _Noreturn void into_trap(into_site *s, const char *trap,
|
||||
const char *fmt, ...) {
|
||||
char msg[640];
|
||||
va_list ap;
|
||||
va_start(ap, fmt);
|
||||
vsnprintf(msg, sizeof msg, fmt, ap);
|
||||
va_end(ap);
|
||||
flan_say(s->loc, s->loclen, "dyn %s: %s", s->op, msg);
|
||||
dyn_trap((const uint8_t *)trap, (int64_t)strlen(trap));
|
||||
}
|
||||
|
||||
static const char *into_who(into_site *s) {
|
||||
return s->where[0] ? s->where : "this";
|
||||
}
|
||||
|
||||
/* "element 2 is a text, "a", and an i64 is wanted there". A view is checked
|
||||
* for staleness before it is rendered, since rendering reads it. */
|
||||
static _Noreturn void into_wrong(into_site *s, flan_dyn x, const char *why) {
|
||||
char sx[SAY_MAX];
|
||||
const char *t = tag_of(x);
|
||||
if (dyn_boxed(x) && dyn_box(x) == BOX_OBJ && dyn_obj(x) != NULL
|
||||
&& dyn_obj(x)->kind == OBJ_VIEW)
|
||||
view_guard_check(s->loc, s->loclen, s->op, dyn_obj(x));
|
||||
if (flan_dyn_tag(x) == FLAN_DYN_TAG_NIL)
|
||||
into_trap(s, "DynType", "%s is nil, and %s", into_who(s), why);
|
||||
say(sx, SAY_MAX, x);
|
||||
into_trap(s, "DynType", "%s is %s %s, %s, and %s", into_who(s), an(t), t,
|
||||
sx, why);
|
||||
}
|
||||
|
||||
/* "an i64 is wanted there". */
|
||||
static void into_wanted(char *buf, size_t cap, const uint8_t *d) {
|
||||
char ty[128];
|
||||
desc_spell(d, ty, sizeof ty);
|
||||
snprintf(buf, cap, "%s %s is wanted there", an(ty), ty);
|
||||
}
|
||||
|
||||
/* Whether a view's descriptor [a] starts with the whole of the code [b].
|
||||
* The code is prefix-free, so a view's (inside a longer one) matches exactly
|
||||
* when these bytes do. */
|
||||
static int desc_same(const uint8_t *a, const uint8_t *b) {
|
||||
size_t n = (size_t)(desc_skip(b) - b);
|
||||
return memcmp(a, b, n) == 0;
|
||||
}
|
||||
|
||||
/* A vec's length and element [i], a plain one's word or a view's element
|
||||
* boxed. [o] is a vec-tagged object whose guard has been checked. */
|
||||
static int64_t into_len(into_site *s, flan_obj *o) {
|
||||
return o->kind == OBJ_VIEW ? view_len(s->loc, s->loclen, s->op, o) : o->len;
|
||||
}
|
||||
|
||||
static flan_dyn into_at(into_site *s, flan_obj *o, int64_t i) {
|
||||
if (o->kind == OBJ_VIEW)
|
||||
return view_read(s->loc, s->loclen, s->op, o, o->u.view.desc,
|
||||
view_elem_at(o, i));
|
||||
return o->u.v.items[i];
|
||||
}
|
||||
|
||||
/* A view object, or NULL; checked for staleness when it is one. */
|
||||
static flan_obj *into_view(into_site *s, flan_dyn x) {
|
||||
flan_obj *o;
|
||||
if (!dyn_boxed(x) || dyn_box(x) != BOX_OBJ) return NULL;
|
||||
o = dyn_obj(x);
|
||||
if (o == NULL || o->kind != OBJ_VIEW) return NULL;
|
||||
view_guard_check(s->loc, s->loclen, s->op, o);
|
||||
return o;
|
||||
}
|
||||
|
||||
/* Steps [s->where] into a part of what it names; [into_leave] steps back. */
|
||||
static void into_enter(into_site *s, const char *fmt, ...) {
|
||||
char part[96], rest[192];
|
||||
va_list ap;
|
||||
va_start(ap, fmt);
|
||||
vsnprintf(part, sizeof part, fmt, ap);
|
||||
va_end(ap);
|
||||
memcpy(rest, s->where, sizeof rest);
|
||||
if (rest[0] == '\0') snprintf(s->where, sizeof s->where, "%s", part);
|
||||
else snprintf(s->where, sizeof s->where, "%s of %s", part, rest);
|
||||
}
|
||||
|
||||
static void into_leave(into_site *s, const char *saved) {
|
||||
memcpy(s->where, saved, sizeof s->where);
|
||||
}
|
||||
|
||||
static void into_put(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p);
|
||||
static void into_slice(into_site *s, const uint8_t *d, flan_dyn x,
|
||||
uint8_t *p);
|
||||
|
||||
/* A text's bytes as a str's two words, pinned — or, in a dev build, copied
|
||||
* into the temp arena, whose registry note and poison catch a str kept past
|
||||
* free-temp (see [pin_text]). */
|
||||
static void into_text(flan_dyn x, uint8_t *p) {
|
||||
flan_obj *o = dyn_obj(x);
|
||||
const uint8_t *b = obj_text_bytes(o);
|
||||
if (flan_dev_reg_enabled()) {
|
||||
uint8_t *q = NULL;
|
||||
if (o->len > 0) {
|
||||
q = (uint8_t *)flan_temp_block(o->len, 1, 1, "u8", 2);
|
||||
if (q == NULL) trap_oom(NULL, 0, o->len);
|
||||
memcpy(q, b, (size_t)o->len);
|
||||
}
|
||||
memcpy(p, &q, 8);
|
||||
memcpy(p + 8, &o->len, 8);
|
||||
return;
|
||||
}
|
||||
pin_text(o);
|
||||
memcpy(p, &b, 8);
|
||||
memcpy(p + 8, &o->len, 8);
|
||||
}
|
||||
|
||||
/* [n] elements of [e] from the vec-tagged [o] into [p]. */
|
||||
static void into_elems(into_site *s, const uint8_t *e, flan_obj *o, int64_t n,
|
||||
uint8_t *p) {
|
||||
int64_t i, sz = desc_size(e);
|
||||
char saved[192];
|
||||
memcpy(saved, s->where, sizeof saved);
|
||||
for (i = 0; i < n; i++) {
|
||||
flan_dyn x;
|
||||
into_enter(s, "element %lld", (long long)i);
|
||||
x = into_at(s, o, i);
|
||||
into_put(s, e, x, p + i * sz);
|
||||
into_leave(s, saved);
|
||||
}
|
||||
}
|
||||
|
||||
static void into_put(into_site *s, const uint8_t *d, flan_dyn x, uint8_t *p) {
|
||||
char why[256], ty[128];
|
||||
int64_t lo, hi;
|
||||
if (int_range(*d, &lo, &hi)) {
|
||||
int64_t n;
|
||||
if (flan_dyn_tag(x) != FLAN_DYN_TAG_INT) {
|
||||
into_wanted(why, sizeof why, d);
|
||||
into_wrong(s, x, why);
|
||||
}
|
||||
n = dyn_int_value(x);
|
||||
if (n < lo || n > hi) {
|
||||
desc_spell(d, ty, sizeof ty);
|
||||
if (*d == 'L')
|
||||
into_trap(s, "DynRange", "%s is %lld, and a u64 holds no negative "
|
||||
"number", into_who(s), (long long)n);
|
||||
into_trap(s, "DynRange", "%s is %lld, and %s %s holds %lld to %lld",
|
||||
into_who(s), (long long)n, an(ty), ty, (long long)lo,
|
||||
(long long)hi);
|
||||
}
|
||||
switch (*d) {
|
||||
case 'b': case 'B': { uint8_t b = (uint8_t)n; memcpy(p, &b, 1); return; }
|
||||
case 'h': case 'H': { uint16_t h = (uint16_t)n; memcpy(p, &h, 2); return; }
|
||||
case 'i': case 'I': { uint32_t w = (uint32_t)n; memcpy(p, &w, 4); return; }
|
||||
default: memcpy(p, &n, 8); return;
|
||||
}
|
||||
}
|
||||
switch (*d) {
|
||||
case 'f': case 'd': {
|
||||
double f = 0;
|
||||
/* An int goes into a float when the float holds it exactly: a view's
|
||||
element write and a class's float slot take the same rule. */
|
||||
if (flan_dyn_tag(x) == FLAN_DYN_TAG_INT) {
|
||||
int64_t n = dyn_int_value(x);
|
||||
f = *d == 'f' ? (double)(float)n : (double)n;
|
||||
if (!(f >= -9223372036854775808.0 && f < 9223372036854775808.0)
|
||||
|| (int64_t)f != n)
|
||||
into_trap(s, "DynRange", "%s is %lld, which has no exact %s. Write "
|
||||
"it as a float, as in %lld.0", into_who(s), (long long)n,
|
||||
*d == 'f' ? "f32" : "f64", (long long)n);
|
||||
} else if (flan_dyn_tag(x) == FLAN_DYN_TAG_FLOAT) {
|
||||
f = dyn_num_value(x);
|
||||
/* A finite float past f32's range would become inf, which is a change
|
||||
of value and not a rounding: refused, as an int out of range is. */
|
||||
if (*d == 'f' && f == f && f - f == 0 && (f > 3.4028234663852886e38
|
||||
|| f < -3.4028234663852886e38)) {
|
||||
char sx[SAY_MAX];
|
||||
say(sx, SAY_MAX, x);
|
||||
into_trap(s, "DynRange", "%s is %s, and an f32 holds -3.4028235e38 "
|
||||
"to 3.4028235e38", into_who(s), sx);
|
||||
}
|
||||
} else {
|
||||
into_wanted(why, sizeof why, d);
|
||||
into_wrong(s, x, why);
|
||||
}
|
||||
if (*d == 'f') { float g = (float)f; memcpy(p, &g, 4); }
|
||||
else memcpy(p, &f, 8);
|
||||
return;
|
||||
}
|
||||
case '?':
|
||||
if (flan_dyn_tag(x) != FLAN_DYN_TAG_BOOL) {
|
||||
into_wanted(why, sizeof why, d);
|
||||
into_wrong(s, x, why);
|
||||
}
|
||||
*p = dyn_payload(x) ? 1 : 0;
|
||||
return;
|
||||
case 't':
|
||||
if (!is_text(x))
|
||||
into_wrong(s, x, "a str is wanted there, which only a text becomes");
|
||||
into_text(x, p);
|
||||
return;
|
||||
case 'a': {
|
||||
const uint8_t *e = d + 1;
|
||||
int64_t n = desc_int(&e), len;
|
||||
flan_obj *o;
|
||||
if (!is_vec(x)) {
|
||||
desc_spell(d, ty, sizeof ty);
|
||||
snprintf(why, sizeof why, "%s %s is made from a vec", an(ty), ty);
|
||||
into_wrong(s, x, why);
|
||||
}
|
||||
o = into_view(s, x);
|
||||
if (o == NULL) o = dyn_obj(x);
|
||||
len = into_len(s, o);
|
||||
if (len != n) {
|
||||
desc_spell(d, ty, sizeof ty);
|
||||
into_trap(s, "DynRange", "%s has %lld element%s, and %s %s holds "
|
||||
"exactly %lld", s->where[0] ? s->where : "this vec",
|
||||
(long long)len, len == 1 ? "" : "s", an(ty), ty,
|
||||
(long long)n);
|
||||
}
|
||||
/* A view of the same elements is the same bytes: an array is a value,
|
||||
copied on the typed side too. */
|
||||
if (o->kind == OBJ_VIEW && desc_same(o->u.view.desc, e)) {
|
||||
if (n > 0) memcpy(p, view_base(o), (size_t)(n * desc_size(e)));
|
||||
return;
|
||||
}
|
||||
into_elems(s, e, o, n, p);
|
||||
return;
|
||||
}
|
||||
case '{': {
|
||||
const uint8_t *at, *name, *fty;
|
||||
int64_t off, namelen, foff;
|
||||
flan_obj *o;
|
||||
char saved[192];
|
||||
if (!is_map(x)) {
|
||||
desc_spell(d, ty, sizeof ty);
|
||||
snprintf(why, sizeof why, "%s %s is made from a map", an(ty), ty);
|
||||
into_wrong(s, x, why);
|
||||
}
|
||||
o = into_view(s, x);
|
||||
if (o != NULL && desc_same(o->u.view.desc, d)) {
|
||||
memcpy(p, o->u.view.base, (size_t)desc_size(d));
|
||||
return;
|
||||
}
|
||||
memcpy(saved, s->where, sizeof saved);
|
||||
/* What the value is called in a sentence: its place inside the whole,
|
||||
else what it is — a struct's view, a class's instance, a map. */
|
||||
{
|
||||
char what[160];
|
||||
flan_obj *m = dyn_obj(x);
|
||||
int64_t i, n;
|
||||
if (s->where[0]) snprintf(what, sizeof what, "%s", s->where);
|
||||
else if (o != NULL) {
|
||||
const char *nm;
|
||||
int64_t nl;
|
||||
view_struct_name(o, &nm, &nl);
|
||||
snprintf(what, sizeof what, "this %.*s", (int)nl, nm);
|
||||
} else if (m->u.v.klass != NULL) {
|
||||
kw_entry *k = m->u.v.klass;
|
||||
snprintf(what, sizeof what, "this %.*s", (int)k->len,
|
||||
(const char *)kw_bytes(k));
|
||||
} else
|
||||
snprintf(what, sizeof what, "this map");
|
||||
at = desc_fields(d, &off);
|
||||
while (desc_next(&at, &off, &name, &namelen, &foff, &fty))
|
||||
if (!flan_dyn_truthy(flan_dyn_map_contains_at(
|
||||
x, flan_dyn_kw(name, namelen), s->loc, s->loclen))) {
|
||||
desc_spell(d, ty, sizeof ty);
|
||||
into_trap(s, "DynType", "%s has no :%.*s, and %s %s needs every "
|
||||
"field", what, (int)namelen, (const char *)name, an(ty),
|
||||
ty);
|
||||
}
|
||||
/* A key the struct has no field for is refused, as a class refuses a
|
||||
slot it does not declare: dropping it would lose what was written. */
|
||||
if (o == NULL) class_sync(m);
|
||||
n = o != NULL ? view_nfields(o) : m->len;
|
||||
for (i = 0; i < n; i++) {
|
||||
flan_dyn k = o != NULL ? view_field_key(o, i) : m->u.v.items[2 * i];
|
||||
int64_t foff2;
|
||||
if (desc_field(d, k, &foff2) == NULL) {
|
||||
char sk[SAY_MAX];
|
||||
int64_t off2;
|
||||
const uint8_t *at2;
|
||||
say(sk, SAY_MAX, k);
|
||||
desc_spell(d, ty, sizeof ty);
|
||||
said_len = 0;
|
||||
said_add("dyn %s: %s has %s, and %s %s has no field %s. Its fields "
|
||||
"are", s->op, what, sk, an(ty), ty, sk);
|
||||
at2 = desc_fields(d, &off2);
|
||||
while (desc_next(&at2, &off2, &name, &namelen, &foff, &fty))
|
||||
said_add(" :%.*s", (int)namelen, (const char *)name);
|
||||
flan_say(s->loc, s->loclen, "%s", said_buf);
|
||||
dyn_trap((const uint8_t *)"DynType", 7);
|
||||
}
|
||||
}
|
||||
}
|
||||
at = desc_fields(d, &off);
|
||||
while (desc_next(&at, &off, &name, &namelen, &foff, &fty)) {
|
||||
flan_dyn k = flan_dyn_kw(name, namelen), v;
|
||||
v = flan_dyn_get(x, k, s->loc, s->loclen);
|
||||
into_enter(s, "field :%.*s", (int)namelen, (const char *)name);
|
||||
into_put(s, fty, v, p + foff);
|
||||
into_leave(s, saved);
|
||||
}
|
||||
return;
|
||||
}
|
||||
case 's': case 'c':
|
||||
into_slice(s, d, x, p);
|
||||
return;
|
||||
default:
|
||||
desc_spell(d, ty, sizeof ty);
|
||||
snprintf(why, sizeof why, "%s %s is not made from a dyn value", an(ty), ty);
|
||||
into_wrong(s, x, why);
|
||||
}
|
||||
}
|
||||
|
||||
/* The copy a [const T] reads, of a plain vec or a view of other elements. */
|
||||
static void into_copy(into_site *s, const uint8_t *e, flan_obj *o,
|
||||
uint8_t *out) {
|
||||
static const char scalars[] = "bBhHiIlLfd?t";
|
||||
static const char *const words[] = { "i8", "u8", "i16", "u16", "i32", "u32",
|
||||
"i64", "u64", "f32", "f64", "bool",
|
||||
"str" };
|
||||
const char *w = *e != '\0' ? strchr(scalars, *e) : NULL;
|
||||
/* The registry keeps the name by pointer, so it is static text. */
|
||||
const char *type = w != NULL ? words[w - scalars] : "element";
|
||||
int64_t n = into_len(s, o), size, align;
|
||||
uint8_t *block = NULL;
|
||||
desc_lay(e, &size, &align);
|
||||
if (n > 0 && size > 0) {
|
||||
block = (uint8_t *)flan_temp_block(n * size, align, size, type,
|
||||
(int64_t)strlen(type));
|
||||
if (block == NULL) trap_oom(s->loc, s->loclen, n * size);
|
||||
memset(block, 0, (size_t)(n * size));
|
||||
into_elems(s, e, o, n, block);
|
||||
}
|
||||
memcpy(out, &block, 8);
|
||||
memcpy(out + 8, &n, 8);
|
||||
}
|
||||
|
||||
/* A [T] or a [const T], at the top or inside an array or a struct. A text
|
||||
* is a [const u8]'s bytes, a view of the very elements wanted is its own
|
||||
* storage, and a [const T] of anything else vec-shaped is a copy; a [T]
|
||||
* never is, since a write through it would not reach the vec. */
|
||||
static void into_slice(into_site *s, const uint8_t *d, flan_dyn x,
|
||||
uint8_t *p) {
|
||||
const uint8_t *e = d + 1;
|
||||
int mut = *d == 's';
|
||||
const char *who = s->where[0] ? s->where : "this vec";
|
||||
char ty[128], ety[128], why[256];
|
||||
flan_obj *o;
|
||||
desc_spell(d, ty, sizeof ty);
|
||||
desc_spell(e, ety, sizeof ety);
|
||||
if (is_text(x) && *e == 'B') {
|
||||
if (mut)
|
||||
into_wrong(s, x, "a text is read-only, so it becomes a str or a "
|
||||
"[const u8] and never a [u8]");
|
||||
into_text(x, p);
|
||||
return;
|
||||
}
|
||||
if (!is_vec(x)) {
|
||||
snprintf(why, sizeof why, "only a vec becomes %s %s", an(ty), ty);
|
||||
into_wrong(s, x, why);
|
||||
}
|
||||
o = into_view(s, x);
|
||||
if (o != NULL && desc_same(o->u.view.desc, e)) {
|
||||
void *b = view_base(o);
|
||||
int64_t n = view_len(s->loc, s->loclen, s->op, o);
|
||||
memcpy(p, &b, 8);
|
||||
memcpy(p + 8, &n, 8);
|
||||
return;
|
||||
}
|
||||
if (mut) {
|
||||
char have[128];
|
||||
if (o != NULL) {
|
||||
desc_spell(o->u.view.desc, have, sizeof have);
|
||||
into_trap(s, "DynType", "%s is a view of %s elements, so %s %s of it "
|
||||
"would be a copy, and a write through the copy would never "
|
||||
"reach the vec. Take it as [const %s], which reads a copy",
|
||||
who, have, an(ty), ty, ety);
|
||||
}
|
||||
into_trap(s, "DynType", "%s is a dyn vec, so %s %s of it would be a "
|
||||
"copy, and a write through the copy would never reach the vec. "
|
||||
"Take it as [const %s], which reads a copy", who, an(ty), ty,
|
||||
ety);
|
||||
}
|
||||
into_copy(s, e, o != NULL ? o : dyn_obj(x), p);
|
||||
}
|
||||
|
||||
void flan_dyn_need_as(flan_dyn v, const uint8_t *want, int64_t wantlen,
|
||||
void *out, const uint8_t *loc, int64_t loclen) {
|
||||
into_site s;
|
||||
char ty[128];
|
||||
uint8_t *p = (uint8_t *)out;
|
||||
(void)wantlen;
|
||||
s.loc = loc;
|
||||
s.loclen = loclen;
|
||||
s.where[0] = '\0';
|
||||
desc_spell(want, ty, sizeof ty);
|
||||
snprintf(s.op, sizeof s.op, "into %s", ty);
|
||||
switch (*want) {
|
||||
case 't':
|
||||
if (!is_text(v)) into_wrong(&s, v, "only a text becomes a str");
|
||||
into_text(v, p);
|
||||
return;
|
||||
default:
|
||||
into_put(&s, want, v, p);
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
static flan_dyn len_walk(flan_dyn v) {
|
||||
if (is_text(v)) return flan_dyn_from_i64(dyn_obj(v)->u.i);
|
||||
/* A map's length is its slot count, so a stale instance would answer the
|
||||
|
||||
@ -208,6 +208,20 @@ flan_dyn flan_dyn_div(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen
|
||||
flan_dyn flan_dyn_rem(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_neg(flan_dyn a, const uint8_t *loc, int64_t loclen);
|
||||
|
||||
/* The bit operations, on ints only. A shift count outside 0..63 traps, where
|
||||
* typed code masks it; a rotation takes its count modulo 64. */
|
||||
flan_dyn flan_dyn_bitand(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_bitor(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_bitxor(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_bitnot(flan_dyn a, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_shl(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_shr(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_rotl(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_rotr(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_popcount(flan_dyn a, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_clz(flan_dyn a, const uint8_t *loc, int64_t loclen);
|
||||
flan_dyn flan_dyn_ctz(flan_dyn a, const uint8_t *loc, int64_t loclen);
|
||||
|
||||
/* Answer a bool dyn. Numbers compare as numbers and text compares bytewise,
|
||||
* chars by code point; a mixture, or anything else, traps. */
|
||||
flan_dyn flan_dyn_lt(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);
|
||||
@ -366,6 +380,18 @@ flan_dyn flan_dyn_view_slice(void *data, int64_t len, const uint8_t *desc,
|
||||
flan_dyn flan_dyn_view_at(void *addr, int64_t len, const uint8_t *desc,
|
||||
int64_t desclen, int32_t shape, int32_t here);
|
||||
|
||||
/* The other direction: a dyn value where typed code wrote a str, a [T], a
|
||||
* [const T], a fixed [n T] or a struct. [want] is that type's descriptor
|
||||
* (the code above, and 'c' before a [const T]'s element); [out] receives the
|
||||
* str's or slice's two words, or the array's or struct's bytes. A text
|
||||
* becomes a str or a [const u8] as its own bytes, kept from the collector
|
||||
* until the temp arena's next free-all; a view of the wanted elements
|
||||
* becomes its own storage; a vec or a map becomes a checked copy — for a
|
||||
* [const T] in the temp arena — and a [T] is never a copy. Anything else
|
||||
* traps at [loc], naming the element and what it holds. */
|
||||
void flan_dyn_need_as(flan_dyn v, const uint8_t *want, int64_t wantlen,
|
||||
void *out, const uint8_t *loc, int64_t loclen);
|
||||
|
||||
/* print, =, length and has-key? with the site they were written at: a view
|
||||
* that traps inside one names it. */
|
||||
void flan_dyn_print_at(flan_dyn v, const uint8_t *loc, int64_t loclen);
|
||||
|
||||
@ -1125,13 +1125,86 @@ _Noreturn void flan_restart_fail(const uint8_t *loc, int64_t loclen,
|
||||
* dynamic stack, so the invoke site cannot see what it will find, and the
|
||||
* frame cannot see who will find it. What each end knows is its own parameter
|
||||
* list, so the message is both of them side by side. */
|
||||
/* The top-level items of a signature "(a b c)", where an item may itself be
|
||||
* bracketed: "(Ptr i32)", "[3 f64]". Up to [max]; answers how many. */
|
||||
static int sig_items(const uint8_t *s, int64_t n, const uint8_t **at,
|
||||
int64_t *len, int max) {
|
||||
int count = 0, depth = 0;
|
||||
int64_t start = -1;
|
||||
for (int64_t i = 1; i + 1 < n; i++) {
|
||||
uint8_t c = s[i];
|
||||
if (c == ' ' && depth == 0) {
|
||||
if (start >= 0 && count < max) { at[count] = s + start; len[count] = i - start; count++; }
|
||||
start = -1;
|
||||
continue;
|
||||
}
|
||||
if (start < 0) start = i;
|
||||
if (c == '(' || c == '[') depth++;
|
||||
else if (c == ')' || c == ']') depth--;
|
||||
}
|
||||
if (start >= 0 && count < max) { at[count] = s + start; len[count] = n - 1 - start; count++; }
|
||||
return count;
|
||||
}
|
||||
|
||||
static int is_number_type(const uint8_t *s, int64_t n) {
|
||||
static const char *names[] = { "i8", "i16", "i32", "i64", "u8", "u16",
|
||||
"u32", "u64", "f32", "f64" };
|
||||
for (size_t k = 0; k < sizeof names / sizeof names[0]; k++)
|
||||
if ((int64_t)strlen(names[k]) == n && memcmp(names[k], s, (size_t)n) == 0)
|
||||
return 1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
/* [got] is the invoke site's signature, then after each 0x1f: the syntax
|
||||
* (i or p) and every argument as written. Where the two signatures differ
|
||||
* only in which number type an argument is, the fix is that argument
|
||||
* converted: (f64 2.5), or f64(2.5) in the indented syntax. */
|
||||
_Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen,
|
||||
const uint8_t *name, int64_t namelen,
|
||||
const uint8_t *want, int64_t wantlen,
|
||||
const uint8_t *got, int64_t gotlen) {
|
||||
flan_say(loc, loclen, "restart %.*s takes %.*s, given %.*s", (int)namelen,
|
||||
(const char *)name, (int)wantlen, (const char *)want, (int)gotlen,
|
||||
(const char *)got);
|
||||
enum { MAX = 16 };
|
||||
const uint8_t *part[MAX + 2];
|
||||
int64_t plen[MAX + 2];
|
||||
int parts = 0;
|
||||
int64_t start = 0;
|
||||
for (int64_t i = 0; i <= gotlen && parts < MAX + 2; i++)
|
||||
if (i == gotlen || got[i] == 0x1f) {
|
||||
part[parts] = got + start; plen[parts] = i - start; parts++;
|
||||
start = i + 1;
|
||||
}
|
||||
const uint8_t *w[MAX], *g[MAX];
|
||||
int64_t wl[MAX], gl[MAX];
|
||||
int nw = sig_items(want, wantlen, w, wl, MAX);
|
||||
int ng = sig_items(part[0], plen[0], g, gl, MAX);
|
||||
char fix[512];
|
||||
size_t used = 0;
|
||||
fix[0] = 0;
|
||||
int ok = parts >= 2 && nw == ng && ng == parts - 2 && ng > 0;
|
||||
for (int k = 0; ok && k < ng; k++) {
|
||||
if (wl[k] == gl[k] && memcmp(w[k], g[k], (size_t)wl[k]) == 0) continue;
|
||||
if (!is_number_type(w[k], wl[k]) || !is_number_type(g[k], gl[k])) { ok = 0; break; }
|
||||
int indented = plen[1] == 1 && part[1][0] == 'i';
|
||||
int wrote = indented
|
||||
? snprintf(fix + used, sizeof fix - used, "%s%.*s(%.*s)", used ? ", " : "",
|
||||
(int)wl[k], (const char *)w[k], (int)plen[k + 2], (const char *)part[k + 2])
|
||||
: snprintf(fix + used, sizeof fix - used, "%s(%.*s %.*s)", used ? ", " : "",
|
||||
(int)wl[k], (const char *)w[k], (int)plen[k + 2], (const char *)part[k + 2]);
|
||||
if (wrote < 0 || (size_t)wrote >= sizeof fix - used) { ok = 0; break; }
|
||||
used += (size_t)wrote;
|
||||
}
|
||||
/* An argument the compiler could not spell is an ellipsis, and a fix with
|
||||
* a hole in it is a conversion to make, not code to paste. */
|
||||
int holed = strstr(fix, "\xe2\x80\xa6") != NULL;
|
||||
if (ok && used > 0)
|
||||
flan_say(loc, loclen, "restart %.*s takes %.*s, given %.*s. %s %s",
|
||||
(int)namelen, (const char *)name, (int)wantlen, (const char *)want,
|
||||
(int)plen[0], (const char *)part[0],
|
||||
holed ? "Convert the argument with" : "Write", fix);
|
||||
else
|
||||
flan_say(loc, loclen, "restart %.*s takes %.*s, given %.*s", (int)namelen,
|
||||
(const char *)name, (int)wantlen, (const char *)want, (int)plen[0],
|
||||
(const char *)part[0]);
|
||||
rt_trap((const uint8_t *)"RestartArity", 12);
|
||||
}
|
||||
|
||||
@ -2593,6 +2666,40 @@ int8_t flan_f64_temp(double x, flan_slice *out) {
|
||||
return flan_temp_text(render_f64, &x, out);
|
||||
}
|
||||
|
||||
/* For flan_dyn.c's crossing of a dyn value into a written type
|
||||
* ([flan_dyn_need_as]). A dyn vec copied into a [const T] or a text's bytes
|
||||
* lent to a str live exactly as long as i64->bytes's text does: until the
|
||||
* temp arena's next free-all. [flan_temp_block] is the copy's block, noted
|
||||
* in a dev build's registry like any temp slice so a read after free-temp
|
||||
* traps or reads poison; NULL only when malloc itself failed. The stamp is
|
||||
* the arena and the incarnation and epoch it is at now, and a stamp is live
|
||||
* while that arena is still at both — a free-temp, the agent's wipe, the end
|
||||
* of a scratch evaluation or a destroy ends it. An arena record is never
|
||||
* freed (see [flan_retired]), so an old stamp is always safe to read. */
|
||||
void *flan_temp_block(int64_t bytes, int64_t align, int64_t elem,
|
||||
const char *type, int64_t typelen) {
|
||||
flan_allocator *a = flan_context_temp();
|
||||
void *q;
|
||||
if (a == NULL || bytes <= 0) return NULL;
|
||||
q = a->proc(a, FLAN_ALLOC_ALLOC, NULL, 0, bytes, align);
|
||||
if (q != NULL) flan_dev_reg_note_sliced(q, bytes, elem, type, typelen, a);
|
||||
return q;
|
||||
}
|
||||
|
||||
const void *flan_temp_stamp(uint64_t *inc, uint64_t *epoch) {
|
||||
flan_allocator *a = flan_context_temp();
|
||||
*inc = a ? a->incarnation : 0;
|
||||
*epoch = a ? a->epoch : 0;
|
||||
return a;
|
||||
}
|
||||
|
||||
int32_t flan_temp_stamp_live(const void *p, uint64_t inc, uint64_t epoch) {
|
||||
const flan_allocator *a = (const flan_allocator *)p;
|
||||
/* No temp arena could be made: the pin is kept for good. */
|
||||
if (a == NULL) return 1;
|
||||
return a->incarnation == inc && a->epoch == epoch;
|
||||
}
|
||||
|
||||
/* The allocator's identity, for the condition's :allocator field. The pointer
|
||||
* is the identity — the same thing the epoch hangs off. */
|
||||
int64_t flan_alloc_id(flan_allocator *a) { return (int64_t)(intptr_t)a; }
|
||||
|
||||
@ -155,9 +155,26 @@ Each item: the proposal, then the reason in one line.
|
||||
### Expressions
|
||||
|
||||
- **Precedence**, low to high: `or` < `and` < `not` < comparisons
|
||||
(`== != < <= > >=`) < `<< >>` < `+ -` < `* / %` < unary `-` < postfix (call,
|
||||
index, field). **Built.** Mixing comparison operators in one chain,
|
||||
`a < b <= c`, is refused. An operator glued to `(` is always a call.
|
||||
(`== != < <= > >=`) < `||` < `^^` < `&&` < `<< >>` < `+ -` < `* / %` <
|
||||
prefix `-` and `~~` < postfix (call, index, field). **Built.** An operator
|
||||
glued to `(` is always a call. The bit operators sit where Python and Rust
|
||||
put them, so `x && mask == 0` is `(x && mask) == 0`.
|
||||
- **The bit operators** are `a && b`, `a || b`, `a ^^ b` and `~~a`, reading
|
||||
`(bit-and a b)`, `(bit-or a b)`, `(bit-xor a b)` and `(bit-not a)`. They take
|
||||
integers; `and`, `or` and `not` are the logical ones. `~~` is one token, so a
|
||||
nested unquote is written `~(~x)`. **Built.**
|
||||
- **A comparison chain may mix `<` with `<=`, or `>` with `>=`** (decision
|
||||
124). `0 <= r < rows` reads `(and (<= 0 r) (< r rows))`. It is evaluated as
|
||||
`a < b < c` is: every operand once, left to right, before any test, with no
|
||||
short-circuit. When an operand is more than a name or a literal, every
|
||||
operand but a literal is bound first, in order, to a fresh name, so a name
|
||||
is read before a call to its right runs: `a < f(x) <= b` reads
|
||||
`(let [~cmp1 a ~cmp2 (f x) ~cmp3 b] (and (< ~cmp1 ~cmp2) (<= ~cmp2 ~cmp3)))`.
|
||||
`flan convert` to parens names them `mid`, `mid2`, ..., or, inside a
|
||||
template, `~(Form.Sym {.s "~cmp1"})`, which no caller can capture. A chain that
|
||||
changes direction, `a < b > c`, or mixes in `==` or `!=`, is refused with the
|
||||
whole chain rewritten as `and`, a middle call named by a `let` first. The
|
||||
printer writes such an `and` back as the chain. **Built.**
|
||||
- **`==` is `=`; `=` is assignment.** `x = v` reads `(set x v)`, `a[i] = v`
|
||||
reads `(set (at a i) v)`, `p.x = v` reads `(set (.x p) v)`. `x += v` reads
|
||||
`(set x (+ x v))` where every part of the place is a name or a literal, and
|
||||
|
||||
@ -1408,6 +1408,31 @@ static void walk_hook(const uint8_t *name, int64_t namelen) {
|
||||
longjmp(walk_out, 1);
|
||||
}
|
||||
|
||||
/* flan_dyn_need_as: a text is a str's own bytes, a view of the same
|
||||
* elements its own storage, and a plain vec a checked copy. */
|
||||
static void into(void) {
|
||||
static int64_t a[3] = { 1, 2, 3 };
|
||||
struct { const uint8_t *p; int64_t n; } s;
|
||||
int64_t arr[2];
|
||||
flan_dyn t, v, w;
|
||||
flan_gc_init();
|
||||
t = flan_dyn_from_bytes((const uint8_t *)"abc", 3);
|
||||
flan_dyn_root_push(&t);
|
||||
flan_dyn_need_as(t, (const uint8_t *)"t", 1, &s, NULL, 0);
|
||||
check(s.n == 3 && memcmp(s.p, "abc", 3) == 0, "into str");
|
||||
v = flan_dyn_view_slice(a, 3, (const uint8_t *)"l", 1, 0);
|
||||
flan_dyn_root_push(&v);
|
||||
flan_dyn_need_as(v, (const uint8_t *)"sl", 2, &s, NULL, 0);
|
||||
check((const void *)s.p == (const void *)a && s.n == 3, "into [i64] view");
|
||||
w = flan_dyn_vec_new();
|
||||
flan_dyn_root_push(&w);
|
||||
flan_dyn_push(w, flan_dyn_from_i64(7), NULL, 0);
|
||||
flan_dyn_push(w, flan_dyn_from_i64(8), NULL, 0);
|
||||
flan_dyn_need_as(w, (const uint8_t *)"a2;l", 4, arr, NULL, 0);
|
||||
check(arr[0] == 7 && arr[1] == 8, "into [2 i64] copy");
|
||||
flan_dyn_root_pop(3);
|
||||
}
|
||||
|
||||
static void walkreset(void) {
|
||||
static uint64_t big[1] = { UINT64_MAX };
|
||||
flan_dyn v, w, m;
|
||||
@ -1438,6 +1463,7 @@ int main(int argc, char **argv) {
|
||||
}
|
||||
if (strcmp(argv[1], "ops") == 0) {
|
||||
ops();
|
||||
into();
|
||||
printf(failures == 0 ? "ops ok\n" : "ops failed\n");
|
||||
return failures == 0 ? 0 : 1;
|
||||
}
|
||||
|
||||
51
test/programs/bits-dyn.flan
Normal file
51
test/programs/bits-dyn.flan
Normal file
@ -0,0 +1,51 @@
|
||||
;;;; The bit operators on dyn ints, beside the same operations on typed i64:
|
||||
;;;; each line prints the dyn answer, the typed one, and whether they agree.
|
||||
;;;; A dyn int is an i64, so the two must be the same number for every count
|
||||
;;;; in 0..63. With an argument, the program traps instead: 1 a shift count
|
||||
;;;; out of range, 2 a bool operand, 3 a float operand, 4 a negative count to >>.
|
||||
|
||||
(defn dyn-ops [a b n] dyn
|
||||
[(bit-and a b) (bit-or a b) (bit-xor a b) (bit-not a) (<< a n) (>> a n)
|
||||
(rotate-left a n) (rotate-right a n) (popcount a) (leading-zeros a)
|
||||
(trailing-zeros a) (bit-xor a b n) (&& a b) (|| a b)])
|
||||
|
||||
(defn typed-ops [a i64 b i64 n i64] [14 i64]
|
||||
[(bit-and a b) (bit-or a b) (bit-xor a b) (bit-not a) (<< a n) (>> a n)
|
||||
(rotate-left a n) (rotate-right a n) (popcount a) (leading-zeros a)
|
||||
(trailing-zeros a) (bit-xor a b n) (&& a b) (|| a b)])
|
||||
|
||||
(defn compare [a i64 b i64 n i64] ()
|
||||
(let [d (dyn-ops a b n)
|
||||
t (typed-ops a b n)]
|
||||
(dotimes [i 14]
|
||||
(print (at d i) " ")
|
||||
(when (!= (i64 (at d i)) (at t i))
|
||||
(print "DIFFER at " i " typed " (at t i) " ")))
|
||||
(println)))
|
||||
|
||||
;; A typed operand beside a dyn one makes the whole operation dyn.
|
||||
(defonce mask i32 255)
|
||||
(defn mixed [x] dyn (bit-and x mask))
|
||||
|
||||
(defn shift [a n] dyn (<< a n))
|
||||
(defn sar [a n] dyn (>> a n))
|
||||
(defn band [a b] dyn (bit-and a b))
|
||||
|
||||
(defn main [args [str]] i32
|
||||
(let [k (if (> (length args) 1) (bytes->i64 (bytes-view (at args 1))) 0)]
|
||||
(cond
|
||||
(= k 0)
|
||||
(do
|
||||
(compare 0 0 0)
|
||||
(compare -1 12345 63)
|
||||
(compare -9000000000000000000 1234567890123 13)
|
||||
(compare 9223372036854775807 -9223372036854775807 1)
|
||||
(compare 281474976710656 -281474976710657 47)
|
||||
(compare 1 3 62)
|
||||
(println (mixed 4660) (mixed -1))
|
||||
(println (leading-zeros 0) (trailing-zeros 0) (popcount -1))
|
||||
0)
|
||||
(= k 1) (do (println "before") (println (shift 1 64)) 0)
|
||||
(= k 2) (do (println "before") (println (band true 1)) 0)
|
||||
(= k 3) (do (println "before") (println (band 1.5 1)) 0)
|
||||
:else (do (println "before") (println (sar 1 -1)) 0))))
|
||||
46
test/programs/bits.flan
Normal file
46
test/programs/bits.flan
Normal file
@ -0,0 +1,46 @@
|
||||
;;;; The bit operators at every integer width, typed. Every operand is a
|
||||
;;;; global or a parameter, so -O2 folds nothing and the x86 backend lowers
|
||||
;;;; each one; the three builds must print the same lines. One generic body
|
||||
;;;; covers the widths, which also walks the integer? bound.
|
||||
|
||||
(defn bits [a $t b $t n $t] ()
|
||||
{:where (integer? $t)}
|
||||
(println (bit-and a b) (bit-or a b) (bit-xor a b) (bit-not a)
|
||||
(bit-and a b n) (&& a b) (|| a b) (^^ a b))
|
||||
(println (<< a n) (>> a n) (rotate-left a n) (rotate-right a n))
|
||||
(println (popcount a) (leading-zeros a) (trailing-zeros a)
|
||||
(popcount b) (leading-zeros b) (trailing-zeros b)))
|
||||
|
||||
(defonce i8a i8 -100) (defonce i8b i8 45) (defonce i8n i8 3)
|
||||
(defonce i16a i16 -30000) (defonce i16b i16 12345) (defonce i16n i16 5)
|
||||
(defonce i32a i32 -2000000000) (defonce i32b i32 123456789) (defonce i32n i32 7)
|
||||
(defonce i64a i64 -9000000000000000000) (defonce i64b i64 1234567890123) (defonce i64n i64 13)
|
||||
(defonce u8a u8 200) (defonce u8b u8 45) (defonce u8n u8 3)
|
||||
(defonce u16a u16 60000) (defonce u16b u16 12345) (defonce u16n u16 5)
|
||||
(defonce u32a u32 4000000000) (defonce u32b u32 123456789) (defonce u32n u32 7)
|
||||
(defonce u64a u64 18000000000000000000) (defonce u64b u64 1234567890123) (defonce u64n u64 13)
|
||||
|
||||
;; Zero, for the counts: leading-zeros and trailing-zeros answer the width.
|
||||
(defonce z8 i8 0) (defonce z16 u16 0) (defonce z32 i32 0) (defonce z64 u64 0)
|
||||
;; A rotation count past the width, and a negative one: both modulo the width.
|
||||
(defonce big32 i32 35) (defonce neg32 i32 -1) (defonce big8 u8 11)
|
||||
|
||||
(defn main [] i32
|
||||
(bits i8a i8b i8n)
|
||||
(bits i16a i16b i16n)
|
||||
(bits i32a i32b i32n)
|
||||
(bits i64a i64b i64n)
|
||||
(bits u8a u8b u8n)
|
||||
(bits u16a u16b u16n)
|
||||
(bits u32a u32b u32n)
|
||||
(bits u64a u64b u64n)
|
||||
(println (leading-zeros z8) (trailing-zeros z8)
|
||||
(leading-zeros z16) (trailing-zeros z16)
|
||||
(leading-zeros z32) (trailing-zeros z32)
|
||||
(leading-zeros z64) (trailing-zeros z64) (popcount z64))
|
||||
(println (rotate-left i32b big32) (rotate-right i32b big32)
|
||||
(rotate-left i32b neg32) (rotate-left u8a big8)
|
||||
(rotate-right u8a big8))
|
||||
;; A narrower count widens to the value's type.
|
||||
(println (<< i64b u8n) (rotate-left u64b u8n))
|
||||
0)
|
||||
138
test/programs/dyn-into-typed.flan
Normal file
138
test/programs/dyn-into-typed.flan
Normal file
@ -0,0 +1,138 @@
|
||||
;;;; A dyn value where typed code wrote a str, a slice, a fixed array or a
|
||||
;;;; struct. Mode 0 is the survey; the others are one trap each, since a trap
|
||||
;;;; ends the process. test_acceptance.ml runs it on both backends and under
|
||||
;;;; --dev, where mode 8 (a view of a returned call's local) traps as well.
|
||||
|
||||
(declare gc-collect [] () "flan_gc_collect")
|
||||
(declare gc-count [] i64 "flan_gc_count")
|
||||
|
||||
(defstruct Point [x f64 y i32])
|
||||
(defstruct Named [name str id u32])
|
||||
(defclass pt [x y])
|
||||
|
||||
;; Unannotated parameters and returns are dyn.
|
||||
(defn keep [d] dyn d)
|
||||
(defn text-of [d] dyn (slice d 0 5))
|
||||
|
||||
(defn shout [s str] () (println s))
|
||||
(defn keep-str [s str] str s)
|
||||
;; The text crosses in this frame, whose dyn slots are gone once it returns.
|
||||
(defn fetch [] str (keep-str (text-of (keep "pinned text"))))
|
||||
(defn sum [xs [const i64]] i64
|
||||
(let [t (i64 0)]
|
||||
(dotimes [i (length xs)] (set t (+ t (at xs i))))
|
||||
t))
|
||||
(defn bump [xs [i64]] ()
|
||||
(dotimes [i (length xs)] (set (at xs i) (+ (at xs i) 100))))
|
||||
(defn sumf [xs [const f64]] f64
|
||||
(let [t 0.0]
|
||||
(dotimes [i (length xs)] (set t (+ t (at xs i))))
|
||||
t))
|
||||
(defn bytes-sum [xs [const u8]] i64
|
||||
(let [t (i64 0)]
|
||||
(dotimes [i (length xs)] (set t (+ t (i64 (at xs i)))))
|
||||
t))
|
||||
(defn names [xs [const str]] ()
|
||||
(dotimes [i (length xs)] (println (at xs i))))
|
||||
(defn words [xs [const [const u8]]] i64 (length (at xs 1)))
|
||||
(defn triple [a [3 i64]] i64 (+ (at a 0) (at a 2)))
|
||||
(defn grid [g [2 [2 i32]]] i32 (at g 1 0))
|
||||
(defn px [p Point] f64 (+ (.x p) (f64 (.y p))))
|
||||
(defn named [n Named] () (println (.name n) (.id n)))
|
||||
(defn f64s [xs [f64]] () (println (length xs)))
|
||||
(defn raw [xs [u8]] () (println (length xs)))
|
||||
|
||||
(declare pin-count [] i64 "flan_dyn_pin_count")
|
||||
(defn slen [s str] i64 (length s))
|
||||
(defn f32s [xs [const f32]] () (println (length xs)))
|
||||
(defclass pq [x])
|
||||
|
||||
;; A str kept in a global past free-temp: a dev build's copy is poisoned.
|
||||
(defonce kept str "")
|
||||
(defn stash-str [] () (set kept (keep-str (keep "kept text"))))
|
||||
|
||||
;; A view of a local, kept past the call that owns the local.
|
||||
(defonce held dyn nil)
|
||||
(defn leak-local [] ()
|
||||
(let [a [(i64 1) 2 3]]
|
||||
(set held (keep a))))
|
||||
|
||||
(defn main [args [str]] i32
|
||||
(let [n (i32 (bytes->i64 (bytes-view (at args 1))))]
|
||||
(cond
|
||||
(= n 0)
|
||||
(do
|
||||
;; A text becomes a str.
|
||||
(shout (keep "hello"))
|
||||
(println (length (keep-str (keep "four"))))
|
||||
;; A str kept past its crossing, the text reachable only through
|
||||
;; the pin, while collections run and the heap is refilled.
|
||||
(let [s (fetch)]
|
||||
(gc-collect)
|
||||
(dotimes [i 20000] (text-of (keep "XXXXXXXXXX")))
|
||||
(gc-collect)
|
||||
(dotimes [i 20000] (text-of (keep "XXXXXXXXXX")))
|
||||
(println s))
|
||||
;; A pin ends at free-temp: a thousand crossed texts are collected.
|
||||
(free-temp)
|
||||
(gc-collect)
|
||||
(let [before (gc-count)]
|
||||
(dotimes [i 1000] (keep-str (text-of (keep "abcdefgh"))))
|
||||
(free-temp)
|
||||
(gc-collect)
|
||||
(println (< (- (gc-count) before) 100)))
|
||||
;; The same texts crossing again and again are pinned once each.
|
||||
(let [t1 (keep "one") t2 (keep "two") n (i64 0)]
|
||||
(dotimes [i 100000] (set n (+ n (slen t1) (slen t2))))
|
||||
(println n (< (pin-count) 10)))
|
||||
;; A view of typed storage comes back as that storage.
|
||||
(let [a [(i64 1) 2 3]]
|
||||
(bump (keep a))
|
||||
(println a)
|
||||
(println (sum (keep a))))
|
||||
(let [v (vec-new i64)]
|
||||
(push v 5) (push v 6)
|
||||
(bump (keep v))
|
||||
(println (at v 0) (at v 1))
|
||||
(free v))
|
||||
;; A plain dyn vec is a checked copy for a [const T].
|
||||
(println (sum (the dyn [1 2 3 4])))
|
||||
(println (sumf (the dyn [1 2.5])))
|
||||
(println (bytes-sum (the dyn [1 2 255])))
|
||||
(println (bytes-sum (keep "AB")))
|
||||
(names (the dyn ["ada" "bo"]))
|
||||
(println (words (the dyn ["x" "yyy"])))
|
||||
;; A view of other elements too.
|
||||
(let [b [(i32 7) 8]]
|
||||
(println (sum (keep b))))
|
||||
;; A fixed array and a struct are values: a copy either way.
|
||||
(println (triple (the dyn [10 20 30])))
|
||||
(let [a [(i64 4) 5 6]] (println (triple (keep a))))
|
||||
(println (grid (the dyn [[1 2] [3 4]])))
|
||||
(println (px (the dyn {:x 1.5 :y 2})))
|
||||
(println (px (pt 2.5 3)))
|
||||
(let [p (Point {.x 0.25 .y 4})] (println (px (keep p))))
|
||||
(named (the dyn {:name "cy" :id 9}))
|
||||
0)
|
||||
(= n 1) (do (println (sum (the dyn [1 "a" 3]))) 0)
|
||||
(= n 2) (do (bump (the dyn [1 2])) 0)
|
||||
(= n 3) (do (println (sum (keep "abc"))) 0)
|
||||
(= n 4) (do (println (bytes-sum (the dyn [1 300]))) 0)
|
||||
(= n 5) (do (println (triple (the dyn [1 2]))) 0)
|
||||
(= n 6) (do (println (px (the dyn {:x 1.5}))) 0)
|
||||
(= n 7) (do (shout (keep 5)) 0)
|
||||
(= n 8) (do (leak-local) (bump held) 0)
|
||||
(= n 9) (do (raw (keep "abc")) 0)
|
||||
(= n 10) (let [a [(f32 1) 2]] (f64s (keep a)) 0)
|
||||
(= n 11) (do (println (px (the dyn {:x 1.5 :y "no"}))) 0)
|
||||
(= n 12) (do (f32s (the dyn [1.5 1e300])) 0)
|
||||
(= n 13) (do (println (px (pq 1.5))) 0)
|
||||
(= n 14) (do (println (px (the dyn {:x 1.5 :y 2 :z 3}))) 0)
|
||||
(= n 15)
|
||||
(do (stash-str)
|
||||
(free-temp)
|
||||
(gc-collect)
|
||||
(dotimes [i 1000] (text-of (keep "XXXXXXXXXX")))
|
||||
(println (at kept 0))
|
||||
0)
|
||||
:else 1)))
|
||||
82
test/programs/literal-locals.flan
Normal file
82
test/programs/literal-locals.flan
Normal file
@ -0,0 +1,82 @@
|
||||
;;;; A number literal bound by let or loop takes its type from its uses in
|
||||
;;;; the function. Each line's expected output is beside it.
|
||||
|
||||
;; A set of an i64 sum makes the accumulator an i64.
|
||||
(defn total [xs [i64]] i64
|
||||
(let [t 0]
|
||||
(dotimes [i (length xs)]
|
||||
(set t (+ t (at xs i))))
|
||||
t))
|
||||
|
||||
;; The operand beside it: an f64 accumulator from a float literal.
|
||||
(defn mean [xs [f64]] f64
|
||||
(let [s 0.0]
|
||||
(dotimes [i (length xs)]
|
||||
(set s (+ s (at xs i))))
|
||||
(/ s (f64 (length xs)))))
|
||||
|
||||
;; A counter compared with an i64 bound counts past i32.
|
||||
(defn count-to [n i64] i64
|
||||
(let [i 0]
|
||||
(while (< i n)
|
||||
(set i (+ i 1000000000)))
|
||||
i))
|
||||
|
||||
;; A set of one literal local into another links them: b holds a value past
|
||||
;; i32, so a is an i64 too.
|
||||
(defn linked [] i64
|
||||
(let [a 0 b 0]
|
||||
(set b 3000000000)
|
||||
(set a b)
|
||||
a))
|
||||
|
||||
;; Two locals fed from each other: i is counted against an i64, and acc
|
||||
;; sums a literal past i32.
|
||||
(defn sum-to [n i64] i64
|
||||
(let [i 0 acc 0]
|
||||
(while (< i n)
|
||||
(set acc (+ acc 1000000000))
|
||||
(set i (+ i 1)))
|
||||
acc))
|
||||
|
||||
;; Inside a generic body the literal takes the type variable.
|
||||
(defn sum-of [xs [$t]] $t {:where (numeric? $t)}
|
||||
(let [acc 0]
|
||||
(dotimes [i (length xs)]
|
||||
(set acc (+ acc (at xs i))))
|
||||
acc))
|
||||
|
||||
;; A chain of sets settles however long it is.
|
||||
(defn chained [x i64] i64
|
||||
(let [a0 0 a1 0 a2 0 a3 0 a4 0 a5 0]
|
||||
(set a0 x) (set a1 (+ a0 1)) (set a2 (+ a1 1)) (set a3 (+ a2 1))
|
||||
(set a4 (+ a3 1)) (set a5 (+ a4 1))
|
||||
a5))
|
||||
|
||||
;; A dyn number is an i64 or an f64, and so is a literal local it feeds.
|
||||
(defn boxed [x] dyn x)
|
||||
(defn from-dyn [] ()
|
||||
(let [d (boxed 0.1) s 0.0 n 0]
|
||||
(set s (+ s d))
|
||||
(set n (+ n (boxed 5000000000)))
|
||||
(println s n)))
|
||||
|
||||
(defn main [] i32
|
||||
(let [xs (the [3 i64] [3000000000 4 5])
|
||||
fs (the [2 f64] [0.5 0.25])
|
||||
gs (the [2 u8] [200 50])]
|
||||
(println (total (slice xs 0 3))) ; 3000000009
|
||||
(println (mean (slice fs 0 2))) ; 0.375
|
||||
(println (count-to 5000000000)) ; 5000000000
|
||||
(println (linked)) ; 3000000000
|
||||
(println (sum-to 3)) ; 3000000000
|
||||
(println (sum-of (slice xs 0 3))) ; 3000000009
|
||||
(println (sum-of (slice fs 0 2)))) ; 0.75
|
||||
(println (chained 3000000000)) ; 3000000005
|
||||
(from-dyn) ; 0.1 5000000000
|
||||
(let [x 0.1]
|
||||
(println (= (boxed x) (boxed 0.1)))) ; true
|
||||
;; Nothing says otherwise: an i32 and an f64.
|
||||
(let [n 7 f 1.5]
|
||||
(println n f)) ; 7 1.5
|
||||
0)
|
||||
@ -101,6 +101,15 @@
|
||||
(handler-bind [(AssetMissing [c] (invoke-restart 'use-value 21))]
|
||||
(shadowed n)))
|
||||
|
||||
;;; A number of another type: the refusal writes the conversion.
|
||||
(defn widened [n i32] i32
|
||||
(handler-bind [(AssetMissing [c] (let [big (i64 7)] (invoke-restart 'use-value big)))]
|
||||
(supplied n)))
|
||||
|
||||
(defn doubled [n i32] i32
|
||||
(handler-bind [(AssetMissing [c] (let [big (i64 7)] (invoke-restart 'use-value (* big 2))))]
|
||||
(supplied n)))
|
||||
|
||||
(defn main [args [str]] i32
|
||||
;; One argument selects a trap; none runs the table's case.
|
||||
(if (> (length args) 1)
|
||||
@ -110,6 +119,8 @@
|
||||
(= k 2) (print (mistyped 91))
|
||||
(= k 3) (print (overfull 92))
|
||||
(= k 4) (print (mislaid 93))
|
||||
(= k 5) (print (widened 94))
|
||||
(= k 6) (print (doubled 95))
|
||||
:else (println "?"))
|
||||
(return 0)))
|
||||
|
||||
|
||||
16
test/syntax/chain/macro.fln
Normal file
16
test/syntax/chain/macro.fln
Normal file
@ -0,0 +1,16 @@
|
||||
;;;; A chain in a macro's template, converted to parens: the names it binds
|
||||
;;;; must not capture the caller's, which here are the ones the converter
|
||||
;;;; would otherwise pick.
|
||||
|
||||
defmacro(between, [lo x hi]):
|
||||
quote
|
||||
~lo <= ~x < ~hi
|
||||
|
||||
fn main() -> i32
|
||||
let mid = 1
|
||||
let mid2 = 2
|
||||
let mid3 = 3
|
||||
println(between(mid, 5, mid))
|
||||
println(between(0, mid2, mid3))
|
||||
println(between(mid3, mid2, mid))
|
||||
0
|
||||
76
test/syntax/handwritten/chain-mixed.fln
Normal file
76
test/syntax/handwritten/chain-mixed.fln
Normal file
@ -0,0 +1,76 @@
|
||||
;;;; A comparison chain that mixes < with <=, or > with >=, is the and of its
|
||||
;;;; neighbouring tests, evaluated as a < b < c is. Every operand below comes
|
||||
;;;; through mark, which prints its tag, so each tag line is a transcript:
|
||||
;;;; each operand runs exactly once, in source order, even after a false test.
|
||||
|
||||
once calls = 0
|
||||
|
||||
fn mark(tag: str, v: i32) -> i32
|
||||
calls += 1
|
||||
print(tag)
|
||||
v
|
||||
|
||||
fn line(b: bool) -> ()
|
||||
print(" -> ")
|
||||
println(b)
|
||||
|
||||
; A name is read where it stands, before a call to its right changes it.
|
||||
once level = 0
|
||||
|
||||
fn raise() -> i32
|
||||
level = 10
|
||||
5
|
||||
|
||||
fn dyn-mark(tag, v)
|
||||
print(tag)
|
||||
v
|
||||
|
||||
fn in-grid(r: i32, rows: i32) -> bool = 0 <= r < rows
|
||||
|
||||
fn dyn-between(lo, x, hi) = lo <= x < hi
|
||||
|
||||
fn main() -> i32
|
||||
print(in-grid(0, 3))
|
||||
print(" ")
|
||||
print(in-grid(2, 3))
|
||||
print(" ")
|
||||
print(in-grid(3, 3))
|
||||
print(" ")
|
||||
print(in-grid(-1, 3))
|
||||
println("")
|
||||
let a = 1
|
||||
let b = 2
|
||||
let c = 2
|
||||
let d = 5
|
||||
print(a < b <= c < d)
|
||||
print(" ")
|
||||
print(a < b <= c < 2)
|
||||
print(" ")
|
||||
print(d >= c > 1)
|
||||
print(" ")
|
||||
print(d >= c > 2)
|
||||
println("")
|
||||
|
||||
; A middle operand that is a call runs once although two tests name it.
|
||||
line(mark("a", 1) < mark("b", 2) <= mark("c", 2))
|
||||
line(mark("a", 1) < mark("b", 2) <= mark("c", 1))
|
||||
; The first test is false, and every operand still runs.
|
||||
line(mark("a", 3) < mark("b", 2) <= mark("c", 5))
|
||||
line(mark("a", 1) <= mark("b", 2) < mark("c", 3) <= mark("d", 3))
|
||||
line(mark("a", 9) >= mark("b", 5) > mark("c", 7) >= mark("d", 0))
|
||||
println(calls)
|
||||
|
||||
; The same over dyn operands.
|
||||
print(dyn-between(0, 0, 3))
|
||||
print(" ")
|
||||
print(dyn-between(0, 3, 3))
|
||||
print(" ")
|
||||
print(dyn-between(1.5, 2, 2.5))
|
||||
println("")
|
||||
line(dyn-mark("p", 1) < dyn-mark("q", 2) <= dyn-mark("r", 2))
|
||||
line(dyn-mark("p", 5) < dyn-mark("q", 2) <= dyn-mark("r", 9))
|
||||
print(level < raise() <= 7)
|
||||
level = 0
|
||||
print(" ")
|
||||
println(<(level, raise(), 7))
|
||||
0
|
||||
12
test/syntax/handwritten/chain-mixed.out
Normal file
12
test/syntax/handwritten/chain-mixed.out
Normal file
@ -0,0 +1,12 @@
|
||||
true true false false
|
||||
true false true false
|
||||
abc -> true
|
||||
abc -> false
|
||||
abc -> false
|
||||
abcd -> true
|
||||
abcd -> false
|
||||
17
|
||||
true false true
|
||||
pqr -> true
|
||||
pqr -> false
|
||||
true true
|
||||
@ -389,6 +389,14 @@ let () =
|
||||
outputs "value semantics" "programs/values.flan" values_out;
|
||||
outputs "machine surface" "programs/machine.flan" machine_out;
|
||||
outputs "unit main exits 0" "programs/unit-main.flan" "ok\n";
|
||||
let literal_locals_out =
|
||||
"3000000009\n0.375\n5000000000\n3000000000\n3000000000\n3000000009\n\
|
||||
0.75\n3000000005\n0.1 5000000000\ntrue\n7 1.5\n"
|
||||
in
|
||||
outputs "literal locals take their uses' type" "programs/literal-locals.flan"
|
||||
literal_locals_out;
|
||||
outputs ~x86:true "literal locals take their uses' type, --x86"
|
||||
"programs/literal-locals.flan" literal_locals_out;
|
||||
(* Comparisons over three operands and more. The lines that carry the
|
||||
whole claim are the tag transcripts: [abc -> false] is a chain whose
|
||||
*first* link already decided the answer and whose middle operand —
|
||||
@ -669,6 +677,81 @@ let () =
|
||||
outputs "unary minus" "programs/negate.flan" neg_out;
|
||||
outputs ~opt:"-O0" "unary minus, -O0" "programs/negate.flan" neg_out;
|
||||
outputs ~x86:true "unary minus, x86" "programs/negate.flan" neg_out;
|
||||
(* The bit operators at every width, and on dyn ints beside typed i64:
|
||||
both backends and both optimisation levels print the same numbers. *)
|
||||
let bits_out =
|
||||
"12 -67 -79 99 0 12 -67 -79\n\
|
||||
-32 -13 -28 -109\n\
|
||||
4 0 2 4 2 0\n\
|
||||
16 -17671 -17687 29999 0 16 -17671 -17687\n\
|
||||
23040 -938 23057 -31658\n\
|
||||
6 0 4 6 2 0\n\
|
||||
4869120 -1881412331 -1886281451 1999999999 0 4869120 -1881412331 -1886281451\n\
|
||||
1698037760 -15625000 1698037828 17929432\n\
|
||||
10 0 10 16 5 0\n\
|
||||
1164229214208 -8999999929661324085 -9000001093890538293 8999999999999999999 0 1164229214208 -8999999929661324085 -9000001093890538293\n\
|
||||
3636062617077809152 -1098632812500000 3636062617077813347 1153167001185248\n\
|
||||
25 0 18 23 23 0\n\
|
||||
8 237 229 55 0 8 237 229\n\
|
||||
64 25 70 25\n\
|
||||
3 0 3 4 2 0\n\
|
||||
8224 64121 55897 5535 0 8224 64121 55897\n\
|
||||
19456 1875 19485 1875\n\
|
||||
7 0 5 6 2 0\n\
|
||||
105580544 4017876245 3912295701 294967295 0 105580544 4017876245 3912295701\n\
|
||||
898891776 31250000 898891895 31250000\n\
|
||||
13 0 11 16 5 0\n\
|
||||
5386010624 18000001229181879499 18000001223795868875 446744073709551615 0 5386010624 18000001229181879499 18000001223795868875\n\
|
||||
11174618839553933312 2197265625000000 11174618839553941305 2197265625000000\n\
|
||||
22 0 19 23 23 0\n\
|
||||
8 8 16 16 32 32 64 64 0\n\
|
||||
987654312 -1595180638 -2085755254 70 25\n\
|
||||
9876543120984 9876543120984\n\
|
||||
" in
|
||||
outputs "bit operators" "programs/bits.flan" bits_out;
|
||||
outputs ~opt:"-O0" "bit operators, -O0" "programs/bits.flan" bits_out;
|
||||
outputs ~x86:true "bit operators, x86" "programs/bits.flan" bits_out;
|
||||
let bits_dyn_out =
|
||||
"0 0 0 -1 0 0 0 0 0 64 64 0 0 0 \n\
|
||||
12345 -1 -12346 0 -9223372036854775808 -1 -1 -1 64 0 0 -12295 12345 -1 \n\
|
||||
1164229214208 -8999999929661324085 -9000001093890538293 8999999999999999999 3636062617077809152 -1098632812500000 3636062617077813347 1153167001185248 25 0 18 -9000001093890538298 1164229214208 -8999999929661324085 \n\
|
||||
1 -1 -2 -9223372036854775808 -2 4611686018427387903 -2 -4611686018427387905 63 1 0 -1 1 -1 \n\
|
||||
0 -1 -1 -281474976710657 0 2 2147483648 2 1 15 48 -48 0 -1 \n\
|
||||
1 3 2 -2 4611686018427387904 0 4611686018427387904 4 1 63 0 60 1 3 \n\
|
||||
52 255\n\
|
||||
32 32 32\n\
|
||||
" in
|
||||
outputs "dyn bit operators" "programs/bits-dyn.flan" bits_dyn_out;
|
||||
outputs ~opt:"-O0" "dyn bit operators, -O0" "programs/bits-dyn.flan"
|
||||
bits_dyn_out;
|
||||
outputs ~x86:true "dyn bit operators, x86" "programs/bits-dyn.flan"
|
||||
bits_dyn_out;
|
||||
(* A dyn bit operation traps at its own site: a shift count out of range
|
||||
either way, a bool, a float. *)
|
||||
let bits_traps ?opt ?x86 () =
|
||||
let exe = compile ?opt ?x86 "programs/bits-dyn.flan" in
|
||||
let traps arg reason =
|
||||
let code, text = run exe (Some arg) in
|
||||
if code <> 134 || not (contains text "before\n")
|
||||
|| not (contains text "programs/bits-dyn.flan:")
|
||||
|| not (contains text reason)
|
||||
then begin
|
||||
incr failures;
|
||||
Printf.printf
|
||||
"FAIL dyn bit trap %s\n got: %S (exit %d)\n wanted: %S (exit 134)\n"
|
||||
arg text code reason
|
||||
end
|
||||
in
|
||||
traps "1" "dyn <<: int and int, and the count is outside 0 to 63";
|
||||
traps "2" "dyn bit-and: bool and int, and it takes integers; true and \
|
||||
false are combined with and, or and not";
|
||||
traps "3" "dyn bit-and: float and int, and it takes integers —";
|
||||
traps "4" "dyn >>: int and int, and the count is outside 0 to 63";
|
||||
(try Sys.remove exe with Sys_error _ -> ())
|
||||
in
|
||||
bits_traps ();
|
||||
bits_traps ~opt:"-O0" ();
|
||||
bits_traps ~x86:true ();
|
||||
(* A literal arm takes the other arm's type. *)
|
||||
let arm_out =
|
||||
"4000000\n9000000000\n5000000000\n7\n9000000000\n3\n9000000000\n2.5\n" in
|
||||
@ -1392,6 +1475,10 @@ let () =
|
||||
have taken them is not consulted. *)
|
||||
refuses "a shadowing clause of the same name and a different signature" "4"
|
||||
"restart use-value takes (str), given (i32)";
|
||||
refuses "a number of another type is refused with its conversion" "5"
|
||||
"restart use-value takes (i32), given (i64). Write (i32 big)";
|
||||
refuses "and the argument as it was written when it is an expression" "6"
|
||||
"restart use-value takes (i32), given (i64). Write (i32 (* big 2))";
|
||||
(try Sys.remove exe with Sys_error _ -> ())
|
||||
in
|
||||
restart_mismatch ();
|
||||
@ -6143,6 +6230,83 @@ level "1"
|
||||
dyn_view_any ~dev:true ();
|
||||
dyn_view_any ~dev:true ~x86:true ();
|
||||
|
||||
(* ── A dyn value into a written type ───────────────────────────────
|
||||
programs/dyn-into-typed.flan: a text into a str, kept past the frame
|
||||
it crossed in while collections run; a view back into its own
|
||||
storage, written through; a dyn vec, map or instance copied into a
|
||||
[const T], a fixed array or a struct (mode 0); then one trap per mode,
|
||||
each naming the element and what it holds. Mode 8, a view of a
|
||||
returned call's local, traps under --dev only. *)
|
||||
let into_out =
|
||||
"hello\n4\npinne\ntrue\n600000 true\n[101 102 103]\n306\n105 106\n10\n3.5\n258\n\
|
||||
131\nada\nbo\n3\n15\n40\n10\n3\n3.5\n5.5\n4.25\ncy 9\n"
|
||||
and into_traps =
|
||||
[ ("1", "dyn-into-typed.flan:117:33: dyn into [const i64]: element 1 \
|
||||
is a text, \"a\", and an i64 is wanted there");
|
||||
("2", "dyn into [i64]: this vec is a dyn vec, so a [i64] of it would \
|
||||
be a copy, and a write through the copy would never reach the \
|
||||
vec. Take it as [const i64], which reads a copy");
|
||||
("3", "this is a text, \"abc\", and only a vec becomes a [const i64]");
|
||||
("4", "element 1 is 300, and a u8 holds 0 to 255");
|
||||
("5", "this vec has 2 elements, and a [3 i64] holds exactly 3");
|
||||
("6", "dyn into Point: this map has no :y, and a Point needs every \
|
||||
field");
|
||||
("7", "dyn into str: this is an int, 5, and only a text becomes a str");
|
||||
("9", "a text is read-only, so it becomes a str or a [const u8] and \
|
||||
never a [u8]");
|
||||
("10", "this vec is a view of f32 elements");
|
||||
("11", "field :y is a text, \"no\", and an i32 is wanted there");
|
||||
("12", "element 1 is 1e+300, and an f32 holds -3.4028235e38 to \
|
||||
3.4028235e38");
|
||||
("13", "dyn into Point: this pq has no :y, and a Point needs every \
|
||||
field");
|
||||
("14", "dyn into Point: this map has :z, and a Point has no field \
|
||||
:z. Its fields are :x :y") ]
|
||||
and into_stale =
|
||||
[ ("8", "dyn into [i64]: this view points into a local of leak-local, \
|
||||
and that call has returned") ]
|
||||
in
|
||||
let dyn_into ?opt ?(x86 = false) ?(dev = false) () =
|
||||
let exe = compile ?opt ~x86 ~dev "programs/dyn-into-typed.flan" in
|
||||
let name what =
|
||||
"dyn: into a written type" ^ what
|
||||
^ (match opt with Some o -> ", " ^ o | None -> "")
|
||||
^ (if x86 then ", --x86" else "") ^ (if dev then ", --dev" else "")
|
||||
in
|
||||
let code, text = run exe (Some "0") in
|
||||
if code <> 0 || text <> into_out then begin
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n got: %S (exit %d)\n wanted: %S\n"
|
||||
(name "") text code into_out
|
||||
end;
|
||||
List.iter
|
||||
(fun (mode, needle) ->
|
||||
let code, text = run exe (Some mode) in
|
||||
if code <> 134 || not (contains text needle) then begin
|
||||
incr failures;
|
||||
Printf.printf
|
||||
"FAIL %s\n got: %S (exit %d)\n wanted a trap \
|
||||
saying %S\n" (name (", mode " ^ mode)) text code needle
|
||||
end)
|
||||
(into_traps @ if dev then into_stale else []);
|
||||
(* A str from a text kept in a global past free-temp: a dev build's
|
||||
copy reads the arena's poison (0xEF), never another text's bytes. *)
|
||||
if dev then begin
|
||||
let code, text = run exe (Some "15") in
|
||||
if code <> 0 || text <> "239\n" then begin
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n got: %S (exit %d)\n wanted: %S\n"
|
||||
(name ", a str kept past free-temp") text code "239\n"
|
||||
end
|
||||
end;
|
||||
(try Sys.remove exe with Sys_error _ -> ())
|
||||
in
|
||||
dyn_into ();
|
||||
dyn_into ~opt:"-O0" ();
|
||||
dyn_into ~x86:true ();
|
||||
dyn_into ~dev:true ();
|
||||
dyn_into ~dev:true ~x86:true ();
|
||||
|
||||
(* The root count, which is the part of this feature the runs above cannot
|
||||
check — and the reason has outlived the stub it was first written
|
||||
about. flan_dyn.c's trigger has a one-megabyte floor, and not one
|
||||
|
||||
@ -1090,6 +1090,53 @@ let () =
|
||||
two [infers] above still hold — and this is the position that had no way
|
||||
to say it. *)
|
||||
infers "array constructor" "(array 4 f32)" "[4 f32]";
|
||||
(* A literal bound by a let takes its type from its uses in the function,
|
||||
and two uses no one type satisfies are refused with the annotation. *)
|
||||
accepts "a literal local takes the type set into it"
|
||||
"(defn f [x i64] i64 (let [t 0] (set t (+ t x)) t))";
|
||||
accepts "a literal local takes an operand's type"
|
||||
"(defn f [x f64] f64 (let [s 0.0] (set s (+ s x)) s))";
|
||||
accepts "recur rebinds a literal local at the type it brings"
|
||||
"(defn f [n i64] i64 (loop [i 0 acc 0] (if (< i n) (recur (+ i 1) (+ acc n)) acc)))";
|
||||
accepts "a set links two literal locals"
|
||||
"(defn f [] i64 (let [a 0 b 0] (set b 3000000000) (set a b) a))";
|
||||
accepts "a float literal local takes the f32 typed code wants"
|
||||
"(defn f [x f32] f32 (let [s 0.0] (set s (+ s x)) s))";
|
||||
rejects_check "a literal past f32's range where f32 is wanted"
|
||||
~needle:"1e+39 does not fit in f32, whose largest value is about 3.4e38"
|
||||
"(defn f [] f32 1e39)";
|
||||
rejects_check "a literal f32 rounds to 0 where f32 is wanted"
|
||||
~needle:"1e-50 is too small for f32, which rounds it to 0"
|
||||
"(defn f [] f32 1e-50)";
|
||||
infers "a literal past f32's range is an f64 like any other" "(+ 1.0 1e300)" "f64";
|
||||
(* Chains through a second round, and through do, let and if arms that
|
||||
merge without one. *)
|
||||
accepts "a literal local fed through do, however long the chain"
|
||||
"(defn f [x i64] i64 (let [a0 0 a1 0 a2 0 a3 0 a4 0 a5 0 a6 0 a7 0 a8 0 a9 0 a10 0 \
|
||||
a11 0 a12 0] (set a0 x) (set a1 (do a0)) (set a2 (do a1)) (set a3 (do a2)) \
|
||||
(set a4 (do a3)) (set a5 (do a4)) (set a6 (do a5)) (set a7 (do a6)) \
|
||||
(set a8 (do a7)) (set a9 (do a8)) (set a10 (do a9)) (set a11 (do a10)) \
|
||||
(set a12 (do a11)) a12))";
|
||||
accepts "a literal local fed through a let"
|
||||
"(defn f [x i64] i64 (let [a0 0 a1 0 a2 0] (set a0 x) (set a1 (let [t a0] t)) \
|
||||
(set a2 (let [t a1] t)) a2))";
|
||||
accepts "a literal local fed through both arms of an if"
|
||||
"(defn f [x i64] i64 (let [a0 0 a1 0] (set a0 x) (set a1 (if true a0 a0)) a1))";
|
||||
accepts "a literal local fed through a generic call settles in rounds"
|
||||
"(defn same [x $t] $t x) (defn f [x i64] i64 (let [a0 0 a1 0 a2 0] (set a0 x) \
|
||||
(set a1 (same a0)) (set a2 (same a1)) a2))";
|
||||
rejects_check "a chain the rounds cannot follow names the local to annotate"
|
||||
~needle:"the type of a7 depends on too long a chain of the values stored into \
|
||||
it to be read off them. Write the type it should have: (i64 0)"
|
||||
"(defn same [x $t] $t x) (defn f [x i64] i64 (let [a0 0 a1 0 a2 0 a3 0 a4 0 a5 0 \
|
||||
a6 0 a7 0 a8 0 a9 0 a10 0] (set a0 x) (set a1 (same a0)) (set a2 (same a1)) \
|
||||
(set a3 (same a2)) (set a4 (same a3)) (set a5 (same a4)) (set a6 (same a5)) \
|
||||
(set a7 (same a6)) (set a8 (same a7)) (set a9 (same a8)) (set a10 (same a9)) a10))";
|
||||
rejects_check "two uses of a literal local disagree"
|
||||
~needle:"x is used as u32 and as i32, and 0 can have only one type. \
|
||||
Write the one it should have: (u32 0)"
|
||||
"(defn u [x u32] u32 x) (defn i [x i32] i32 x) \
|
||||
(defn f [] i32 (let [x 0] (u x) (i x)) 0)";
|
||||
infers "array of a struct" "(array 2 i32)" "[2 i32]";
|
||||
infers "array of an array" "(array 2 [3 u8])" "[2 [3 u8]]";
|
||||
(* (array-fill [r c] v): the same type at any rank, with the element type
|
||||
@ -1379,6 +1426,91 @@ let () =
|
||||
~needle:"bit-or takes two arguments or more, given 0";
|
||||
rejects_check "one operand is not a min"
|
||||
"(defn f [] i32 (min 7))" ~needle:"min takes two arguments or more, given 1";
|
||||
(* The bit operators take integers, and a bool is answered with the logical
|
||||
operator a C programmer meant. *)
|
||||
infers "bit-not keeps its operand's type" "(bit-not (u16 5))" "u16";
|
||||
infers "popcount keeps its operand's type" "(popcount (i64 5))" "i64";
|
||||
infers "a rotation takes the value's type" "(rotate-left (u8 5) (u8 1))" "u8";
|
||||
infers "&& is bit-and" "(&& 6 3)" "i32";
|
||||
infers "a bit operation with a dyn operand is dyn"
|
||||
"(bit-and (the dyn 6) (i32 3))" "dyn";
|
||||
infers "a shift with a dyn operand is dyn" "(<< (the dyn 1) 3)" "dyn";
|
||||
(* Through the whole-file check [flan check] and the editor run, which
|
||||
records a refusal and goes on rather than raising at the first: a hint
|
||||
that only a raised refusal could give would be lost there. [.fln] text is
|
||||
checked from a file, since the operator's spelling follows the syntax. *)
|
||||
let refuses_all name ?(fln = false) src needle =
|
||||
let diags =
|
||||
match
|
||||
if fln then begin
|
||||
let path = Test_support.tmp "bits-" (string_of_int (Hashtbl.hash name) ^ ".fln") in
|
||||
Out_channel.with_open_bin path (fun oc -> output_string oc src);
|
||||
let r = snd (Front.checked ~all:true path) in
|
||||
Sys.remove path; r
|
||||
end
|
||||
else Check.program_all (Parse.program_all (read src))
|
||||
with
|
||||
| _ -> []
|
||||
| exception Loc.Errors ds -> List.map (fun (d : Loc.diag) -> d.Loc.dmsg) ds
|
||||
| exception Loc.Error d -> [ d.Loc.dmsg ]
|
||||
in
|
||||
if not (List.exists (fun m -> contains m needle) diags) then begin
|
||||
incr failures;
|
||||
Printf.printf "FAIL %s\n wanted: %s\n got: %s\n" name needle
|
||||
(String.concat " | " diags)
|
||||
end
|
||||
in
|
||||
refuses_all "bit-and over bools points at and"
|
||||
"(defn f [a bool b bool] bool (= (bit-and a b) 0))"
|
||||
"bit-and works on the bits of an integer, and this is a bool. \
|
||||
For true and false, write (and a b)";
|
||||
refuses_all "bit-not over a bool points at not"
|
||||
"(defn f [a bool] i32 (bit-not a) 0)" "write (not a)";
|
||||
refuses_all "bit-xor over bools points at !="
|
||||
"(defn f [a bool b bool] i32 (bit-xor a b) 0)" "write (!= a b)";
|
||||
refuses_all "a typed bool beside a dyn is refused before it runs"
|
||||
"(defn f [a bool d dyn] dyn (bit-or a d))" "write (or a b)";
|
||||
refuses_all "a shift of a bool"
|
||||
"(defn f [a bool] i32 (<< a 1) 0)" "combined with and, or and not";
|
||||
refuses_all "a bool shift count" "(defn f [flag bool] i32 (<< 1 flag))"
|
||||
"combined with and, or and not";
|
||||
refuses_all "a bool beside an integer, an integer wanted"
|
||||
"(defn f [flag bool x i32] i32 (bit-and flag x))" "write (and a b)";
|
||||
refuses_all "a bool beside a literal, an integer wanted"
|
||||
"(defn f [flag bool] i32 (bit-or flag 1))" "write (or a b)";
|
||||
refuses_all "a literal beside a bool" "(defn f [flag bool] i32 (bit-or 1 flag))"
|
||||
"write (or a b)";
|
||||
refuses_all "a bool third" "(defn f [x i32 flag bool] i32 (bit-and x x flag))"
|
||||
"write (and a b)";
|
||||
refuses_all "a comparison as an operand"
|
||||
"(defn f [x i32 y i32] i32 (bit-and x (= x y)))" "write (and a b)";
|
||||
refuses_all "a bool field" "(defstruct S [on bool]) (defn f [s S] i32 (bit-or 1 (.on s)))"
|
||||
"write (or a b)";
|
||||
refuses_all "a call that answers a bool"
|
||||
"(defn p? [x i32] bool (> x 0)) (defn f [x i32] i32 (bit-and x (p? x)))"
|
||||
"write (and a b)";
|
||||
refuses_all "an if whose type is bool"
|
||||
"(defn f [x i32 c bool] i32 (bit-or 1 (if c true false)))" "write (or a b)";
|
||||
refuses_all "a dyn function's typed bool result"
|
||||
"(defn p? [x] bool (> x 0)) (defn f [d dyn] i32 (<< 1 (p? d)))"
|
||||
"combined with and, or and not";
|
||||
refuses_all "a bool inside a nest of bit operations"
|
||||
"(defn p? [x i32] bool (> x 0)) \
|
||||
(defn f [x i32] i32 (bit-and x (bit-or x (bit-xor x (p? x)))))"
|
||||
"write (!= a b)";
|
||||
refuses_all ~fln:true "&& in .fln, the bool first"
|
||||
"fn f(flag: bool, x: i32) -> i32\n flag && x\n" "For true and false, write a and b";
|
||||
refuses_all ~fln:true "&& in .fln, a literal first"
|
||||
"fn f(flag: bool) -> i32\n 1 && flag\n" "write a and b";
|
||||
refuses_all ~fln:true "&& in .fln, the bool last of three"
|
||||
"fn f(flag: bool, x: i32) -> i32\n x && x && flag\n" "write a and b";
|
||||
refuses_all ~fln:true "~~ in .fln" "fn f(a: bool) -> i32\n ~~a\n" "~~ works on the bits";
|
||||
refuses_all ~fln:true "^^ in .fln" "fn f(a: bool, b: bool) -> bool\n a ^^ b == 0\n"
|
||||
"write a != b";
|
||||
rejects_check "popcount of a float"
|
||||
"(defn f [a f64] f64 (popcount a))" ~needle:"popcount takes integers, found f64";
|
||||
rejects_check "a rotation's count does not widen the value"
|
||||
"(defn f [a u8 n i32] u8 (rotate-left a n))" ~needle:"i32";
|
||||
|
||||
(* ── Chained comparisons ───────────────────────────────────────── *)
|
||||
(* (< a b c) is a < b and b < c. The left fold — ((a < b) < c) — would be
|
||||
@ -2753,18 +2885,16 @@ let () =
|
||||
"(defn f [a i32 b i32] bool (=/= a b))" ~needle:"Write (!= a b)";
|
||||
rejects_check "== names ="
|
||||
"(defn f [a i32 b i32] bool (== a b))" ~needle:"Write (= a b)";
|
||||
rejects_check "&& names and"
|
||||
"(defn f [a bool b bool] bool (&& a b))" ~needle:"Write (and a b)";
|
||||
rejects_check "&& over bools names and"
|
||||
"(defn f [a bool b bool] bool (&& a b))" ~needle:"write (and a b)";
|
||||
accepts "and that call compiles" "(defn f [a bool b bool] bool (and a b))";
|
||||
rejects_check "|| names or"
|
||||
"(defn f [a bool b bool] bool (|| a b))" ~needle:"Write (or a b)";
|
||||
rejects_check "|| over bools names or"
|
||||
"(defn f [a bool b bool] bool (|| a b))" ~needle:"write (or a b)";
|
||||
rejects_check "! names not"
|
||||
"(defn f [a bool] bool (! a))" ~needle:"Write (not a)";
|
||||
rejects_check "a ! at an arity not does not take gets not's shape"
|
||||
"(defn f [a bool b bool] bool (! a b))" ~needle:"called as (not x)";
|
||||
rejects_check "a bare && is written back as the and that compiles"
|
||||
"(defn f [] bool (&&))" ~needle:"Write (and)";
|
||||
accepts "and it does" "(defn f [] bool (and))";
|
||||
accepts "a bare and compiles" "(defn f [] bool (and))";
|
||||
accepts "a program's own not= is its own"
|
||||
"(defn not= [a i32 b i32] bool (!= a b)) \
|
||||
(defn f [a i32 b i32] bool (not= a b))";
|
||||
@ -7733,9 +7863,18 @@ let () =
|
||||
rejects_check "the refuses a dyn and names the cast"
|
||||
"(defn f [x dyn] i32 (the i32 x))" ~needle:"write (i32 x) to convert it";
|
||||
accepts "the cast that refusal names compiles" "(defn f [x dyn] i32 (i32 x))";
|
||||
rejects_check "the refuses a dyn at a type a dyn does not become"
|
||||
rejects_check "the refuses a dyn at str, which a dyn becomes where passed"
|
||||
"(defn f [x dyn] str (the str x))"
|
||||
~needle:"dyn — str does not cross into a written type yet";
|
||||
~needle:"a dyn becomes a str where a str is passed";
|
||||
accepts "a dyn becomes a slice, an array and a struct where passed"
|
||||
"(defstruct P [x i32]) (defn f [a [const i64] b [2 f32] c P s str] i64 (length a)) \
|
||||
(defn g [d dyn] i64 (f d d d d))";
|
||||
rejects_check "a dyn does not become an array of Vecs"
|
||||
"(defn f [d dyn] [2 (Vec i64)] d)"
|
||||
~needle:"it holds a Vec, which owns its storage";
|
||||
rejects_check "a dyn does not become a slice of dyn"
|
||||
"(defn f [d dyn] [const dyn] d)"
|
||||
~needle:"[const dyn] does not cross into a written type yet";
|
||||
rejects_check "the refuses a dyn at bool, which a dyn becomes where passed"
|
||||
"(defn f [x dyn] bool (the bool x))"
|
||||
~needle:"a dyn becomes a bool where a bool is passed";
|
||||
|
||||
@ -111,6 +111,10 @@ let canon (f : Form.t) : Form.t =
|
||||
let rec go env (f : Form.t) =
|
||||
let v =
|
||||
match f.v with
|
||||
(* The Lisp side may write the bit operators' .fln spellings, which read
|
||||
back as their words: the same builtin by two names. *)
|
||||
| Form.Sym ("&&" | "||" | "^^" as s) ->
|
||||
Form.Sym (match s with "&&" -> "bit-and" | "||" -> "bit-or" | _ -> "bit-xor")
|
||||
| Form.Sym s -> Form.Sym (look env s)
|
||||
(* Quoted data keeps its names: renaming them would hide a printer
|
||||
that renamed them too. *)
|
||||
@ -531,9 +535,42 @@ let () =
|
||||
reads "chain" "x = a < b < c" "(set x (< a b c))";
|
||||
reads "left to right" "x = a - b + c" "(set x (+ (- a b) c))";
|
||||
reads "precedence" "x = a or b and not c == d" "(set x (or a (and b (not (= c d)))))";
|
||||
(* The bit operators: tighter than a comparison, looser than a shift, and
|
||||
among themselves && then ^^ then ||. *)
|
||||
reads "bit and under a comparison" "x = a && mask == 0"
|
||||
"(set x (= (bit-and a mask) 0))";
|
||||
reads "bit operator order" "x = a || b ^^ c && d << 2 + 1"
|
||||
"(set x (bit-or a (bit-xor b (bit-and c (<< d (+ 2 1))))))";
|
||||
reads "bit operators left to right" "x = a && b && c || d"
|
||||
"(set x (bit-or (bit-and a b c) d))";
|
||||
reads "bit-not" "x = ~~a && ~~f(b)" "(set x (bit-and (bit-not a) (bit-not (f b))))";
|
||||
reads "bit-not of a negation" "x = ~~-a" "(set x (bit-not (- a)))";
|
||||
reads "bit operator values" "x = reduce(^^, 0, xs)" "(set x (reduce bit-xor 0 xs))";
|
||||
reads "bit-not in a spaced vector" "x = [~~a b]" "(set x [(bit-not a) b])";
|
||||
reads "a nested unquote" "quote\n f(~(~x))" "(quasiquote (f (unquote (unquote x))))";
|
||||
reads "bit-not in a template" "quote\n f(~~x, ~(~~y))"
|
||||
"(quasiquote (f (bit-not x) (unquote (bit-not y))))";
|
||||
refuses "not-equal chain" "x = a != b != c" "indent/chained-not-equal" "!=(a, b, c)";
|
||||
reads "not-equal call" "x = !=(a, b, c)" "(set x (!= a b c))";
|
||||
refuses "mixed comparison" "x = a < b <= c" "indent/mixed-comparison" "and";
|
||||
(* One direction mixes; each operand that is a call is bound once, in
|
||||
order, before any test. *)
|
||||
reads "mixed chain" "x = 0 <= r < rows" "(set x (and (<= 0 r) (< r rows)))";
|
||||
reads "mixed chain of four" "x = a < b <= c < d"
|
||||
"(set x (and (< a b) (<= b c) (< c d)))";
|
||||
reads "mixed chain downward" "x = x >= y > 0" "(set x (and (>= x y) (> y 0)))";
|
||||
(* A name is bound too once any operand is, so it is read in its turn. *)
|
||||
reads "mixed chain over a call" "x = a < f(b) <= c"
|
||||
"(set x (let [~cmp1 a ~cmp2 (f b) ~cmp3 c] (and (< ~cmp1 ~cmp2) (<= ~cmp2 ~cmp3))))";
|
||||
reads "mixed chain over two calls" "x = 0 < f() <= g() < h()"
|
||||
"(set x (let [~cmp1 (f) ~cmp2 (g) ~cmp3 (h)] (and (< 0 ~cmp1) (<= ~cmp1 ~cmp2) (< ~cmp2 ~cmp3))))";
|
||||
refuses "chain that turns around" "x = a < b > c" "indent/mixed-comparison"
|
||||
"a < b and b > c";
|
||||
refuses "== in a chain" "x = a == b < c" "indent/mixed-comparison" "a == b and b < c";
|
||||
refuses "== after a chain" "x = x < 1 <= 2 == true" "indent/mixed-comparison"
|
||||
"x < 1 and 1 <= 2 and 2 == true";
|
||||
refuses "a refused chain's middle call is named once" "x = a < f(b) <= g(c) > d"
|
||||
"indent/mixed-comparison"
|
||||
"let mid = f(b)\n let mid2 = g(c)\n a < mid and mid <= mid2 and mid2 > d";
|
||||
(* Statements. *)
|
||||
reads "lets merge" "fn f() -> i32\n let a = 1\n let b = 2\n a + b"
|
||||
"(defn f [] i32 (let [a 1 b 2] (+ a b)))";
|
||||
@ -930,7 +967,34 @@ let () =
|
||||
fail "%s: read back %s from %S" name (describe_diff forms back) text
|
||||
| exception e -> fail "%s: its text is refused: %s\n%s" name (diag_text e) text
|
||||
in
|
||||
round "a one-line lambda" "(defn f [] () (h (fn [a] (+ a 1)) 2))" "= h(fn(a) => a + 1, 2)";
|
||||
round "a mixed chain" "(defn f [r i32 n i32] bool (and (<= 0 r) (< r n)))" "= 0 <= r < n";
|
||||
round "an and of one operator stays an and"
|
||||
"(defn f [r i32 n i32] bool (and (< 0 r) (< r n)))" "= 0 < r and r < n";
|
||||
round "an and whose middles differ stays an and"
|
||||
"(defn f [r i32 n i32] bool (and (<= 0 r) (< n 9)))" "= 0 <= r and n < 9";
|
||||
round "a let the reader would not make stays a let"
|
||||
"(defn f [a i32] bool (let [m (g)] (and (<= a m) (< m (h)))))" " let m = g()";
|
||||
back "a chain's middle call gets a name paren text can spell"
|
||||
"fn f(a, b) -> bool = a < g() <= b"
|
||||
"(let [mid a mid2 (g) mid3 b] (and (< mid mid2) (<= mid2 mid3)))";
|
||||
(* And the paren text prints as the chain again, up to the names. *)
|
||||
let src = "(defn f [a i32 b i32] bool (let [mid a mid2 (g) mid3 b] (and (< mid mid2) (<= mid2 mid3))))" in
|
||||
prints "a mixed chain over a call comes back a chain" src " a < g() <= b";
|
||||
(let forms = Reader.read_all ~file:"<p>" src in
|
||||
let back = Indent_reader.read_all ~file:"<p>" (Indent_printer.program ~source:src forms) in
|
||||
if not (same_forms (List.map norm forms) (List.map norm back)) then
|
||||
fail "a mixed chain over a call: read back %s" (describe_diff forms back));
|
||||
round "bit operators print infix"
|
||||
"(defn f [a i32 m i32] bool (= (bit-and a (bit-not m)) (bit-or (bit-xor a 1) (<< m 2))))"
|
||||
"a && ~~m == a ^^ 1 || m << 2";
|
||||
round "bit operators parenthesise against precedence"
|
||||
"(defn f [a i32 b i32 c i32] i32 (bit-and (bit-or a b) (+ c 1) (bit-not (bit-xor a b))))"
|
||||
"= (a || b) && c + 1 && ~~(a ^^ b)";
|
||||
round "a nested unquote prints with parentheses"
|
||||
"(defmacro m [x] `(defmacro n [] `(g ~~x ~(bit-not x))))" "~(~x)";
|
||||
prints "the Lisp spellings print as the operators"
|
||||
"(defn f [a i32 b i32] i32 (^^ (&& a b) (|| a b)))" "a && b ^^ (a || b)";
|
||||
round "a one-line lambda""(defn f [] () (h (fn [a] (+ a 1)) 2))" "= h(fn(a) => a + 1, 2)";
|
||||
round "a block lambda as a call's last argument"
|
||||
"(defn f [] () (sort-by xs (fn [a b] (g a) (< a b))))"
|
||||
" sort-by(xs, fn(a, b) =>\n g(a)\n a < b)";
|
||||
@ -1421,6 +1485,22 @@ let () =
|
||||
[ "syntax/flat/shadows.flan"; "syntax/flat/macros.flan"; "syntax/flat/capture.flan" ];
|
||||
run_both "syntax/mixed/main.flan" "12\n12\n0\n55\n";
|
||||
run_both "syntax/mixed/main.fln" "25\n7\nfar\n3\n";
|
||||
(* A chain in a template: its names made where the macro expands in the
|
||||
paren text, and the chain printed back as one. *)
|
||||
let src = In_channel.with_open_bin "syntax/chain/macro.fln" In_channel.input_all in
|
||||
let want = "false\ntrue\nfalse\n" in
|
||||
run_both "syntax/chain/macro.fln" want;
|
||||
let forms = Indent_reader.read_all ~file:"syntax/chain/macro.fln" src in
|
||||
let paren = Paren_printer.program ~source:src forms in
|
||||
if not (Test_support.contains paren "~(Form.Sym {.s \"~cmp1\"}) ~lo") then
|
||||
fail "a template's chain in parens: %s" paren;
|
||||
let flan = Filename.concat scratch (Printf.sprintf "chain-macro-%d.flan" (Unix.getpid ())) in
|
||||
Out_channel.with_open_bin flan (fun oc -> output_string oc paren);
|
||||
run_both flan want;
|
||||
let back = Indent_printer.program ~source:paren (Reader.read_all ~file:flan paren) in
|
||||
(try Sys.remove flan with Sys_error _ -> ());
|
||||
if not (Test_support.contains back "~lo <= ~x < ~hi") then
|
||||
fail "a template's chain back from parens: %s" back;
|
||||
(* Return types read off the body, in both spellings of [_]. *)
|
||||
List.iter
|
||||
(fun p -> run_both p "3\n2.5\n1.5\n2.5\nyes 0\n4\n0 5\n2\n1\n")
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user