mirror of
https://github.com/janet-lang/janet
synced 2024-11-28 11:09:54 +00:00
143 lines
5.0 KiB
Plaintext
143 lines
5.0 KiB
Plaintext
# Copyright (c) 2023 Calvin Rose
|
|
#
|
|
# Permission is hereby granted, free of charge, to any person obtaining a copy
|
|
# of this software and associated documentation files (the "Software"), to
|
|
# deal in the Software without restriction, including without limitation the
|
|
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
|
|
# sell copies of the Software, and to permit persons to whom the Software is
|
|
# furnished to do so, subject to the following conditions:
|
|
#
|
|
# The above copyright notice and this permission notice shall be included in
|
|
# all copies or substantial portions of the Software.
|
|
#
|
|
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
|
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
|
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
|
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
|
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
|
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
|
|
# IN THE SOFTWARE.
|
|
|
|
(import ./helper :prefix "" :exit true)
|
|
(start-suite)
|
|
|
|
# Marshal
|
|
|
|
# 98f2c6f
|
|
(def um-lookup (env-lookup (fiber/getenv (fiber/current))))
|
|
(def m-lookup (invert um-lookup))
|
|
|
|
# 0cf10946b
|
|
(defn testmarsh [x msg]
|
|
(def marshx (marshal x m-lookup))
|
|
(def out (marshal (unmarshal marshx um-lookup) m-lookup))
|
|
(assert (= (string marshx) (string out)) msg))
|
|
|
|
(testmarsh nil "marshal nil")
|
|
(testmarsh false "marshal false")
|
|
(testmarsh true "marshal true")
|
|
(testmarsh 1 "marshal small integers")
|
|
(testmarsh -1 "marshal integers (-1)")
|
|
(testmarsh 199 "marshal small integers (199)")
|
|
(testmarsh 5000 "marshal medium integers (5000)")
|
|
(testmarsh -5000 "marshal small integers (-5000)")
|
|
(testmarsh 10000 "marshal large integers (10000)")
|
|
(testmarsh -10000 "marshal large integers (-10000)")
|
|
(testmarsh 1.0 "marshal double")
|
|
(testmarsh "doctordolittle" "marshal string")
|
|
(testmarsh :chickenshwarma "marshal symbol")
|
|
(testmarsh @"oldmcdonald" "marshal buffer")
|
|
(testmarsh @[1 2 3 4 5] "marshal array")
|
|
(testmarsh [tuple 1 2 3 4 5] "marshal tuple")
|
|
(testmarsh @{1 2 3 4} "marshal table")
|
|
(testmarsh {1 2 3 4} "marshal struct")
|
|
(testmarsh (fn [x] x) "marshal function 0")
|
|
(testmarsh (fn name [x] x) "marshal function 1")
|
|
(testmarsh (fn [x] (+ 10 x 2)) "marshal function 2")
|
|
(testmarsh (fn thing [x] (+ 11 x x 30)) "marshal function 3")
|
|
(testmarsh map "marshal function 4")
|
|
(testmarsh reduce "marshal function 5")
|
|
(testmarsh (fiber/new (fn [] (yield 1) 2)) "marshal simple fiber 1")
|
|
(testmarsh (fiber/new (fn [&] (yield 1) 2)) "marshal simple fiber 2")
|
|
|
|
# issue #53 - 1147482e6
|
|
(def strct {:a @[nil]})
|
|
(put (strct :a) 0 strct)
|
|
(testmarsh strct "cyclic struct")
|
|
|
|
# More marshalling code
|
|
# issue #53 - 1147482e6
|
|
(defn check-image
|
|
"Run a marshaling test using the make-image and load-image functions."
|
|
[x msg]
|
|
(def im (make-image x))
|
|
# (printf "\nimage-hash: %d" (-> im string hash))
|
|
(assert-no-error msg (load-image im)))
|
|
|
|
(check-image (fn [] (fn [] 1)) "marshal nested functions")
|
|
(check-image (fiber/new (fn [] (fn [] 1)))
|
|
"marshal nested functions in fiber")
|
|
(check-image (fiber/new (fn [] (fiber/new (fn [] 1))))
|
|
"marshal nested fibers")
|
|
|
|
# issue #53 - f4908ebc4
|
|
(def issue-53-x
|
|
(fiber/new
|
|
(fn []
|
|
(var y (fiber/new (fn [] (print "1") (yield) (print "2")))))))
|
|
|
|
(check-image issue-53-x "issue 53 regression")
|
|
|
|
# Marshal closure over non resumable fiber
|
|
# issue #317 - 7c4ffe9b9
|
|
(do
|
|
(defn f1
|
|
[a]
|
|
(defn f1 [] (++ (a 0)))
|
|
(defn f2 [] (++ (a 0)))
|
|
(error [f1 f2]))
|
|
(def [_ tup] (protect (f1 @[0])))
|
|
(def [f1 f2] (unmarshal (marshal tup make-image-dict) load-image-dict))
|
|
(assert (= 1 (f1)) "marshal-non-resumable-closure 1")
|
|
(assert (= 2 (f2)) "marshal-non-resumable-closure 2"))
|
|
|
|
# Marshal closure over currently alive fiber
|
|
# issue #317 - 7c4ffe9b9
|
|
(do
|
|
(defn f1
|
|
[a]
|
|
(defn f1 [] (++ (a 0)))
|
|
(defn f2 [] (++ (a 0)))
|
|
(marshal [f1 f2] make-image-dict))
|
|
(def [f1 f2] (unmarshal (f1 @[0]) load-image-dict))
|
|
(assert (= 1 (f1)) "marshal-live-closure 1")
|
|
(assert (= 2 (f2)) "marshal-live-closure 2"))
|
|
|
|
(do
|
|
(var a 1)
|
|
(defn b [x] (+ a x))
|
|
(def c (unmarshal (marshal b)))
|
|
(assert (= 2 (c 1)) "marshal-on-stack-closure 1"))
|
|
|
|
# Issue #336 cases - don't segfault
|
|
# b145d4786
|
|
(assert-error "unmarshal errors 1" (unmarshal @"\xd6\xb9\xb9"))
|
|
(assert-error "unmarshal errors 2" (unmarshal @"\xd7bc"))
|
|
# 5bbd50785
|
|
(assert-error "unmarshal errors 3"
|
|
(unmarshal "\xd3\x01\xd9\x01\x62\xcf\x03\x78\x79\x7a"
|
|
load-image-dict))
|
|
# fcc610f53
|
|
(assert-error "unmarshal errors 4"
|
|
(unmarshal
|
|
@"\xD7\xCD\0e/p\x98\0\0\x03\x01\x01\x01\x02\0\0\x04\0\xCEe/p../tools
|
|
\0\0\0/afl\0\0\x01\0erate\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE\xDE
|
|
\xA8\xDE\xDE\xDE\xDE\xDE\xDE\0\0\0\xDE\xDE_unmarshal_testcase3.ja
|
|
neldb\0\0\0\xD8\x05printG\x01\0\xDE\xDE\xDE'\x03\0marshal_tes/\x02
|
|
\0\0\0\0\0*\xFE\x01\04\x02\0\0'\x03\0\r\0\r\0\r\0\r" load-image-dict))
|
|
# XXX: still needed? see 72beeeea
|
|
(gccollect)
|
|
|
|
(end-suite)
|
|
|