mirror of
https://github.com/janet-lang/janet
synced 2024-06-18 11:19:56 +00:00
Fix NaNboxing bug that cause flaky builds.
The macro janet_checktype(x, JANET_NUMBER) was incorrect when x was NaN. This caused the initial unmarshalling dictionary to be missing entries in certain cases.
This commit is contained in:
Calvin Rose
parent
321a758ab9
commit
24b8b0e382
2
Makefile
2
Makefile
|
|
@ -149,7 +149,7 @@ build/janet_boot: $(JANET_BOOT_OBJECTS)
|
|||
|
||||
# Now the reason we bootstrap in the first place
|
||||
build/janet.c: build/janet_boot src/boot/boot.janet
|
||||
build/janet_boot . JANET_PATH '$(JANET_PATH)' JANET_HEADERPATH '$(INCLUDEDIR)/janet' > $@
|
||||
build/janet_boot . JANET_PATH '$(JANET_PATH)' > $@
|
||||
cksum $@
|
||||
|
||||
########################
|
||||
|
|
|
|||
|
|
@ -7,6 +7,8 @@
|
|||
###
|
||||
###
|
||||
|
||||
(def root-env "The root environment used to create environments with (make-env)" _env)
|
||||
|
||||
(def defn :macro
|
||||
"(defn name & more)\n\nDefine a function. Equivalent to (def name (fn name [args] ...))."
|
||||
(fn defn [name & more]
|
||||
|
|
@ -567,15 +569,6 @@
|
|||
[head & body]
|
||||
(loop1 body head 0))
|
||||
|
||||
(put _env 'loop1 nil)
|
||||
(put _env 'check-indexed nil)
|
||||
(put _env 'for-template nil)
|
||||
(put _env 'for-var-template nil)
|
||||
(put _env 'iterate-template nil)
|
||||
(put _env 'each-template nil)
|
||||
(put _env 'range-template nil)
|
||||
(put _env 'loop-fiber-template nil)
|
||||
|
||||
(defmacro seq
|
||||
"Similar to loop, but accumulates the loop body into an array and returns that.
|
||||
See loop for details."
|
||||
|
|
@ -594,6 +587,16 @@
|
|||
[& body]
|
||||
(tuple fiber/new (tuple 'fn '[] ;body) :yi))
|
||||
|
||||
(defmacro- undef
|
||||
"Remove binding from root-env"
|
||||
[& syms]
|
||||
~(do ,;(seq [s :in syms] ~(put root-env ',s nil))))
|
||||
|
||||
(undef _env)
|
||||
|
||||
(undef loop1 check-indexed for-template for-var-template iterate-template
|
||||
each-template range-template loop-fiber-template)
|
||||
|
||||
(defn sum
|
||||
"Returns the sum of xs. If xs is empty, returns 0."
|
||||
[xs]
|
||||
|
|
@ -749,7 +752,7 @@
|
|||
[& xs]
|
||||
(compare-reduce >= xs))
|
||||
|
||||
(put _env 'compare-reduce nil)
|
||||
(undef compare-reduce)
|
||||
|
||||
###
|
||||
###
|
||||
|
|
@ -785,8 +788,8 @@
|
|||
[a &opt by]
|
||||
(sort-help a 0 (- (length a) 1) (or by <)))
|
||||
|
||||
(put _env 'sort-part nil)
|
||||
(put _env 'sort-help nil)
|
||||
(undef sort-part)
|
||||
(undef sort-help)
|
||||
|
||||
(defn sort-by
|
||||
"Returns a new sorted array that compares elements by invoking
|
||||
|
|
@ -1140,8 +1143,8 @@
|
|||
:tuple (tuple/slice (walk-ind f form))
|
||||
form))
|
||||
|
||||
(put _env 'walk-ind nil)
|
||||
(put _env 'walk-dict nil)
|
||||
(undef walk-ind)
|
||||
(undef walk-dict)
|
||||
|
||||
(defn postwalk
|
||||
"Do a post-order traversal of a data structure and call (f x)
|
||||
|
|
@ -1350,7 +1353,7 @@
|
|||
[tab & colls]
|
||||
(loop [c :in colls
|
||||
key :keys c]
|
||||
(set (tab key) (in c key)))
|
||||
(put tab key (in c key)))
|
||||
tab)
|
||||
|
||||
(defn merge
|
||||
|
|
@ -1361,7 +1364,7 @@
|
|||
(def container @{})
|
||||
(loop [c :in colls
|
||||
key :keys c]
|
||||
(set (container key) (in c key)))
|
||||
(put container key (in c key)))
|
||||
container)
|
||||
|
||||
(defn keys
|
||||
|
|
@ -1615,9 +1618,9 @@
|
|||
,(aux (+ 2 i))
|
||||
,$res)))) 0)))
|
||||
|
||||
(put _env 'sentinel nil)
|
||||
(put _env 'match-1 nil)
|
||||
(put _env 'with-idemp nil)
|
||||
(undef sentinel)
|
||||
(undef match-1)
|
||||
(undef with-idemp)
|
||||
|
||||
###
|
||||
###
|
||||
|
|
@ -1742,8 +1745,8 @@
|
|||
[&opt sym]
|
||||
~(,doc* ',sym))
|
||||
|
||||
(put _env 'env-walk nil)
|
||||
(put _env 'print-index nil)
|
||||
(undef env-walk)
|
||||
(undef print-index)
|
||||
|
||||
###
|
||||
###
|
||||
|
|
@ -2032,7 +2035,7 @@
|
|||
will inherit bindings from the parent environment, but new
|
||||
bindings will not pollute the parent environment."
|
||||
[&opt parent]
|
||||
(def parent (if parent parent _env))
|
||||
(def parent (if parent parent root-env))
|
||||
(def newenv (table/setproto @{} parent))
|
||||
newenv)
|
||||
|
||||
|
|
@ -2248,10 +2251,11 @@
|
|||
by make-image, such that (load-image bytes) is the same as (unmarshal bytes load-image-dict)."
|
||||
@{})
|
||||
|
||||
(def comptime
|
||||
(defmacro comptime
|
||||
"(comptime x)\n\n
|
||||
Evals x at compile time and returns the result. Similar to a top level unquote."
|
||||
:macro eval)
|
||||
[x]
|
||||
(eval x))
|
||||
|
||||
(defn make-image
|
||||
"Create an image from an environment returned by require.
|
||||
|
|
@ -2305,7 +2309,7 @@
|
|||
(module/add-paths ".jimage" :image)
|
||||
|
||||
# Version of fexists that works even with a reduced OS
|
||||
(if-let [has-stat (_env 'os/stat)]
|
||||
(if-let [has-stat (root-env 'os/stat)]
|
||||
(let [stat (has-stat :value)]
|
||||
(defglobal "fexists" (fn fexists [path] (= :file (stat path :mode)))))
|
||||
(defglobal "fexists"
|
||||
|
|
@ -2352,10 +2356,10 @@
|
|||
str-parts (interpose "\n " paths)]
|
||||
[nil (string "could not find module " path ":\n " ;str-parts)])))
|
||||
|
||||
(put _env 'fexists nil)
|
||||
(put _env 'mod-filter nil)
|
||||
(put _env 'check-. nil)
|
||||
(put _env 'not-check-. nil)
|
||||
(undef fexists)
|
||||
(undef mod-filter)
|
||||
(undef check-.)
|
||||
(undef not-check-.)
|
||||
|
||||
(def module/cache
|
||||
"Table mapping loaded module identifiers to their environments."
|
||||
|
|
@ -2463,7 +2467,7 @@
|
|||
(def newv (table/setproto @{:private (not ep)} v))
|
||||
(put env (symbol prefix k) newv)))
|
||||
|
||||
(put _env 'require-1 nil)
|
||||
(undef require-1)
|
||||
|
||||
(defmacro import
|
||||
"Import a module. First requires the module, and then merges its
|
||||
|
|
@ -2530,7 +2534,7 @@
|
|||
(in (.slots frame-idx) (or nth 0)))
|
||||
|
||||
# Conditional compilation for disasm
|
||||
(def disasm-alias (if-let [x (_env 'disasm)] (x :value)))
|
||||
(def disasm-alias (if-let [x (root-env 'disasm)] (x :value)))
|
||||
|
||||
(defn .disasm
|
||||
"Gets the assembly for the current function."
|
||||
|
|
@ -2592,13 +2596,9 @@
|
|||
(debug/unfbreak fun i))
|
||||
(print "Cleared " (length bytecode) " breakpoints in " fun))
|
||||
|
||||
(unless (get _env 'disasm)
|
||||
(put _env '.disasm nil)
|
||||
(put _env '.bytecode nil)
|
||||
(put _env '.breakall nil)
|
||||
(put _env '.clearall nil)
|
||||
(put _env '.ppasm nil))
|
||||
(put _env 'disasm-alias nil)
|
||||
(unless (get root-env 'disasm)
|
||||
(undef .disasm .bytecode .breakall .clearall .ppasm))
|
||||
(undef disasm-alias)
|
||||
|
||||
(defn .source
|
||||
"Show the source code for the function being debugged."
|
||||
|
|
@ -2652,9 +2652,9 @@
|
|||
"An environment that contains dot prefixed functions for debugging."
|
||||
@{})
|
||||
|
||||
(def- debugger-keys (filter (partial string/has-prefix? ".") (keys _env)))
|
||||
(each k debugger-keys (put debugger-env k (_env k)) (put _env k nil))
|
||||
(put _env 'debugger-keys nil)
|
||||
(def- debugger-keys (filter (partial string/has-prefix? ".") (keys root-env)))
|
||||
(each k debugger-keys (put debugger-env k (root-env k)) (put root-env k nil))
|
||||
(undef debugger-keys)
|
||||
|
||||
###
|
||||
###
|
||||
|
|
@ -2750,7 +2750,7 @@
|
|||
(each a args (import* (string a) :prefix "" :evaluator evaluator)))
|
||||
|
||||
# conditional compilation for reduced os
|
||||
(def- getenv-alias (if-let [entry (in _env 'os/getenv)] (entry :value) (fn [&])))
|
||||
(def- getenv-alias (if-let [entry (in root-env 'os/getenv)] (entry :value) (fn [&])))
|
||||
|
||||
(defn cli-main
|
||||
"Entrance for the Janet CLI tool. Call this functions with the command line
|
||||
|
|
@ -2885,12 +2885,7 @@
|
|||
(setdyn :err-color (if *colorize* true))
|
||||
(repl getchunk nil env)))
|
||||
|
||||
(put _env 'no-side-effects nil)
|
||||
(put _env 'is-safe-def nil)
|
||||
(put _env 'safe-forms nil)
|
||||
(put _env 'importers nil)
|
||||
(put _env 'use-2 nil)
|
||||
(put _env 'getenv-alias nil)
|
||||
(undef no-side-effects is-safe-def safe-forms importers use-2 getenv-alias)
|
||||
|
||||
###
|
||||
###
|
||||
|
|
@ -2898,12 +2893,13 @@
|
|||
###
|
||||
###
|
||||
|
||||
(def root-env "The root environment used to create environments with (make-env)" _env)
|
||||
|
||||
(do
|
||||
(put _env 'boot/opts nil)
|
||||
(put _env '_env nil)
|
||||
(def load-dict (env-lookup _env))
|
||||
(undef boot/opts undef)
|
||||
(def load-dict (env-lookup root-env))
|
||||
(put load-dict 'boot/config nil)
|
||||
(put load-dict 'boot/args nil)
|
||||
(each [k v] (pairs load-dict)
|
||||
(if (number? v) (put load-dict k nil)))
|
||||
(merge-into load-image-dict load-dict)
|
||||
(merge-into make-image-dict (invert load-dict)))
|
||||
|
||||
|
|
@ -2924,25 +2920,29 @@
|
|||
(put into k (x k))))
|
||||
into)
|
||||
|
||||
(def env (fiber/getenv (fiber/current)))
|
||||
|
||||
# Modify env based on some options.
|
||||
(loop [[k v] :pairs env
|
||||
(loop [[k v] :pairs root-env
|
||||
:when (symbol? k)]
|
||||
(def flat (proto-flatten @{} v))
|
||||
(when (boot/config :no-docstrings)
|
||||
(put flat :doc nil))
|
||||
(when (boot/config :no-sourcemaps)
|
||||
(put flat :source-map nil))
|
||||
(put env k flat))
|
||||
(put root-env k flat))
|
||||
|
||||
(put env 'boot/config nil)
|
||||
(put env 'boot/args nil)
|
||||
(def image (let [env-pairs (pairs (env-lookup env))
|
||||
(put root-env 'boot/config nil)
|
||||
(put root-env 'boot/args nil)
|
||||
|
||||
(def image (let [env-pairs (pairs (env-lookup root-env))
|
||||
essential-pairs (filter (fn [[k v]] (or (cfunction? v) (abstract? v))) env-pairs)
|
||||
lookup (table ;(mapcat identity essential-pairs))
|
||||
reverse-lookup (invert lookup)]
|
||||
(marshal env reverse-lookup)))
|
||||
# Check no duplicate values
|
||||
(def temp @{})
|
||||
(eachp [k v] lookup
|
||||
(if (in temp v) (errorf "duplicate value: %v" v))
|
||||
(put temp v k))
|
||||
(marshal root-env reverse-lookup)))
|
||||
|
||||
# Create amalgamation
|
||||
|
||||
|
|
|
|||
|
|
@ -23,6 +23,7 @@
|
|||
#include <janet.h>
|
||||
#include <assert.h>
|
||||
#include <stdio.h>
|
||||
#include <math.h>
|
||||
|
||||
#include "tests.h"
|
||||
|
||||
|
|
@ -44,6 +45,11 @@ int system_test() {
|
|||
assert(janet_equals(janet_wrap_integer(INT32_MIN), janet_wrap_integer(INT32_MIN)));
|
||||
assert(janet_equals(janet_wrap_number(1.4), janet_wrap_number(1.4)));
|
||||
assert(janet_equals(janet_wrap_number(3.14159265), janet_wrap_number(3.14159265)));
|
||||
#ifdef NAN
|
||||
assert(janet_checktype(janet_wrap_number(NAN), JANET_NUMBER));
|
||||
#else
|
||||
assert(janet_checktype(janet_wrap_number(0.0 / 0.0), JANET_NUMBER));
|
||||
#endif
|
||||
|
||||
assert(NULL != &janet_wrap_nil);
|
||||
|
||||
|
|
|
|||
|
|
@ -1218,7 +1218,7 @@ JanetTable *janet_core_env(JanetTable *replacements) {
|
|||
}
|
||||
|
||||
/* Load core cfunctions (and some built in janet assembly functions) */
|
||||
JanetTable *dict = janet_table(300);
|
||||
JanetTable *dict = janet_table(512);
|
||||
janet_load_libs(dict);
|
||||
|
||||
/* Add replacements */
|
||||
|
|
|
|||
|
|
@ -274,9 +274,9 @@ int32_t janet_hash(Janet x) {
|
|||
if (sizeof(double) == sizeof(void *)) {
|
||||
/* Assuming 8 byte pointer */
|
||||
uint64_t i = janet_u64(x);
|
||||
uint32_t lo = (uint32_t) (i & 0xFFFFFFFF);
|
||||
uint32_t hi = (uint32_t) (i >> 32);
|
||||
hash = (int32_t) (hi ^ (lo >> 3));
|
||||
uint32_t lo = (uint32_t)(i & 0xFFFFFFFF);
|
||||
uint32_t hi = (uint32_t)(i >> 32);
|
||||
hash = (int32_t)(hi ^ (lo >> 3));
|
||||
} else {
|
||||
/* Assuming 4 byte pointer (or smaller) */
|
||||
hash = (int32_t)((char *)janet_unwrap_pointer(x) - (char *)0);
|
||||
|
|
|
|||
|
|
@ -579,7 +579,7 @@ JANET_API Janet janet_wrap_integer(int32_t x);
|
|||
(((x).u64 & JANET_NANBOX_TAGBITS) == janet_nanbox_tag((type)))
|
||||
|
||||
#define janet_nanbox_isnumber(x) \
|
||||
(!isnan((x).number) || janet_nanbox_checkauxtype((x), JANET_NUMBER))
|
||||
(!isnan((x).number) || ((((x).u64 >> 47) & 0xF) == JANET_NUMBER))
|
||||
|
||||
#define janet_checktype(x, t) \
|
||||
(((t) == JANET_NUMBER) \
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user