JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Master is merged into the when, get and if let lane.

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-26 12:13:55 +07:00
commit 62fd7b19bc
20 changed files with 911 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
TODO.org
View File

@ -137,6 +137,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=,
@ -730,6 +738,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]

3
emacs/flan-fln-mode.el
View File

@ -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))

4
emacs/flan-mode.el
View File

@ -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

15
emacs/test-flan-fln.el
View File

@ -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)

226
lib/check.ml
View File

@ -606,6 +606,9 @@ let builtin_names : string list ref = ref []
twenty thousand calls. Filled beside the list. *)
let builtin_set : (string, unit) Hashtbl.t = Hashtbl.create 128
(* Set while [bool_operands] asks an operand its type; see there. *)
let probing = ref false
(* ── builtin/, the reserved qualifier ──────────────────────────────────
[builtin/length] is the builtin [length], whatever else the program has
decided [length] means. It is the way out of the dead end shadowing used to leave: a
@ -677,12 +680,13 @@ let spell_arg stand_for (a : Ast.expr) =
(* Operators other languages spell differently, each mapped to the Flan
builtin that computes the same thing. Only exact equivalents: [mod] is left
out because Clojure's is floored and [%] is not. *)
out because Clojure's is floored and [%] is not. [&&] and [||] are not
here: they are the bit operators, and a bool reaching one is told which
logical operator it wanted there. *)
let operator_aliases =
[ ("not=", ("!=", "Not-equal")); ("=/=", ("!=", "Not-equal"));
("/=", ("!=", "Not-equal")); ("<>", ("!=", "Not-equal"));
("==", ("=", "Equality")); ("===", ("=", "Equality"));
("&&", ("and", "Logical and")); ("||", ("or", "Logical or"));
("!", ("not", "Logical not")) ]
(* The fix, as the sentence that ends the refusal. The reader's call is
@ -10200,7 +10204,9 @@ and not_numeric name what (a : Tast.expr) =
| _ -> false
in
let where = a.Tast.loc in
if text then
if a.Tast.ty = Types.Bool && String.equal what "integers" then
bool_bits where name
else if text then
fail where
"%s takes %s, and this is %s — there is no %s on text. The prelude \
concatenates with concat and join"
@ -10320,14 +10326,16 @@ and dyn_fold ctx ~want loc name first rest =
| "+" -> "flan_dyn_add" | "-" -> "flan_dyn_sub"
| "*" -> "flan_dyn_mul" | "/" -> "flan_dyn_div"
| "%" -> "flan_dyn_rem"
| _ ->
(* Bitwise and shift operators land here if they ever admit a dyn
operand. They do not: the runtime carries no bitwise entry points,
and an integer operation on a value that might be a float is not
something to guess at. *)
no_dyn_yet loc ~into:false Types.Dyn
(Printf.sprintf " — %s has no dyn form" name)
| _ -> dyn_bits_sym name
in
(* A bitwise fold takes integers on both sides, and the typed side of a
mixed pair can be asked now rather than at run time. *)
let bitwise = not (List.mem name [ "+"; "-"; "*"; "/"; "%" ]) in
if bitwise then
List.iter
(fun (v : Tast.expr) ->
if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v)
first;
(* The site travels with the operands. A dyn arithmetic trap is this
language's type error, and until now it printed with no file, no line and
no column — [here loc] is the same string literal [cast_dyn] hands the
@ -10338,12 +10346,100 @@ and dyn_fold ctx ~want loc name first rest =
| [ a; b ] -> apply (box loc a) b
| _ -> assert false
in
let acc =
List.fold_left (fun acc arg -> apply acc (check ctx ~want:Types.Dyn arg))
acc rest
let operand arg =
if bitwise then begin
let v = check ctx arg in
if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v;
v
end
else check ctx ~want:Types.Dyn arg
in
let acc = List.fold_left (fun acc arg -> apply acc (operand arg)) acc rest in
expect ctx loc ~want acc
(* The runtime's entry point for each bit operation on a dyn int. *)
and dyn_bits_sym name =
match name with
| "bit-and" -> "flan_dyn_bitand" | "bit-or" -> "flan_dyn_bitor"
| "bit-xor" -> "flan_dyn_bitxor" | "bit-not" -> "flan_dyn_bitnot"
| "<<" -> "flan_dyn_shl" | ">>" -> "flan_dyn_shr"
| "rotate-left" -> "flan_dyn_rotl" | "rotate-right" -> "flan_dyn_rotr"
| "popcount" -> "flan_dyn_popcount" | "leading-zeros" -> "flan_dyn_clz"
| "trailing-zeros" -> "flan_dyn_ctz"
| _ -> invalid_arg ("dyn_bits_sym " ^ name)
(* An operand of a bit operation, once it is known not to be dyn: an integer,
or a type variable the where clause bounds by [integer?]. A bool is the
likeliest thing to arrive here — [a && b] is logical and in C — so it is
answered with the operator that does what was meant. *)
and bits_operand ctx loc name (v : Tast.expr) =
match v.Tast.ty with
| Types.Int _ -> ()
| t when generic_ty t -> unconstrained ctx.env loc name ~needs:"integer?" t
| Types.Bool -> bool_bits v.Tast.loc name
| other -> fail loc "%s takes integers, found %s" name (tyname loc other)
(* A bool operand is refused before the operands are joined, and not left to
[bits_operand]: the join sees a bool beside an integer as a plain mismatch,
"expected i32, found bool", which says nothing of [and]. Each operand's own
type is asked in a trial that is always abandoned, so the check leaves no
trace — no slot, no lifted lambda, no recorded refusal — and the real check
below is the only one that counts. A literal is never a bool, and a call to
an arithmetic or bit operator answers a number or a dyn, so neither is
asked. Nor is anything asked while a probe is running: the probe wants a
type, and asking again inside it would check a nest of these once per
level for every level above it, which doubles with each level. *)
and bool_operands ctx name (args : Ast.expr list) =
if not !probing then
let never_bool (a : Ast.expr) =
match a.Ast.e with
| Ast.Int _ | Ast.UInt _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _ ->
true
| Ast.Call ({ Ast.e = Ast.Var h; _ }, _) ->
List.mem h
[ "+"; "-"; "*"; "/"; "%"; "bit-and"; "bit-or"; "bit-xor"; "bit-not";
"&&"; "||"; "^^"; "~~"; "<<"; ">>"; "rotate-left"; "rotate-right";
"popcount"; "leading-zeros"; "trailing-zeros" ]
&& not (shadows_builtin ctx a.Ast.loc h)
| _ -> false
in
let is_bool (a : Ast.expr) =
(not (never_bool a))
&&
let ty = ref None in
probing := true;
Fun.protect ~finally:(fun () -> probing := false) (fun () ->
ignore
(trial ctx (fun () ->
let v = check ctx a in
ty := Some v.Tast.ty;
Loc.failk "check/probe" a.Ast.loc "abandoned")));
!ty = Some Types.Bool
in
List.iter (fun a -> if is_bool a then bool_bits a.Ast.loc name) args
and bool_bits loc name =
let fln = fln_source loc in
let shown =
if not fln then name
else match name with
| "bit-and" -> "&&" | "bit-or" -> "||" | "bit-xor" -> "^^"
| "bit-not" -> "~~" | n -> n
in
let logic =
match name with
| "bit-and" -> Some (if fln then "a and b" else "(and a b)")
| "bit-or" -> Some (if fln then "a or b" else "(or a b)")
| "bit-xor" -> Some (if fln then "a != b" else "(!= a b)")
| "bit-not" -> Some (if fln then "not a" else "(not a)")
| _ -> None
in
Loc.failk "check/bits-of-bool" loc
"%s works on the bits of an integer, and this is a bool. %s" shown
(match logic with
| Some l -> Printf.sprintf "For true and false, write %s" l
| None -> "True and false are combined with and, or and not")
(* A comparison over three operands or more asks about more than one pair, and
every operand is bound to a slot before any pair is looked at. That is what
makes "left to right, exactly once" true of the lowering and not only of
@ -11238,8 +11334,33 @@ and named_call ?(qualified = false) ctx ~want loc name args =
| _ -> Tast.BitXor
in
fold_arity loc name args;
bool_operands ctx name args;
fold_left_prim ctx ~want loc name p ~needs:"integer?" Types.is_integer
"integers" args
(* The .fln operators, which the indented reader already spells as the words
above; a form built some other way may still carry them. [~qualified]
skips the shadowing arm, because a program that means its own [&&] has
been answered by that arm already under this name. *)
| "&&" | "||" | "^^" | "~~" ->
let canon = match name with
| "&&" -> "bit-and" | "||" -> "bit-or" | "^^" -> "bit-xor"
| _ -> "bit-not"
in
named_call ~qualified:true ctx ~want loc canon args
| "bit-not" | "popcount" | "leading-zeros" | "trailing-zeros" ->
arity ctx loc name 1 args;
bool_operands ctx name args;
let v = check ctx ?want:(numeric_want want) (List.hd args) in
if v.Tast.ty = Types.Dyn then
expect ctx loc ~want (rt loc Types.Dyn (dyn_bits_sym name) [ v; here loc ])
else begin
bits_operand ctx loc name v;
let p = match name with
| "bit-not" -> Tast.BitNot | "popcount" -> Tast.Popcount
| "leading-zeros" -> Tast.Clz | _ -> Tast.Ctz
in
prim p v.Tast.ty [ v ]
end
(* The shifts stay at two, and not only because a shift chain reads badly:
each count would be checked against the same width below, so (<< x 30 30)
would pass two legal shifts and still shift the value away entirely.
@ -11251,22 +11372,32 @@ and named_call ?(qualified = false) ctx ~want loc name args =
type and the width the shift wraps at would be taken from a number that is
only saying how far, and the range check just below, along with [emit]'s
mask, is keyed to the *value's* width. A count wider than the value is
refused and is told to write the cast. *)
| "<<" | ">>" ->
let p = if String.equal name "<<" then Tast.Shl else Tast.Shr in
refused and is told to write the cast.
The rotations share the rule and not the range check: a rotation by the
width is the value unchanged, so every count means something and is taken
modulo the width. *)
| "<<" | ">>" | "rotate-left" | "rotate-right" ->
let p = match name with
| "<<" -> Tast.Shl | ">>" -> Tast.Shr | "rotate-left" -> Tast.Rotl
| _ -> Tast.Rotr
in
arity ctx loc name 2 args;
let a, b = binary ctx ~join:false name loc ~want:(numeric_want want) args in
(match a.Tast.ty with
| Types.Int _ -> ()
(* A type variable under {:where (integer? $t)}: every type the bound
admits has a width to shift within, so the abstract pass lets the
body through and each instantiation meets the concrete checks below
at its own width. Anything weaker — [numeric?] included — is refused
here, at the definition, because a shift at f32 means nothing. *)
| t when generic_ty t ->
unconstrained ctx.env loc name ~needs:"integer?" t
| other -> fail loc "%s takes integers, found %s" name
(tyname loc other));
bool_operands ctx name args;
let a, b =
binary ctx ~dyn_ok:true ~join:false name loc ~want:(numeric_want want) args
in
if a.Tast.ty = Types.Dyn || b.Tast.ty = Types.Dyn then begin
(* The typed side of a mixed pair still has to be an integer: the dyn
half is asked at run time, and this half can be asked now. *)
List.iter
(fun (v : Tast.expr) ->
if v.Tast.ty <> Types.Dyn then bits_operand ctx v.Tast.loc name v)
[ a; b ];
expect ctx loc ~want
(rt loc Types.Dyn (dyn_bits_sym name) [ box loc a; box loc b; here loc ])
end else begin
bits_operand ctx loc name a;
(* A shift by the operand's own width or more is poison in LLVM, which at
-O2 turns the whole function into an undefined value rather than into a
wrong number. A literal count is rejected here — that is the typo — and
@ -11281,6 +11412,7 @@ and named_call ?(qualified = false) ctx ~want loc name args =
(tyname loc a.Tast.ty) (Types.bits k)
| _ -> ());
prim p a.Tast.ty [ a; b ]
end
(* (min a b) and (max a b) evaluate each operand once — hence the slots —
because a min over two calls must not call either of them twice.
@ -14715,19 +14847,41 @@ let builtins : (string * string * string) list =
("not", "not [bool] bool",
"Negates a bool. Nothing else in this language is a truth value.");
("bit-and", "bit-and [int ...] int",
"Bitwise and, folded left. Integers only; operands of different widths \
meet at the wider one, the way + does.");
("bit-or", "bit-or [int ...] int", "Bitwise or, folded left over integers.");
"Bitwise and, folded left; a && b in a .fln file. Integers only; operands \
of different widths meet at the wider one, the way + does.");
("bit-or", "bit-or [int ...] int",
"Bitwise or, folded left over integers; a || b in a .fln file.");
("bit-xor", "bit-xor [int ...] int",
"Bitwise exclusive or, folded left over integers.");
"Bitwise exclusive or, folded left over integers; a ^^ b in a .fln file.");
("bit-not", "bit-not [int] int",
"Every bit of an integer flipped; ~~a in a .fln file.");
("&&", "&& [int ...] int", "bit-and, by its .fln spelling.");
("||", "|| [int ...] int", "bit-or, by its .fln spelling.");
("^^", "^^ [int ...] int", "bit-xor, by its .fln spelling.");
("~~", "~~ [int] int", "bit-not, by its .fln spelling.");
("<<", "<< [int int] int",
"Left shift. The value's type decides — a narrower count widens to it, a \
wider one is refused — and a literal count at or past the value's width \
is refused too, because LLVM calls that poison.");
is refused too. On a dyn int, a count outside 0 to 63 traps.");
(">>", ">> [int int] int",
"Right shift. The value's type decides and the count widens to it, never \
the reverse; a literal count at or past the width is refused, as it is \
for <<.");
"Right shift, arithmetic on a signed type and logical on an unsigned one. \
The value's type decides and the count widens to it; a literal count at \
or past the width is refused, as it is for <<.");
("rotate-left", "rotate-left [int int] int",
"The bits of the value moved left by the count, the ones that fall off \
the top coming back in at the bottom. The count is taken modulo the \
width.");
("rotate-right", "rotate-right [int int] int",
"The bits of the value moved right by the count, wrapping round to the \
top. The count is taken modulo the width.");
("popcount", "popcount [int] int",
"How many bits of the integer are set. The answer has the operand's \
type.");
("leading-zeros", "leading-zeros [int] int",
"How many zero bits come before the highest set bit, counted within the \
operand's width: the width itself for 0.");
("trailing-zeros", "trailing-zeros [int] int",
"How many zero bits come after the lowest set bit: the width for 0.");
("min", "min [ordered? ...] ordered?",
"The smallest of two or more operands, each of them evaluated exactly \
once however many there are. Two widths meet at the wider: (min i8-x \

59
lib/emit.ml
View File

@ -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)
@ -5035,6 +5083,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)

101
lib/indent_printer.ml
View File

@ -296,36 +296,42 @@ 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 (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 +353,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 +373,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 +408,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 +432,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)
@ -442,7 +453,7 @@ and list f h args =
(* [if let P = v], the head (if-let [P v] ...) is written with. *)
and if_let_head (hd : Form.t) =
match hd.v with
| Form.Vec [ pat; v ] -> "if let " ^ at 8 pat ^ " = " ^ at 1 v
| Form.Vec [ pat; v ] -> "if let " ^ at 11 pat ^ " = " ^ at 1 v
| _ -> assert false
(* A one-line slot's text — an arm's value, a then or an else, what follows
@ -462,7 +473,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)]. *)
@ -474,7 +485,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 ->
@ -491,7 +502,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"; _ };
@ -510,7 +521,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
@ -750,7 +761,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
@ -782,7 +795,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 ->
@ -963,9 +976,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
@ -1102,7 +1115,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"; _ } :: _ :: _ :: _) ->
@ -1305,7 +1318,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
@ -1370,7 +1383,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
@ -1385,7 +1398,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. *)

81
lib/indent_reader.ml
View File

@ -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)];
@ -185,7 +192,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 +532,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 +665,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. *)
@ -677,11 +683,16 @@ let when_else p =
and None when it does not. For two branches write if c then a else b, \
or an if with an else block"
(* 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
@ -745,7 +756,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 =
@ -758,18 +773,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)
@ -801,7 +816,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
@ -813,18 +828,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
@ -837,21 +852,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)
@ -998,7 +1013,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. *)
@ -1142,7 +1157,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;
@ -1151,7 +1166,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
@ -1182,7 +1197,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

6
lib/js.ml
View File

@ -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

3
lib/reader.ml
View File

@ -209,6 +209,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"

4
lib/tast.ml
View File

@ -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
View File

@ -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;

112
runtime/flan_dyn.c
View File

@ -2802,6 +2802,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

14
runtime/flan_dyn.h
View File

@ -205,6 +205,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;
* a mixture of the two, or anything else, traps. */
flan_dyn flan_dyn_lt(flan_dyn a, flan_dyn b, const uint8_t *loc, int64_t loclen);

12
spec-syntax.md
View File

@ -155,9 +155,15 @@ 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.** Mixing
comparison operators in one chain, `a < b <= c`, is refused. 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.**
- **`==` 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

51
test/programs/bits-dyn.flan Normal file
View 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
View 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)

75
test/test_acceptance.ml
View File

@ -669,6 +669,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

97
test/test_flan.ml
View File

@ -1375,6 +1375,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
@ -2749,18 +2834,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))";

31
test/test_syntax.ml
View File

@ -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. *)
@ -528,6 +532,21 @@ 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";
@ -927,7 +946,17 @@ 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 "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)";