Game-Decompilation/jak-project
1
0
Fork 0
mirror of https://github.com/open-goal/jak-project.git synced 2025-02-17 04:27:57 +00:00
Code Issues Actions 3 Packages Projects Releases Wiki Activity

Compiler Cleanup (Part 2) (#56)

Browse Source 
* check on windows

* fix windows build

* version test

* clean up - will it work on windows

* fix formatting
This commit is contained in:
water111 2020-09-25 21:11:27 -04:00 committed by GitHub
parent 15051ec5dd
commit c9b53d51ff
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
175 changed files with 455 additions and 2785 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
.vs/launch.vs.json
View File

@ -9,11 +9,7 @@
"name": "Run Tests - Summary",
"args": [
"--gtest_brief=1"
],
"env": {
"NEXT_DIR": "${projectDir}",
"FAKE_ISO_PATH": "/game/fake_iso.txt"
}
]
},
{
"type": "default",
@ -22,17 +18,28 @@
"name": "Run Tests - Verbose",
"args": [
"--gtest_brief=0"
],
"env": {
"NEXT_DIR": "${projectDir}",
"FAKE_ISO_PATH": "/game/fake_iso.txt"
}
]
},
{
"type": "default",
"project": "CMakeLists.txt",
"projectTarget": "gk.exe (bin\\gk.exe)",
"name": "Run Game"
"name": "Run Runtime (no kernel)",
"args": [
"-fakeiso",
"-debug",
"-nokernel"
]
},
{
"type": "default",
"project": "CMakeLists.txt",
"projectTarget": "gk.exe (bin\\gk.exe)",
"name": "Run Runtime (with kernel)",
"args": [
"-fakeiso",
"-debug"
]
},
{
"type": "default",

6
boot_kernel.sh Executable file
View File

@ -0,0 +1,6 @@
#!/bin/bash
# Directory of this script
DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
$DIR/build/game/gk -fakeiso -debug

2
common/goos/CMakeLists.txt
View File

@ -1,2 +1,2 @@
add_library(goos SHARED Object.cpp TextDB.cpp Reader.cpp Interpreter.cpp InterpreterEval.cpp)
target_link_libraries(goos common_util)
target_link_libraries(goos common_util fmt)

60
common/goos/Interpreter.cpp
View File

@ -38,36 +38,36 @@ Interpreter::Interpreter() {
{"while", &Interpreter::eval_while},
};
builtin_forms = {
{"top-level", &Interpreter::eval_begin},
{"begin", &Interpreter::eval_begin},
{"exit", &Interpreter::eval_exit},
{"read", &Interpreter::eval_read},
{"read-file", &Interpreter::eval_read_file},
{"print", &Interpreter::eval_print},
{"inspect", &Interpreter::eval_inspect},
{"load-file", &Interpreter::eval_load_file},
{"eq?", &Interpreter::eval_equals},
{"gensym", &Interpreter::eval_gensym},
{"eval", &Interpreter::eval_eval},
{"cons", &Interpreter::eval_cons},
{"car", &Interpreter::eval_car},
{"cdr", &Interpreter::eval_cdr},
{"set-car!", &Interpreter::eval_set_car},
{"set-cdr!", &Interpreter::eval_set_cdr},
{"+", &Interpreter::eval_plus},
{"-", &Interpreter::eval_minus},
{"*", &Interpreter::eval_times},
{"/", &Interpreter::eval_divide},
{"=", &Interpreter::eval_numequals},
{"<", &Interpreter::eval_lt},
{">", &Interpreter::eval_gt},
{"<=", &Interpreter::eval_leq},
{">=", &Interpreter::eval_geq},
{"null?", &Interpreter::eval_null},
{"type?", &Interpreter::eval_type},
{"current-method-type", &Interpreter::eval_current_method_type},
};
builtin_forms = {{"top-level", &Interpreter::eval_begin},
{"begin", &Interpreter::eval_begin},
{"exit", &Interpreter::eval_exit},
{"read", &Interpreter::eval_read},
{"read-file", &Interpreter::eval_read_file},
{"print", &Interpreter::eval_print},
{"inspect", &Interpreter::eval_inspect},
{"load-file", &Interpreter::eval_load_file},
{"eq?", &Interpreter::eval_equals},
{"gensym", &Interpreter::eval_gensym},
{"eval", &Interpreter::eval_eval},
{"cons", &Interpreter::eval_cons},
{"car", &Interpreter::eval_car},
{"cdr", &Interpreter::eval_cdr},
{"set-car!", &Interpreter::eval_set_car},
{"set-cdr!", &Interpreter::eval_set_cdr},
{"+", &Interpreter::eval_plus},
{"-", &Interpreter::eval_minus},
{"*", &Interpreter::eval_times},
{"/", &Interpreter::eval_divide},
{"=", &Interpreter::eval_numequals},
{"<", &Interpreter::eval_lt},
{">", &Interpreter::eval_gt},
{"<=", &Interpreter::eval_leq},
{">=", &Interpreter::eval_geq},
{"null?", &Interpreter::eval_null},
{"type?", &Interpreter::eval_type},
{"current-method-type", &Interpreter::eval_current_method_type},
{"fmt", &Interpreter::eval_format},
{"error", &Interpreter::eval_error}};
string_to_type = {{"empty-list", ObjectType::EMPTY_LIST},
{"integer", ObjectType::INTEGER},

6
common/goos/Interpreter.h
View File

@ -180,6 +180,12 @@ class Interpreter {
Object eval_current_method_type(const Object& form,
Arguments& args,
const std::shared_ptr<EnvironmentObject>& env);
Object eval_format(const Object& form,
Arguments& args,
const std::shared_ptr<EnvironmentObject>& env);
Object eval_error(const Object& form,
Arguments& args,
const std::shared_ptr<EnvironmentObject>& env);
// specials
Object eval_define(const Object& form,

51
common/goos/InterpreterEval.cpp
View File

@ -3,6 +3,7 @@
* Implementation of built-in GOOS functions.
*/
#include <third-party/fmt/format.h>
#include "Interpreter.h"
namespace goos {
@ -586,4 +587,54 @@ Object Interpreter::eval_current_method_type(const Object& form,
vararg_check(form, args, {}, {});
return SymbolObject::make_new(reader.symbolTable, goal_to_goos.enclosing_method_type);
}
Object Interpreter::eval_format(const Object& form,
Arguments& args,
const std::shared_ptr<EnvironmentObject>& env) {
(void)env;
if (args.unnamed.size() < 2) {
throw_eval_error(form, "format must get at least two arguments");
}
auto dest = args.unnamed.at(0);
auto format_str = args.unnamed.at(1);
if (!format_str.is_string()) {
throw_eval_error(form, "format string must be a string");
}
// Note: this might be relying on internal implementation details of libfmt to work properly
// and isn't a great solution.
std::vector<fmt::basic_format_arg<fmt::format_context>> args2;
std::vector<std::string> strings;
for (size_t i = 2; i < args.unnamed.size(); i++) {
if (args.unnamed.at(i).is_string()) {
strings.push_back(args.unnamed.at(i).as_string()->data);
} else {
strings.push_back(args.unnamed.at(i).print());
}
}
for (auto& x : strings) {
args2.push_back(fmt::detail::make_arg<fmt::format_context>(x));
}
auto formatted =
fmt::vformat(format_str.as_string()->data,
fmt::format_args(args2.data(), static_cast<unsigned>(args2.size())));
if (truthy(dest)) {
printf("%s", formatted.c_str());
}
return StringObject::make_new(formatted);
}
Object Interpreter::eval_error(const Object& form,
Arguments& args,
const std::shared_ptr<EnvironmentObject>& env) {
(void)env;
vararg_check(form, args, {ObjectType::STRING}, {});
throw_eval_error(form, "Error: " + args.unnamed.at(0).as_string()->data);
return EmptyListObject::make_new();
}
} // namespace goos

2
common/type_system/TypeSystem.cpp
View File

@ -577,7 +577,7 @@ void TypeSystem::add_builtin_types() {
// Methods and Fields
// OBJECT
add_method(obj_type, "new", make_function_typespec({"symbol", "type", "int32"}, "_type_"));
add_method(obj_type, "new", make_function_typespec({"symbol", "type", "int"}, "_type_"));
add_method(obj_type, "delete", make_function_typespec({"_type_"}, "none"));
add_method(obj_type, "print", make_function_typespec({"_type_"}, "_type_"));
add_method(obj_type, "inspect", make_function_typespec({"_type_"}, "_type_"));

4
common/versions.h
View File

@ -12,8 +12,8 @@
namespace versions {
// language version
constexpr s32 GOAL_VERSION_MAJOR = 2;
constexpr s32 GOAL_VERSION_MINOR = 6;
constexpr s32 GOAL_VERSION_MAJOR = 0;
constexpr s32 GOAL_VERSION_MINOR = 1;
} // namespace versions
// GOAL kernel version

21
doc/changelog.md Normal file
View File

@ -0,0 +1,21 @@
# Language Changes
## V0.1
- The GOAL language version has been set to 0.1
- Calling a function with unknown argument/return types is now an error instead of a warning
- Getting a method of an object or type with `method` returns the correct type for methods using the `_type_` feature
- The `object-new` macro will now type check arguments
- The size argument to `(method object new)` is now an `int` instead of `int32`
- Using `set!` incorrectly, like `(set! 1 2)` will now create an error instead of having no effect
- GOOS now has a `fmt` form which wraps `libfmt` for doing string formatting.
- GOOS now has an `error` form for throwing an error with a string to describe it
- GOAL `if` now throws errors on extra arguments instead of silently ignoring them
- The first 1 MB of GOAL memory now cannot be read/written/executed so dereferencing a GOAL null pointer will now segfault
- The runtime now accepts command line boot arguments
- The runtime now defaults to loading `KERNEL.CGO` and using its `kernel-dispatcher` function.
- The runtime now accepts a `-nokernel` parameter for running without `KERNEL.CGO`.
- The runtime will now refuse to load object files from another major GOAL version
- Using `&+` and `&+!` now produces a pointer with the same type as the original.
- There is a `&-` which returns a `uint` and works with basically any input types
- The `&` operator works on fields and elements in arrays
- The `&->` operator has been added

6
game/kernel/kboot.cpp
View File

@ -47,12 +47,15 @@ u32 DebugSegment;
// Set to 1 to load game engine after boot automatically
u32 DiskBoot;
u32 MasterUseKernel;
void kboot_init_globals() {
strcpy(DebugBootLevel, "#f"); // no specified level
strcpy(DebugBootMessage, "play"); // play mode, the default retail mode
MasterExit = 0;
MasterDebug = 1;
MasterUseKernel = 1;
DebugSegment = 1;
DiskBoot = 0;
memset(&masterConfig, 0, sizeof(MasterConfig));
@ -117,6 +120,9 @@ s32 goal_main(int argc, const char* const* argv) {
if (InitMachine() >= 0) { // init kernel
KernelCheckAndDispatch(); // run kernel
ShutdownMachine(); // kernel died, we should too.
} else {
fprintf(stderr, "InitMachine failed\n");
exit(1);
}
return 0;

2
game/kernel/kboot.h
View File

@ -75,6 +75,6 @@ void KernelCheckAndDispatch();
*/
void KernelShutdown();
constexpr bool MasterUseKernel = false;
extern u32 MasterUseKernel;
#endif // RUNTIME_KBOOT_H

9
game/kernel/klink.cpp
View File

@ -8,6 +8,7 @@
#include <cstring>
#include <cassert>
#include <common/versions.h>
#include "klink.h"
#include "fileio.h"
#include "kscheme.h"
@ -67,6 +68,14 @@ void link_control::begin(Ptr<uint8_t> object_file,
m_segment_process = 0;
ObjectFileHeader* ofh = m_link_block_ptr.cast<ObjectFileHeader>().c();
if (ofh->goal_version_major != versions::GOAL_VERSION_MAJOR) {
fprintf(
stderr,
"VERSION ERROR: C Kernel built from GOAL %d.%d, but object file %s is from GOAL %d.%d\n",
versions::GOAL_VERSION_MAJOR, versions::GOAL_VERSION_MINOR, name, ofh->goal_version_major,
ofh->goal_version_minor);
exit(0);
}
if (link_debug_printfs) {
printf("Object file header:\n");
printf(" GOAL ver %d.%d obj %d len %d\n", ofh->goal_version_major, ofh->goal_version_minor,

6
game/kernel/kmachine.cpp
View File

@ -94,6 +94,12 @@ void InitParms(int argc, const char* const* argv) {
reboot = 0;
}
// an added mode to allow booting without a KERNEL.CGO for testing
if (arg == "-nokernel") {
Msg(6, "dkernel: no kernel mode\n");
MasterUseKernel = false;
}
// GOAL Settings
// ----------------------------

18
game/runtime.cpp
View File

@ -49,6 +49,9 @@ u8* g_ee_main_mem = nullptr;
namespace {
int g_argc = 0;
char** g_argv = nullptr;
/*!
* SystemThread function for running the DECI2 communication with the GOAL compiler.
*/
@ -98,10 +101,6 @@ constexpr u64 EE_MAIN_MEM_MAP = 0x2000000000; // intentionally > 32-bit to
// so this should be used only for debugging.
constexpr bool EE_MEM_LOW_MAP = false;
// GOAL Boot arguments
constexpr const char* GOAL_ARGV[] = {"", "-fakeiso", "-boot", "-debug"};
constexpr int GOAL_ARGC = 4;
/*!
* SystemThread Function for the EE (PS2 Main CPU)
*/
@ -132,6 +131,11 @@ void ee_runner(SystemThreadInterface& iface) {
printf("[EE] Run!\n");
memset((void*)g_ee_main_mem, 0, EE_MAIN_MEM_SIZE);
// prevent access to the first 1 MB of memory.
// On the PS2 this is the kernel and can't be accessed either.
// this may not work well on systems with a page size > 1 MB.
mprotect((void*)g_ee_main_mem, 1024 * 1024, PROT_NONE);
fileio_init_globals();
kboot_init_globals();
kdgo_init_globals();
@ -146,7 +150,7 @@ void ee_runner(SystemThreadInterface& iface) {
kmemcard_init_globals();
kprint_init_globals();
goal_main(GOAL_ARGC, GOAL_ARGV);
goal_main(g_argc, g_argv);
printf("[EE] Done!\n");
// // kill the IOP todo
@ -224,8 +228,8 @@ void iop_runner(SystemThreadInterface& iface) {
* Arguments are currently ignored.
*/
u32 exec_runtime(int argc, char** argv) {
(void)argc;
(void)argv;
g_argc = argc;
g_argv = argv;
// step 1: sce library prep
iop::LIBRARY_INIT();

2
gk.sh
View File

@ -3,4 +3,4 @@
# Directory of this script
DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null 2>&1 && pwd )"
$DIR/build/game/gk "$@"
$DIR/build/game/gk -fakeiso -debug -nokernel

36
goal_src/goal-lib.gc
View File

@ -191,8 +191,11 @@
`(set! ,place (+ ,place ,amount))
)
;; todo, handle too many arguments correct
(defmacro if (condition true-case &rest others)
(if (> (length others) 1)
(error "got too many arguments to if")
#f
)
(if (null? others)
`(cond (,condition ,true-case))
`(cond (,condition ,true-case)
@ -289,6 +292,18 @@
`(eq? ,thing 0)
)
(defmacro &+! (val amount)
`(set! ,val (&+ ,val ,amount))
)
(defmacro &- (a b)
`(- (the-as uint ,a) (the-as uint ,b))
)
(defmacro &-> (&rest args)
`(& (-> ,@args))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Bit Macros
;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -296,21 +311,6 @@
`(logand #xfffffff0 (+ (the-as integer ,value) 15))
)
(defmacro &+ (v1 &rest args)
(if (null? args)
`(the pointer ,v1)
`(&+ (+ (the-as int ,v1) (the-as int ,(first args))) ,@(cdr args))
)
)
(defmacro &- (v1 v2)
`(the pointer (- (the-as int ,v1) (the-as int ,v2)))
)
(defmacro &+! (v1 v2)
`(set! ,v1 (&+ ,v1 ,v2))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TYPE STUFF
@ -368,8 +368,8 @@
(defmacro object-new (&rest sz)
(if (null? sz)
`(the ,(current-method-type) ((-> object method-table 0) allocation type-to-make (-> type-to-make asize)))
`(the ,(current-method-type) ((-> object method-table 0) allocation type-to-make ,@sz))
`(the ,(current-method-type) ((method object new) allocation type-to-make (the int (-> type-to-make size))))
`(the ,(current-method-type)((method object new) allocation type-to-make ,@sz))
)
)

2
goal_src/kernel-defs.gc
View File

@ -101,7 +101,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; *listener-link-block*
;; *listener-function*
(define-extern *listener-function* (function object))
;; kernel-dispatcher
;; kernel-packages
;; *print-column*

2
goal_src/kernel/gcommon.gc
View File

@ -582,7 +582,7 @@
"Create a new inline-array. Sets the length, allocated-length to cnt. Uses the mysterious heap-base field
of the type-to-make to determine the element size"
(let* ((sz (+ (-> type-to-make size) (* (-> type-to-make heap-base) cnt)))
(new-object (object-new sz)))
(new-object (object-new (the int sz))))
;;(format 0 "create sz ~d at #x~X~%" sz new-object)
(unless (zero? new-object)
(set! (-> new-object length) cnt)

2
goal_src/kernel/gkernel-h.gc
View File

@ -5,3 +5,5 @@
;; name in dgo: gkernel-h
;; dgos: KERNEL
(defglobalconstant *kernel-major-version* 2)
(defglobalconstant *kernel-minor-version* 0)

20
goal_src/kernel/gkernel.gc
View File

@ -5,3 +5,23 @@
;; name in dgo: gkernel
;; dgos: KERNEL
(define *kernel-version* (the binteger (logior (ash *kernel-major-version* 16) *kernel-minor-version*)))
(defun kernel-dispatcher ()
"Kernel Dispatcher Function. This gets called from the main loop in kboot.cpp's KernelCheckAndDispatch"
;; check if we have a new listener function to run
(when *listener-function*
;; we do! enable method-set for debug purposes
(+! *enable-method-set* 1)
;; execute and print result
(let ((result (*listener-function*)))
(format #t "~D~%" result)
)
(+! *enable-method-set* -1)
;; clear the pending function.
(set! *listener-function* (the (function object) #f))
)
)

53
goal_src/kernel/gstring.gc
View File

@ -5,3 +5,56 @@
;; name in dgo: gstring
;; dgos: KERNEL
;; Note on strings:
;; the allocated length does not include an extra byte on the end for the null terminator!
(defmethod length string ((obj string))
; Get the length of a string. Like strlen
(let ((str-ptr (-> obj data)))
(while (!= 0 (-> str-ptr 0))
(set! str-ptr (the (pointer uint8) (&+ str-ptr 1)))
)
(- (the int str-ptr) (the int (-> obj data)))
)
)
(defmethod asize-of string ((obj string))
;; get the size in bytes of a string.
;; BUG - string should probably be (-> obj type), not that it matters, I don't think
;; anybody makes a subclass of string.
(+ (-> obj allocated-length) 1 (-> string size))
)
(defun copy-string<-string ((dst string) (src string))
"Copy data from one string to another, like strcpy"
(let ((dst-ptr (-> dst data))
(src-ptr (-> src data))
)
(while (!= 0 (-> src-ptr))
(set! (-> dst-ptr) (-> src-ptr))
(&+! dst-ptr 1)
(&+! src-ptr 1)
)
)
)
(defmethod new string ((allocation symbol) (type-to-make type) (size int) (other string))
"Create a new string of the given size. If other is not #f, copy data from it."
(cond
(other
(let* ((desired-size (max (length other) size))
(new-obj (object-new (+ desired-size 1 (-> type-to-make size))))
)
(set! (-> new-obj allocated-length) size)
(copy-string<-string new-obj other)
new-obj
)
)
(else
(let ((new-obj (object-new (+ 1 size (-> type-to-make size)))))
(set! (-> new-obj allocated-length) size)
new-obj
)
)
)
)

5
goal_src/test/test-access-inline-array.gc
View File

@ -1,6 +1,5 @@
(let* ((new-method (-> bfloat method-table 0))
(print-method (-> bfloat method-table 2))
(my-float (the bfloat (new-method 'global bfloat)))
(let* ((print-method (method bfloat print))
(my-float (new 'global 'bfloat))
)
(set! (-> my-float data) 1.23456)
(print-method my-float)

15
goal_src/test/test-addr-of.gc Normal file
View File

@ -0,0 +1,15 @@
(start-test "addr-of")
(deftype addr-of-test-type (basic)
((v1 int32 :offset-assert 4)
(arr int32 12 :offset-assert 8)
(end uint8 :offset-assert 56)
)
)
(let ((temp (new 'global 'addr-of-test-type)))
(expect-true (= 8 (&- (&-> temp arr 1) temp)))
(expect-true (= 0 (&- (&-> temp v1) temp)))
)
(finish-test)

4
goal_src/test/test-basic-type-check.gc
View File

@ -1,6 +1,4 @@
(define-extern hack-bfloat integer)
(define hack-bfloat (+ #x6000000 4))
(define-extern hack-bfloat bfloat)
(define hack-bfloat (new 'global 'bfloat))
(format #t "~A~A~A~A"

5
goal_src/test/test-bfloat.gc
View File

@ -1,7 +1,4 @@
;; awful hack to create a bfloat
(define-extern hack-bfloat integer)
(define hack-bfloat (+ #x6000000 4))
(define-extern hack-bfloat bfloat)
(define hack-bfloat (new 'global 'bfloat))
(set! (-> hack-bfloat type) bfloat)
(set! (-> hack-bfloat data) 1.233)

4
goal_src/test/test-dynamic-type.gc
View File

@ -15,7 +15,7 @@
;"Create a new inline-array. Sets the length, allocated-length to cnt. Uses the mysterious heap-base field
;of the type-to-make to determine the element size"
(let* ((sz (+ (-> type-to-make size) (* 4 cnt)))
(new-object (object-new sz)))
(new-object (object-new (the int sz))))
;;(format 0 "create sz ~d at #x~X~%" sz new-object)
(unless (zero? new-object)
(set! (-> new-object allocated-length) cnt)
@ -39,7 +39,7 @@
)
(define test-dynamic-obj
(the test-dynamic-type ((-> test-dynamic-type method-table 0) 'global test-dynamic-type 40)))
(the test-dynamic-type (new 'global 'test-dynamic-type 40)))
; ;(define test-dynamic-obj (new 'global 'test-dynamic-type 40))

12
goal_src/test/test-new-string.gc Normal file
View File

@ -0,0 +1,12 @@
(start-test "new-string")
(let ((new-string (new 'global 'string 17 "alligator")))
(expect-true (= 17 (-> new-string allocated-length)))
(expect-true (= 9 (length new-string)))
(expect-true (= #x61 (-> new-string data 0))) ;; a
(expect-true (= #x72 (-> new-string data 8))) ;; r
(expect-true (= #x00 (-> new-string data 9))) ;; \0
)
(finish-test)

11
test/old_goal_tests/tests/test-set-self.gc → goal_src/test/test-set-self.gc
View File

@ -1,20 +1,17 @@
(test-setup 12 #f)
(deftype self-test-type (basic)
((self self-test-type))
((self basic))
)
(defmethod new self-test-type ((allocation symbol) (type-to-make type))
(let ((obj (object-new)))
;; here the register of obj is used both as a "real" pointer and a GOAL pointer in the same instruction.
;; this is a special case in the emitter.
;; this was a tricky thing to get right in the old compiler, so its worth testing.
(set! (-> obj self) obj)
obj
)
)
(let ((temp (new 'global 'self-test-type)))
(expect-true (eq? temp (-> temp self)))
(format #t "~A~%" (eq? temp (-> temp self)))
)
12
0

17
goal_src/test/test-string-type.gc Normal file
View File

@ -0,0 +1,17 @@
(start-test "string-type")
; (db)
(expect-true (= 101 (-> "test" data 1)))
(expect-true (= 4 (-> "test" allocated-length)))
(expect-true (= 13 (asize-of "test")))
(let ((temp "test"))
; (format #t "before: ~D ~D~%" (-> temp data 1) (-> temp data 2))
(set! (-> temp data 1) 102)
;(format #t "after: ~D ~D~%" (-> temp data 1) (-> temp data 2))
; (print-type (-> temp data 1))
(set! (-> temp data 3) 0)
; (format #t "length is ~D~%" (length temp))
; (inspect temp)
(expect-true (= 3 (length temp)))
)
(finish-test)

15
goal_src/test/test-type-arrays.gc
View File

@ -1,10 +1,5 @@
(start-test "test-type-arrays")
(defmacro new-type-hack (type-name)
`(the ,type-name ((-> ,type-name method-table 0) 'global ,type-name))
)
(deftype basic-type (basic)
(
(flt float)
@ -21,7 +16,7 @@
)
)
(let ((obj-test (new-type-hack struct-type)))
(let ((obj-test (new 'global 'struct-type)))
;(inspect obj-test)
(set! (-> obj-test dec) #x00f0f0f0)
(set! (-> obj-test flt) 123.456)
@ -41,8 +36,8 @@
)
(let ((obj000 (new-type-hack type000))
(bo (new-type-hack basic-type))
(let ((obj000 (new 'global 'type000))
(bo (new 'global 'basic-type))
)
(set! (-> obj000 x) bo)
(expect-eq (-> obj000 x type) basic-type)
@ -58,8 +53,8 @@
)
(let ((obj001 (new-type-hack type001))
(sub-obj (new-type-hack struct-type)))
(let ((obj001 (new 'global 'type001))
(sub-obj (new 'global 'struct-type)))
;;(inspect obj001)
(set! (-> obj001 x) sub-obj)
(set! (-> obj001 x dec) 12)

2
goalc/compiler/Compiler.h
View File

@ -166,6 +166,7 @@ class Compiler {
Val* compile_lognot(const goos::Object& form, const goos::Object& rest, Env* env);
Val* compile_logand(const goos::Object& form, const goos::Object& rest, Env* env);
Val* compile_logior(const goos::Object& form, const goos::Object& rest, Env* env);
Val* compile_pointer_add(const goos::Object& form, const goos::Object& rest, Env* env);
// Function
Val* compile_lambda(const goos::Object& form, const goos::Object& rest, Env* env);
@ -183,6 +184,7 @@ class Compiler {
Val* compile_car(const goos::Object& form, const goos::Object& rest, Env* env);
Val* compile_cdr(const goos::Object& form, const goos::Object& rest, Env* env);
Val* compile_method(const goos::Object& form, const goos::Object& rest, Env* env);
Val* compile_addr_of(const goos::Object& form, const goos::Object& rest, Env* env);
};
#endif // JAK_COMPILER_H

2
goalc/compiler/StaticObject.cpp
View File

@ -40,7 +40,7 @@ void StaticString::generate(emitter::ObjectGenerator* gen) {
}
// add allocated size
push_data_to_byte_vector<u32>(text.size() + 1, d);
push_data_to_byte_vector<u32>(text.size(), d);
// add chars
for (auto c : text) {

4
goalc/compiler/Val.h
View File

@ -85,7 +85,9 @@ class RegVal : public Val {
*/
class SymbolVal : public Val {
public:
SymbolVal(std::string name, TypeSpec ts) : Val(std::move(ts)), m_name(std::move(name)) {}
SymbolVal(std::string name, TypeSpec ts) : Val(std::move(ts)), m_name(std::move(name)) {
mark_as_settable();
}
const std::string& name() const { return m_name; }
std::string print() const override { return "<" + m_name + ">"; }
RegVal* to_reg(Env* fe) override;

16
goalc/compiler/compilation/Atoms.cpp
View File

@ -57,7 +57,7 @@ static const std::unordered_map<
{"defmethod", &Compiler::compile_defmethod},
// {"defenum", &Compiler::compile_defenum},
{"->", &Compiler::compile_deref},
// {"&", &Compiler::compile_addr_of},
{"&", &Compiler::compile_addr_of},
{"the-as", &Compiler::compile_the_as},
{"the", &Compiler::compile_the},
{"print-type", &Compiler::compile_print_type},
@ -106,6 +106,7 @@ static const std::unordered_map<
{">=", &Compiler::compile_condition_as_bool},
{"<", &Compiler::compile_condition_as_bool},
{">", &Compiler::compile_condition_as_bool},
{"&+", &Compiler::compile_pointer_add},
// BUILDER (build-dgo/build-cgo?)
{"build-dgos", &Compiler::compile_build_dgo},
@ -306,4 +307,17 @@ Val* Compiler::compile_float(float value, Env* env, int seg) {
auto fie = get_parent_env_of_type<FileEnv>(env);
fie->add_static(std::move(obj));
return result;
}
Val* Compiler::compile_pointer_add(const goos::Object& form, const goos::Object& rest, Env* env) {
auto args = get_va(form, rest);
va_check(form, args, {{}, {}}, {});
auto first = compile_error_guard(args.unnamed.at(0), env)->to_gpr(env);
typecheck(form, m_ts.make_typespec("pointer"), first->type(), "&+ first argument");
auto second = compile_error_guard(args.unnamed.at(1), env)->to_gpr(env);
typecheck(form, m_ts.make_typespec("integer"), second->type(), "&+ second argument");
auto result = env->make_gpr(first->type());
env->emit(std::make_unique<IR_RegSet>(result, first));
env->emit(std::make_unique<IR_IntegerMath>(IntegerMathKind::ADD_64, result, second));
return result;
}

16
goalc/compiler/compilation/Define.cpp
View File

@ -46,6 +46,10 @@ Val* Compiler::compile_define(const goos::Object& form, const goos::Object& rest
typecheck(form, existing_type->second, in_gpr->type(), "define on existing symbol");
}
if (!sym_val->settable()) {
throw_compile_error(
form, "Tried to use define on something that wasn't settable: " + sym_val->print());
}
fe->emit(std::make_unique<IR_SetSymbolValue>(sym_val, in_gpr));
return in_gpr;
}
@ -111,6 +115,10 @@ Val* Compiler::compile_set(const goos::Object& form, const goos::Object& rest, E
auto sym_val =
fe->alloc_val<SymbolVal>(symbol_string(destination), m_ts.make_typespec("symbol"));
auto result_in_gpr = source->to_gpr(env);
if (!sym_val->settable()) {
throw_compile_error(
form, "Tried to use set! on something that wasn't settable: " + sym_val->print());
}
env->emit(std::make_unique<IR_SetSymbolValue>(sym_val, result_in_gpr));
return result_in_gpr;
}
@ -118,6 +126,10 @@ Val* Compiler::compile_set(const goos::Object& form, const goos::Object& rest, E
} else {
// destination is some complex expression, so compile it and hopefully get something settable.
auto dest = compile_error_guard(destination, env);
if (!dest->settable()) {
throw_compile_error(form,
"Tried to use set! on something that wasn't settable: " + dest->print());
}
auto as_mem_deref = dynamic_cast<MemoryDerefVal*>(dest);
auto as_pair = dynamic_cast<PairEntryVal*>(dest);
if (as_mem_deref) {
@ -126,13 +138,13 @@ Val* Compiler::compile_set(const goos::Object& form, const goos::Object& rest, E
auto base_as_mco = dynamic_cast<MemoryOffsetConstantVal*>(base);
if (base_as_mco) {
// if it is a constant offset, we can use a fancy x86-64 addressing mode to simplify
auto ti = m_ts.lookup_type(base->type());
auto ti = m_ts.lookup_type(as_mem_deref->type());
env->emit(std::make_unique<IR_StoreConstOffset>(
source, base_as_mco->offset, base_as_mco->base->to_gpr(env), ti->get_load_size()));
return source;
} else {
// nope, the pointer to dereference is some compliated thing.
auto ti = m_ts.lookup_type(base->type());
auto ti = m_ts.lookup_type(as_mem_deref->type());
env->emit(std::make_unique<IR_StoreConstOffset>(source, 0, base->to_gpr(env),
ti->get_load_size()));
return source;

9
goalc/compiler/compilation/Function.cpp
View File

@ -417,12 +417,9 @@ Val* Compiler::compile_real_function_call(const goos::Object& form,
fe->require_aligned_stack();
TypeSpec return_ts;
if (function->type().arg_count() == 0) {
// if the type system doesn't know what the function will return, just make it object.
// the user is responsible for getting this right.
return_ts = m_ts.make_typespec("object");
gLogger.log(MSG_WARN, "[Warning] Function call could not determine return type: %s, %s, %s\n",
form.print().c_str(), function->print().c_str(), function->type().print().c_str());
// todo, consider making this an error once object-new works better.
// if the type system doesn't know what the function will return, don't allow it to be called
throw_compile_error(
form, "This function call has unknown argument and return types and cannot be called");
} else {
return_ts = function->type().last_arg();
}

38
goalc/compiler/compilation/Type.cpp
View File

@ -13,6 +13,7 @@ RegVal* Compiler::compile_get_method_of_type(const TypeSpec& type,
const std::string& method_name,
Env* env) {
auto info = m_ts.lookup_method(type.base_type(), method_name);
info.type = info.type.substitute_for_method_call(type.base_type());
auto offset_of_method = get_offset_of_method(info.id);
auto fe = get_parent_env_of_type<FunctionEnv>(env);
@ -38,6 +39,7 @@ RegVal* Compiler::compile_get_method_of_object(RegVal* object,
Env* env) {
auto& compile_time_type = object->type();
auto method_info = m_ts.lookup_method(compile_time_type.base_type(), method_name);
method_info.type = method_info.type.substitute_for_method_call(compile_time_type.base_type());
auto fe = get_parent_env_of_type<FunctionEnv>(env);
RegVal* runtime_type = nullptr;
@ -230,6 +232,7 @@ Val* Compiler::compile_deref(const goos::Object& form, const goos::Object& _rest
if (deref_info.mem_deref) {
result =
fe->alloc_val<MemoryDerefVal>(deref_info.result_type, result, MemLoadInfo(deref_info));
result->mark_as_settable();
} else {
assert(false);
}
@ -258,9 +261,11 @@ Val* Compiler::compile_deref(const goos::Object& form, const goos::Object& _rest
assert(di.can_deref);
assert(di.mem_deref);
result = fe->alloc_val<MemoryDerefVal>(di.result_type, loc, MemLoadInfo(di));
result->mark_as_settable();
} else {
result = fe->alloc_val<MemoryOffsetConstantVal>(field.type, result,
field.field.offset() + offset);
result->mark_as_settable();
// assert(false);
}
continue;
@ -282,9 +287,11 @@ Val* Compiler::compile_deref(const goos::Object& form, const goos::Object& _rest
assert(di.mem_deref);
assert(di.can_deref);
auto offset = compile_integer(di.stride, env)->to_gpr(env);
// todo, check for integer and avoid runtime multiply
env->emit(std::make_unique<IR_IntegerMath>(IntegerMathKind::IMUL_32, offset, index_value));
auto loc = fe->alloc_val<MemoryOffsetVal>(result->type(), result, offset);
result = fe->alloc_val<MemoryDerefVal>(di.result_type, loc, MemLoadInfo(di));
result->mark_as_settable();
} else {
throw_compile_error(form, "can't access array of type " + result->type().print());
}
@ -292,12 +299,27 @@ Val* Compiler::compile_deref(const goos::Object& form, const goos::Object& _rest
return result;
}
Val* Compiler::compile_addr_of(const goos::Object& form, const goos::Object& rest, Env* env) {
auto args = get_va(form, rest);
va_check(form, args, {{}}, {});
auto loc = compile_error_guard(args.unnamed.at(0), env);
auto as_mem_deref = dynamic_cast<MemoryDerefVal*>(loc);
if (!as_mem_deref) {
throw_compile_error(form, "Cannot take the address of this");
}
return as_mem_deref->base;
}
Val* Compiler::compile_the_as(const goos::Object& form, const goos::Object& rest, Env* env) {
auto args = get_va(form, rest);
va_check(form, args, {{}, {}}, {});
auto desired_ts = parse_typespec(args.unnamed.at(0));
auto base = compile_error_guard(args.unnamed.at(1), env);
return get_parent_env_of_type<FunctionEnv>(env)->alloc_val<AliasVal>(desired_ts, base);
auto result = get_parent_env_of_type<FunctionEnv>(env)->alloc_val<AliasVal>(desired_ts, base);
if (base->settable()) {
result->mark_as_settable();
}
return result;
}
Val* Compiler::compile_the(const goos::Object& form, const goos::Object& rest, Env* env) {
@ -322,7 +344,11 @@ Val* Compiler::compile_the(const goos::Object& form, const goos::Object& rest, E
}
}
return get_parent_env_of_type<FunctionEnv>(env)->alloc_val<AliasVal>(desired_ts, base);
auto result = get_parent_env_of_type<FunctionEnv>(env)->alloc_val<AliasVal>(desired_ts, base);
if (base->settable()) {
result->mark_as_settable();
}
return result;
}
Val* Compiler::compile_print_type(const goos::Object& form, const goos::Object& rest, Env* env) {
@ -379,7 +405,9 @@ Val* Compiler::compile_car(const goos::Object& form, const goos::Object& rest, E
if (pair->type() != m_ts.make_typespec("object")) {
typecheck(form, m_ts.make_typespec("pair"), pair->type(), "Type of argument to car");
}
return fe->alloc_val<PairEntryVal>(m_ts.make_typespec("object"), pair, true);
auto result = fe->alloc_val<PairEntryVal>(m_ts.make_typespec("object"), pair, true);
result->mark_as_settable();
return result;
}
Val* Compiler::compile_cdr(const goos::Object& form, const goos::Object& rest, Env* env) {
@ -390,7 +418,9 @@ Val* Compiler::compile_cdr(const goos::Object& form, const goos::Object& rest, E
if (pair->type() != m_ts.make_typespec("object")) {
typecheck(form, m_ts.make_typespec("pair"), pair->type(), "Type of argument to cdr");
}
return fe->alloc_val<PairEntryVal>(m_ts.make_typespec("object"), pair, false);
auto result = fe->alloc_val<PairEntryVal>(m_ts.make_typespec("object"), pair, false);
result->mark_as_settable();
return result;
}
// todo, consider splitting into method-of-object and method-of-type?

4
goalc/gs/goos-lib.gs
View File

@ -122,6 +122,10 @@
(defsmacro string? (x)
`(type? 'string ,x))
(defsmacro ferror (&rest args)
`(error (fmt #f ,@args))
)
;; Bootstrap GOAL macro system

3
goalc/main.cpp
View File

@ -1,10 +1,11 @@
#include <cstdio>
#include "goalc/compiler/Compiler.h"
#include "common/versions.h"
int main(int argc, char** argv) {
(void)argc;
(void)argv;
printf("GOAL Compiler\n");
printf("OpenGOAL Compiler %d.%d\n", versions::GOAL_VERSION_MAJOR, versions::GOAL_VERSION_MINOR);
Compiler compiler;
compiler.execute_repl();

2
test/CMakeLists.txt
View File

@ -34,5 +34,5 @@ if(CMAKE_COMPILER_IS_GNUCXX AND CODE_COVERAGE)
setup_target_for_coverage_lcov(NAME goalc-test_coverage
EXECUTABLE goalc-test --gtest_color=yes
DEPENDENCIES goalc-test
EXCLUDE "third-party/*" "/usr/include/*")
EXCLUDE "third-party/*" "/usr/include/*" "decompiler/*")
endif()

44
test/old_goal_tests/goal-compiler-control.gc
View File

@ -1,44 +0,0 @@
;-*-Scheme-*-
;; This file is loaded as part of goal-lib.gc.
;; It should generate no code.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COMPILER CONTROL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TODO change me!!!
(defglobalconstant *compiler-output-path* "obj/")
;; a macro to compile the test file
(defmacro :t ()
`(asm-file "game/test.gc" :color)
)
;; a macro to compile and load the test file
(defmacro :tl ()
`(asm-file "game/test.gc" :color :load)
)
;; compile the gcommon code.
(defmacro :g ()
;`(asm-file "game/kernel/gcommon.gc" :color :write)
`(asm-file "game/kernel/gcommon.gc" :color)
)
;; compile and load the gcommon code.
(defmacro :gl ()
`(begin
(asm-file "game/kernel/gcommon.gc" :color :load)
)
)
;; compile, color, and save a file
(defmacro m (file)
`(asm-file ,file :color :write)
)
;; compile, color, load and save a file
(defmacro ml (file)
`(asm-file ,file :color :load :write)
)

7
test/old_goal_tests/goal-constants.gc
View File

@ -1,7 +0,0 @@
;-*-Scheme-*-
;; This file is loaded as part of goal-lib.gc.
;; It should generate no code.
(defglobalconstant M_PI 3.1415926589932)
(defglobalconstant *gtype-basic-offset* 4)

96
test/old_goal_tests/goal-externs.gc
View File

@ -1,96 +0,0 @@
;-*-Scheme-*-
;; This file is loaded as part of goal-lib.gc.
;; It should generate no code.
;; This is used to extern define all C Kernel functions and types.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Forward declare C Kernel Fixed Syms
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; '()
;; booleans
(define-extern #f boolean)
(define-extern #t boolean)
;; types
(define-extern function type)
(define-extern symbol type)
(define-extern basic type)
(define-extern string type)
(define-extern type type)
(define-extern object type)
(define-extern link-block type)
(define-extern integer type)
(define-extern sinteger type)
(define-extern uinteger type)
(define-extern binteger type)
(define-extern int8 type)
(define-extern int16 type)
(define-extern int32 type)
(define-extern int64 type)
(define-extern int128 type)
(define-extern uint8 type)
(define-extern uint16 type)
(define-extern uint32 type)
(define-extern uint64 type)
(define-extern uint128 type)
(define-extern float type)
(define-extern process-tree type)
(define-extern process type)
(define-extern thread type)
(define-extern structure type)
(define-extern pair type)
(define-extern pointer type)
(define-extern number type)
(define-extern array type)
(define-extern vu-function type)
(define-extern connectable type)
(define-extern stack-frame type)
(define-extern file-stream type)
(define-extern kheap type)
;; functions
(defun-extern nothing () none)
;; del basic
(define-extern static symbol)
(define-extern global object)
;;(define-extern debug kheap)
(define-extern loading-level symbol)
(define-extern loading-package symbol)
(define-extern process-level-heap symbol)
(define-extern stack symbol)
(define-extern scratch symbol)
;;(define-extern *scratch-top* pointer)
(defun-extern zero-func () int32)
(defun-extern method-set! ((x type) (y integer) (z function)) object)
;; todo - change allocation to a kheap
(defun-extern dgo-load ((name string) (allocation object) (flag integer) (buffer-size integer)) none)
(defun-extern *listener-function* () object)
(define-extern *enable-method-set* int32)
;; asizeo-of-bsic
;; copy-basic
;; level
;; art group
;; tx page dir
;; tx page
;; sound
;; dgo
;; top level
(defun-extern string->symbol ((x string)) symbol)
(defun-extern print ((x object)) object)
(defun-extern inspect ((x object)) object)
(define-extern test-function function)
(define-extern _format function)
;; for the compiler
(define-extern format function)
;; TODO - some others...
(define-extern *kernel-boot-message* symbol)
(define-extern *debug-segment* boolean)
;; for use by the compiler.
(defun-extern malloc ((allocation symbol) (size integer)) pointer)

100
test/old_goal_tests/goal-lib.gc
View File

@ -1,100 +0,0 @@
;-*-Scheme-*-
;; THE GOAL COMMON LIBRARY
;; before this is loaded into the compiler, GOOS needs to have loaded
;; goos-lib.gs. The goos-lib will insert some macros into GOAL's macro space
;; required for this to work.
;; WARNING - this file should generate NO CODE!
;; Any code which would be generated by this file is thrown out without warning!
;; Any "common" code should go in gcommon instead.
(asm-file "goal/gc/goal-test-defs.gc")
(asm-file "goal/gc/goal-target-control.gc")
(asm-file "goal/gc/goal-compiler-control.gc")
(asm-file "goal/gc/goal-syntax.gc")
(asm-file "goal/gc/goal-test-utils.gc")
(asm-file "goal/gc/goal-externs.gc")
(asm-file "goal/gc/goal-constants.gc")
(asm-file "goal/gc/goal-macros.gc")
(asm-file "builder/gc/builder.gc")
;; Ideally this file only contains the above asm-file statements
;; but below is a good spot for temporary hacks:
;; HACKS!
;; temp hack, this gets you the wrong type, and doesn't do good typechecking on the inputs
; (defmacro &+ (v1 v2)
; `(the pointer (+ (the integer ,v1) (the integer ,v2)))
; )
(defmacro &+ (v1 &rest args)
(if (null? args)
`(the pointer ,v1)
`(&+ (+ (the integer ,v1) (the integer ,(first args))) ,@(cdr args))
)
)
(defmacro &- (v1 v2)
`(the pointer (- (the integer ,v1) (the integer ,v2)))
)
(defmacro &+! (v1 v2)
`(set! ,v1 (&+ ,v1 ,v2))
)
;; macro to print a float.
(defmacro pf (flt)
`(format #t "~f~%" ,flt)
)
(defmacro ct ()
;; compiler test
`(begin
(build-game)
(set! fancy-listener-print #f)
(test)
(set! fancy-listener-print #t)
)
)
(defmacro tt ()
`(begin
(lt)
(asm-file "game/test.gc" :color :load)
)
)
(defmacro tn ()
`(begin
(asm-file "game/test.gc" :color)
)
)
(defmacro lm ()
`(begin
(build-game)
(asm-file "game/engine/math/math.gc" :color :load)
(set! fancy-listener-print #t)
)
)
(defmacro lg ()
`(begin
(dgo-load "game" global #xf #x200000)
))
(defmacro e ()
`(:exit)
)
;(test)
;; uncomment to run tests automatically on startup.
;; Useful for running the compiler in GDB where you can't easily type stuff.
;;:(:t)
;(build-game)
; (set-config! debug-print-obj #t)

23
test/old_goal_tests/goal-macros.gc
View File

@ -1,23 +0,0 @@
;-*-Scheme-*-
;; This file is loaded as part of goal-lib.gc.
;; It should generate no code.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; BIT STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro align16 (value)
`(logand #xfffffff0 (+ (the integer ,value) 15))
)
(defmacro &-> (&rest args)
`(& (-> ,@args))
)
(defmacro new-with-method (alloc type &rest args)
`(the ,type ((-> ,type methods 0) ,alloc ,type ,@args))
)
(defmacro symbol? (basic-obj)
`(eq? (-> ,basic-obj type) symbol)
)

355
test/old_goal_tests/goal-syntax.gc
View File

@ -1,355 +0,0 @@
;-*-Scheme-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; LEXICAL STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Bind vars in body
(defmacro let (bindings &rest body)
`((lambda :inline-only #t ,(apply first bindings) ,@body)
,@(apply second bindings)))
;; Let, but recursive, allowing you to define variables in terms of others.
(defmacro let* (bindings &rest body)
(if (null? bindings)
`(begin ,@body)
`((lambda :inline-only #t (,(caar bindings))
(let* ,(cdr bindings) ,@body))
,(car (cdar bindings))
)
)
)
;; Backup some values, and restore after executing body.
;; Non-dynamic (nonlocal jumps out of body will skip restore)
(defmacro protect (defs &rest body)
(if (null? defs)
;; nothing to backup, just insert body (base case)
`(begin ,@body)
;; a unique name for the thing we are backing up
(with-gensyms (backup)
;; store the original value of the first def in backup
`(let ((,backup ,(first defs)))
;; backup any other things which need backing up
(protect ,(cdr defs)
;; execute the body
,@body
)
;; restore the first thing
(set! ,(first defs) ,backup)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DEFINE STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Define a new function
(defmacro defun (name bindings &rest body)
(if (and
(> (length body) 1) ;; more than one thing in function
(string? (first body)) ;; first thing is a string
)
;; then it's a docstring and we ignore it.
`(define ,name (lambda :name ,name ,bindings ,@(cdr body)))
;; otherwise don't ignore it.
`(define ,name (lambda :name ,name ,bindings ,@body))
)
)
;; Define a new function, but only if we're debugging.
;; TODO - should place the function in the debug segment!
(defmacro defun-debug (name &rest args)
`(if *debug-segment*
(defun ,name ,@args) ;; debug data is loaded, define function in symbol table
(define ,name nothing) ;; function not loaded, set function to the nothing function.
)
)
;; By default, recursive functions don't work because the compiler doesn't
;; know the return type of a function until after the function is fully defined.
;; To get around this, this macro allows you to define a function + give a return type.
;; it simply forward declares the function with the given return, then defines the function as normal
;; if you got the return type wrong, the function definition conflicts with the forward dec
;; and throws an error.
(defmacro defun-recursive (name bindings return-type &rest body)
`(begin
(defun-extern ,name ,bindings ,return-type)
(define ,name (lambda :name ,name ,bindings
;; omit the doc-string if needed
,@(if (and (> (length body) 1) (string? (first body)))
(cdr body)
body
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CONDITIONAL COMPILATION
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro #when (clause &rest body)
`(#cond (,clause ,@body))
)
(defmacro #unless (clause &rest body)
`(#cond ((not ,clause) ,@body))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; MATH STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro +1 (var)
`(+ ,var 1)
)
(defmacro +! (place amount)
`(set! ,place (+ ,place ,amount))
)
(defmacro +1! (place)
`(set! ,place (+ 1 ,place))
)
(defmacro -! (place amount)
`(set! ,place (- ,place ,amount))
)
(defmacro *! (place amount)
`(set! ,place (* ,place ,amount))
)
(defmacro 1- (var)
`(- ,var 1)
)
(defmacro fabs (x)
`(if (> 0.0 ,x) (- ,x) ,x)
)
(defmacro fmin (a b)
`(if (> ,a ,b) ,b ,a)
)
(defmacro fmax (a b)
`(if (> ,a ,b) ,a ,b)
)
(defmacro true! (place)
`(set! ,place #t)
)
(defmacro false! (place)
`(set! ,place #f)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; CONTROL FLOW STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro if (condition true-case &rest others)
(if (null? others)
`(cond (,condition ,true-case))
`(cond (,condition ,true-case)
(else ,(first others))
)
)
)
(defmacro when (condition &rest body)
`(if ,condition
(begin ,@body)
)
)
(defmacro unless (condition &rest body)
`(if (not ,condition)
(begin ,@body)
)
)
; (defmacro while (test &rest body)
; (with-gensyms (reloop test-exit)
; `(begin
; (goto ,test-exit)
; (label ,reloop)
; ,@body
; (label ,test-exit)
; (when ,test
; (goto ,reloop)
; )
; )
; )
; )
(defmacro while (test &rest body)
(with-gensyms (reloop test-exit)
`(begin
(goto ,test-exit)
(label ,reloop)
,@body
(label ,test-exit)
(when-goto ,test ,reloop)
#f
)
)
)
(defmacro and (&rest args)
(with-gensyms (result end)
`(begin
(let ((,result (the object #f)))
,@(apply (lambda (x)
`(begin
(set! ,result ,x)
(if (eq? ,result #f)
(goto ,end)
)
)
)
args
)
(label ,end)
,result
)
)
)
)
(defmacro or (&rest args)
(with-gensyms (result end)
`(begin
(let ((,result (the object #f)))
,@(apply (lambda (x)
`(begin
(set! ,result ,x)
(if (not (eq? ,result #f))
(goto ,end)
)
)
)
args
)
(label ,end)
,result
)
)
)
)
(defmacro zero? (thing)
`(eq? ,thing 0)
)
(defmacro until (test &rest body)
(with-gensyms (reloop)
`(begin
(label ,reloop)
,@body
(when-goto (not ,test) ,reloop)
; (when (not ,test)
; (goto ,reloop)
; )
)
)
)
(defmacro dotimes (var &rest body)
`(let (( ,(first var) 0))
(while (< ,(first var) ,(second var))
,@body
(+1! ,(first var))
)
,@(cddr var)
)
)
(defmacro countdown (var &rest body)
`(let ((,(first var) ,(second var)))
(while (!= ,(first var) 0)
(set! ,(first var) (- ,(first var) 1))
,@body
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TYPE STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro basic? (obj)
;; todo, make this more efficient
`(= 4 (logand (the integer ,obj) #b111))
)
(defmacro pair? (obj)
;; todo, make this more efficient
`(= 2 (logand (the integer ,obj) #b111))
)
(defmacro binteger? (obj)
`(zero? (logand (the integer ,obj) #b111))
)
(defmacro rtype-of (obj)
`(cond ((binteger? ,obj) binteger)
((pair? ,obj) pair)
(else (-> (the basic ,obj) type))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; PAIR STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro cons (a b)
`(new 'global 'pair ,a ,b)
)
(defmacro list (&rest args)
(if (null? args)
(quote '())
`(cons ,(car args) (list ,@(cdr args)))
)
)
(defmacro null? (arg)
;; todo, make this better
`(if (eq? ,arg '())
#t
#f
)
)
(defmacro caar (arg)
`(car (car ,arg))
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; METHOD STUFF
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro object-new (&rest sz)
(if (null? sz)
`(the ,(current-method-type) ((-> object methods 0) allocation type-to-make (-> type-to-make asize)))
`(the ,(current-method-type) ((-> object methods 0) allocation type-to-make ,@sz))
)
)

30
test/old_goal_tests/goal-target-control.gc
View File

@ -1,30 +0,0 @@
;-*-Scheme-*-
;; GOAL Macros for interfacing with the target.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; TARGET CONTROL
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defmacro lt (&rest args)
;; shortcut for listen-to-target. also sends a :status command to make sure
;; all buffers on the target are flushed.
`(begin
(listen-to-target ,@args)
(:status)
)
)
(defmacro :r (&rest args)
;; shortcut to completely reset the target and connect, regardless of current state
`(begin
;; connect, so we can send reset. if we're already connected, does nothing
(listen-to-target ,@args)
;; send a reset message, disconnecting us
(reset-target)
;; establish connection again
(listen-to-target ,@args)
;; flush buffers
(:status)
)
)

134
test/old_goal_tests/goal-test-defs.gc
View File

@ -1,134 +0,0 @@
;; Definition of all GOAL tests
(defglobalconstant *goal-test-prefix* "goal/gc/tests/")
(defglobalconstant *goal-test-files*
(
"test-return-integer.gc"
"test-return-integer1.gc"
"test-return-integer2.gc"
"test-return-integer3.gc"
"test-return-integer4.gc"
"test-return-integer5.gc"
"test-return-integer6.gc"
"test-return-negative-integer.gc"
"test-conditional-compilation.gc"
"test-conditional-compilation-2.gc"
"test-define-1.gc"
"test-nested-blocks-1.gc"
;; up to here has been hand-checked for good code.
"test-nested-blocks-2.gc"
"test-nested-blocks-3.gc"
"test-goto-1.gc"
"test-defglobalconstant-1.gc"
"test-defglobalconstant-2.gc"
"test-simple-function-call.gc"
"test-application-lambda-1.gc"
"test-let-1.gc"
"test-let-star-1.gc"
"test-string-constant-1.gc"
"test-string-constant-2.gc"
"test-defun-return-constant.gc"
"test-defun-return-symbol.gc"
"test-function-return-arg-1.gc"
"test-nested-function-call.gc"
"test-add-int-constants.gc"
"test-add-int-vars.gc"
"test-add-int-multiple.gc"
"test-add-int-multiple-2.gc"
"test-add-function-returns.gc"
"test-sub-1.gc"
"test-sub-2.gc"
"test-mul-1.gc"
"test-declare-inline.gc"
"test-inline-call.gc"
"test-with-inline.gc"
"test-three-reg-add.gc"
"test-three-reg-sub.gc"
"test-three-reg-mult.gc"
"test-mlet.gc"
"test-set-symbol.gc"
"test-defun-extern.gc"
"test-defsmacro-defgmacro.gc"
"test-desfun.gc"
"test-factorial-recursive.gc"
"test-factorial-iterative.gc"
"test-div-1.gc"
"test-div-2.gc"
"test-protect.gc"
"test-shiftvs.gc"
"test-ash.gc"
"test-negative-integer-symbol.gc"
"test-mod.gc"
"test-nested-function-call-2.gc"
"test-load-gcommon.gc"
"test-quote-symbol.gc"
"test-min-max.gc"
"test-format-1.gc"
"test-float-product.gc"
"test-float-in-symbol.gc"
"test-function-return-constant-float.gc"
"test-float-function.gc"
"test-float-pow-function.gc"
"test-bfloat-1.gc"
"test-align16-1.gc"
"test-align16-2.gc"
"test-basic-type-check.gc"
"test-return-from-f.gc"
"test-return-from-f-tricky-color.gc"
"test-signed-int-compare.gc"
"test-condition-boolean.gc"
"test-return-value-of-if.gc"
"test-inline-array-field.gc"
"test-access-inline-array.gc"
"test-find-parent-method.gc"
"test-empty-pair.gc"
"test-pairp.gc"
"test-cons.gc"
"test-list.gc"
"test-car-cdr-get.gc"
"test-car-cdr-set.gc"
"test-nested-car-cdr-set.gc"
"test-dotimes.gc"
"test-ref.gc"
"test-pair-asize.gc"
"test-last.gc"
"test-pair-length.gc"
"test-member-1.gc"
"test-member-2.gc"
"test-assoc-1.gc"
"test-assoc-2.gc"
"test-assoce-1.gc"
"test-assoce-2.gc"
"test-append.gc"
"test-delete-list.gc"
"test-delete-car.gc"
"test-insert-cons.gc"
"test-sort.gc"
"test-new-inline-array-class.gc"
"test-pointer-as-array-numbers.gc"
"test-memcpy.gc"
"test-qmemcpy-down.gc"
"test-qmemcpy-up.gc"
"test-memset.gc"
"test-print-binteger.gc"
"test-type-arrays.gc"
"test-number-comparison.gc"
"test-approx-pi.gc"
"test-dynamic-type.gc"
"test-string-type.gc"
"test-new-string.gc"
"test-static-new-integer-field.gc"
"test-addr-of.gc"
"test-set-self.gc"
"test-asm-func.gc"
"test-methods.gc"
"test-bitfield-enums.gc"
"test-packed-inline-array.gc"
"test-fixed-shifts.gc"
"test-add-binteger.gc"
"test-bitfield-access.gc"
"test-bitfield-set1.gc"
)
)

39
test/old_goal_tests/goal-test-utils.gc
View File

@ -1,39 +0,0 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; COMPILER TEST
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; macro to set up the target and compiler for a test
(defmacro test-setup (expected-value reset-required)
`(begin
;; first, reboot and connect
;; this uses a "compile time" conditional, as (:r) does the reset when it is _compiled_.
;; so we want to compile the (:r) only if the reset is wanted.
(#when ,reset-required (:r))
;; set expected value in GOOS
(seval (define *test-expected* ,expected-value))
;; make sure that *test-result* is an object to avoid typing errors with future tests.
(define-extern *test-result* object)
)
)
(defmacro test-result (value)
value)
(defmacro expect (v1 v2)
`(if (not (eq? ,v1 ,v2))
(format #t "TEST FAILURE!~%")
)
)
(defmacro expect-true (value)
`(if (not (eq? ,value #t))
(format #t "TEST FAILTURE!~%")
)
)
(defmacro expect-false (value)
`(if (not (eq? ,value #f))
(format #t "TEST FAILTURE!~%")
)
)

19
test/old_goal_tests/tests/test-access-inline-array.gc
View File

@ -1,19 +0,0 @@
;-*-Scheme-*-
(test-setup 1.2345 #f)
(let* ((new-method (-> bfloat methods 0))
(print-method (-> bfloat methods 2))
(my-float (the bfloat (new-method 'global bfloat)))
)
(set! (-> my-float data) 1.23456)
(print-method my-float)
(format #t "~%")
)
(let ((x 0))
(while (< x 9)
(format #t "method ~d of ~A is ~A~%" x bfloat (-> bfloat methods x))
(+1! x)
)
)

3
test/old_goal_tests/tests/test-add-binteger.gc
View File

@ -1,3 +0,0 @@
(test-setup -13 #f)
(printl (+ (the binteger -3) -10))

23
test/old_goal_tests/tests/test-add-function-returns.gc
View File

@ -1,23 +0,0 @@
;-*-Scheme-*-
;; various functions which add numbers, called in a big sum.
(test-setup 21 #f)
(defun return-one ()
1)
(defun return-sum ((a integer) (b integer))
(+ a b)
)
(defun return-plus-two ((in integer))
(+ in 2)
)
(defun return-plus-three ((in integer))
(+ 3 in)
)
(+ 2 (return-one) (return-plus-three 2) (return-plus-two 3) (return-sum 1 2) (return-plus-two 3))

8
test/old_goal_tests/tests/test-add-int-constants.gc
View File

@ -1,8 +0,0 @@
;-*-Scheme-*-
;; add two constants together.
(test-setup 13 #f)
(+ 15 -2)

19
test/old_goal_tests/tests/test-add-int-multiple-2.gc
View File

@ -1,19 +0,0 @@
;-*-Scheme-*-
(test-setup 15 #f)
;; add a bunch of numbers together in a single function, in a strange order.
(defun add-five-v2 ((a int32) (b int32) (c int32) (d int32) (e int32))
(let* ((total-1 a)
(also-d d)
(total-2 (+ total-1 b))
(total-3 (+ c total-2))
)
(+ total-3 e also-d)
)
)
(add-five 1 2 3 4 5)

13
test/old_goal_tests/tests/test-add-int-multiple.gc
View File

@ -1,13 +0,0 @@
;-*-Scheme-*-
(test-setup 15 #f)
;; add a bunch of numbers together in a single function.
(defun add-five ((a integer) (b integer) (c integer) (d integer) (e integer))
(+ c d (+ e a) b)
)
(add-five 1 2 3 4 5)

13
test/old_goal_tests/tests/test-add-int-vars.gc
View File

@ -1,13 +0,0 @@
;-*-Scheme-*-
(test-setup 7 #f)
;; add two numbers in a function
(defun add-two ((x integer) (y integer))
(+ x y)
)
(add-two 3 4)

13
test/old_goal_tests/tests/test-addr-of.gc
View File

@ -1,13 +0,0 @@
(test-setup 4 #f)
(deftype addr-of-test-type (basic)
((v1 int32 :offset 4)
(arr int32 12 :offset 8)
)
)
(let ((temp (new 'global 'addr-of-test-type)))
(expect-true (= 12 (- (the integer (&-> temp arr 1)) (the integer temp))))
(- (the integer (&-> temp v1)) (the integer temp))
)

6
test/old_goal_tests/tests/test-align16-1.gc
View File

@ -1,6 +0,0 @@
;-*-Scheme-*-
(test-setup 80 #f)
(+ (align16 1) (align16 (* 3 5)) (align16 (/ 32 2)) (align16 (- -17)))

10
test/old_goal_tests/tests/test-align16-2.gc
View File

@ -1,10 +0,0 @@
;-*-Scheme-*-
(test-setup 64 #f)
(defun type-method-check ((obj type))
(align16 (+ 28 (* 4 (-> obj num-methods))))
)
(type-method-check integer)

4
test/old_goal_tests/tests/test-append.gc
View File

@ -1,4 +0,0 @@
(test-setup '(a b c d e) #f)
(format #t "~A~%"
(append! (list 'a 'b) (list 'c 'd 'e)))

9
test/old_goal_tests/tests/test-application-lambda-1.gc
View File

@ -1,9 +0,0 @@
;-*-Scheme-*-
(test-setup 2 #f)
;; test an immediate lambda which does not generate code.
(define *test-result*
((lambda :inline-only #t (x y z) y) 1 2 3))
(test-result *test-result*)

52
test/old_goal_tests/tests/test-approx-pi.gc
View File

@ -1,52 +0,0 @@
(test-setup 1 #f)
(defun test-approx-pi ((res integer))
(let ((rad (* res res))
(count 0))
(dotimes (x res)
(dotimes (y res)
(if (> rad (+ (* x x) (* y y)))
(+! count 1)
)
)
)
(* 4.0 (/ (the float count) (the float rad)))
)
)
(let ((approx-pi (test-approx-pi 1000)))
(expect-true (> approx-pi 3.14))
(expect-true (< approx-pi 3.15))
)
(defun test-approx-pi-float ((res float))
(let* ((rad (the float (* res res)))
(count (the float 0))
(x (the float 0))
(y (the float 0))
(scale (/ 1.0 rad)))
(while (< x res)
(set! y 0.0)
(while (< y res)
; (format #t "tapf ~f ~f ~f~%" x y res)
(if (> rad (+ (* x x) (* y y)))
(+! count scale)
)
(+! y 1.0)
)
(+! x 1.0)
)
(* 4.0 count)
)
)
(let ((approx-pi (test-approx-pi-float 500.0)))
(expect-true (> approx-pi 3.14))
(expect-true (< approx-pi 3.15))
)
;(format #t "~f~%" (test-approx-pi 1000))
1

13
test/old_goal_tests/tests/test-ash.gc
View File

@ -1,13 +0,0 @@
;-*-Scheme-*-
(test-setup 18 #f)
(defun ash ((value integer) (shift-amount integer))
(if (> shift-amount 0)
(shlv value shift-amount)
(sarv value (- shift-amount))
)
)
(+ (ash (+ 1 2) (/ 6 2)) (ash (- 12) (- 1)))

19
test/old_goal_tests/tests/test-asm-func.gc
View File

@ -1,19 +0,0 @@
(test-setup 1234567 #f)
(defun test-asm-function ()
;; enable asm-func mode (DANGER)
(declare (asm-func))
;; now we have no prologue/epilogue.
;; most operations involving variables are unsafe.
;; create a "safe" variable which is the rax register
(rlet ((ret :reg rax :type integer))
;; set to a numeric constant
(set! ret 1234567)
)
;; and do a return manually
(.ret)
)
(test-asm-function)

7
test/old_goal_tests/tests/test-assoc-1.gc
View File

@ -1,7 +0,0 @@
(test-setup 'w #f)
(format #t "~A~%"
(cdr (assoc 'e (list (cons 'a 'b) (cons 'e 'w) (cons 'x 'x)))))
(print-type (assoc 'a '()))

4
test/old_goal_tests/tests/test-assoc-2.gc
View File

@ -1,4 +0,0 @@
(test-setup #f #f)
(format #t "~A~%"
(assoc 'r (list (cons 'a 'b) (cons 'e 'w) (cons 'x 'x))))

4
test/old_goal_tests/tests/test-assoce-1.gc
View File

@ -1,4 +0,0 @@
(test-setup 'x #f)
(format #t "~A~%"
(cdr (assoce 'r (list (cons 'a 'b) (cons 'e 'w) (cons 'else 'x)))))

4
test/old_goal_tests/tests/test-assoce-2.gc
View File

@ -1,4 +0,0 @@
(test-setup 'x #f)
(format #t "~A~%"
(cdr (assoce 'r (list (cons 'a 'b) (cons 'r 'x) (cons 'else 'w)))))

24
test/old_goal_tests/tests/test-basic-type-check.gc
View File

@ -1,24 +0,0 @@
;-*-Scheme-*-
(test-setup '#f#t#t#f#t#f#t#t #f)
;; awful hack to create a bfloat at #x6000000
(define-extern hack-bfloat integer)
(define hack-bfloat (+ #x6000000 *gtype-basic-offset*))
(define-extern hack-bfloat bfloat)
(format #t "~A~A~A~A"
(basic-type? hack-bfloat integer) ;; #f
(basic-type? hack-bfloat structure) ;; #t
(basic-type? integer type) ;; #t
(basic-type? hack-bfloat object) ;; #t
)
(format #t "~A~A~A~A~%"
(basic-type? integer basic) ;; t
(basic-type? integer integer) ;; #f
(basic-type? #f basic) ;; #t
(basic-type? inspect function) ;; #t
)

35
test/old_goal_tests/tests/test-bfloat-1.gc
View File

@ -1,35 +0,0 @@
;-*-Scheme-*-
(test-setup 1.2339 #f)
;; awful hack to create a bfloat at #x6000000
(define-extern hack-bfloat integer)
(define hack-bfloat (+ #x6000000 *gtype-basic-offset*))
(define-extern hack-bfloat bfloat)
;; we have to manually set the type field.
(set! (-> hack-bfloat type) bfloat)
;; set the data field
(set! (-> hack-bfloat data) 1.234)
(defun test-print-bfloat ((obj bfloat))
(format #t "~f~%" (-> obj data))
)
;; to make test pass
;;(format #t "~f~%" (-> hack-bfloat data))
(test-print-bfloat hack-bfloat)
;; try printing it as a basic (should use default basic printer)
(format #t "Here's a bfloat ~A~%" hack-bfloat)
;; or access the field directly and print as float
(format #t "Here's (-> flt data) ~f~%" (-> hack-bfloat data))
;; or inspect it (compiler should generate this method
(format #t "Here's its inspect~%~I~%" hack-bfloat)
(format #t "It's type is `~A`~%" (-> hack-bfloat type))

24
test/old_goal_tests/tests/test-bitfield-access.gc
View File

@ -1,24 +0,0 @@
(test-setup 'fffffffffffff344f213ffffffffffffffff #f)
(deftype test-bf-type (int32)
((f1 int16)
(f2 uint8)
(f3 int8 :size 3)
(f4 uint8 :size 2)
(f5 int8 :size 2)
)
)
(deftype test-bf-type2 (int64)
((f1 int16)
(f2 uint8)
(f3 float)
)
)
(let ((temp (the test-bf-type #xf9f2f344))
(temp2 (the test-bf-type2 #x133f456789012345)))
(expect-true (< (fabs (- 1.7711 (+ 1.0 (-> temp2 f3)))) 0.002))
; (format #t "diff is ~f~%" (fabs (- 1.711 (+ 1.0 (-> temp2 f3)))))
(format #t "~X~X~X~X~X~%" (-> temp f1) (-> temp f2) (-> temp f3) (-> temp f4) (-> temp f5))
)

9
test/old_goal_tests/tests/test-bitfield-enums.gc
View File

@ -1,9 +0,0 @@
(test-setup 5 #f)
(defenum test-bitfield :bitfield #t
(one 0)
(two 1)
(four 2)
)
(test-bitfield one four)

20
test/old_goal_tests/tests/test-bitfield-set1.gc
View File

@ -1,20 +0,0 @@
(test-setup 50.3432 #f)
(deftype test-bf-type3 (int64)
((f1 uint16 :offset-assert 0)
(f2 uint8 :size 7 :offset-assert 16)
(f3 float :offset-assert 23)
(f4 uint8 :size 1 :offset-assert 55)
(f5 uint8 :offset-assert 56)
)
)
(let ((temp (the test-bf-type3 #x0)))
(set! (-> temp f1) #x12)
(set! (-> temp f2) #x13)
(set! (-> temp f3) 12.3433)
(set! (-> temp f4) #xffffffff) ; will get truncated.
(expect-true (eq? 0 (-> temp f5))) ; check it gets truncated
(format #t "~f~%" (+ (-> temp f3) (-> temp f2) (-> temp f1) (-> temp f4)))
)

8
test/old_goal_tests/tests/test-car-cdr-get.gc
View File

@ -1,8 +0,0 @@
;-*-Scheme-*-
(test-setup 'ab #f)
(let ((my-pair (cons 'a 'b)))
(format #t "~A~A~%" (car my-pair) (cdr my-pair))
)

10
test/old_goal_tests/tests/test-car-cdr-set.gc
View File

@ -1,10 +0,0 @@
;-*-Scheme-*-
(test-setup 'cd #f)
(let ((my-pair (cons 'a 'b)))
(set! (car my-pair) 'c)
(set! (cdr my-pair) 'd)
(format #t "~A~A~%" (car my-pair) (cdr my-pair))
)

27
test/old_goal_tests/tests/test-condition-boolean.gc
View File

@ -1,27 +0,0 @@
;-*-Scheme-*-
(test-setup 4 #f)
(let ((total 0))
(if (true-func)
(+! total 1)
(+! total 999)
)
(if (false-func)
(+! total 999)
(+! total 1)
)
(if (not (true-func))
(+! total 999)
(+! total 1)
)
(if (not (false-func))
(+! total 1)
(+! total 999)
)
total
)

9
test/old_goal_tests/tests/test-conditional-compilation-2.gc
View File

@ -1,9 +0,0 @@
;-*-Scheme-*-
(test-setup 5 #f)
;; test the #when and #unless macros
(#unless (< 1 2) (/ 0 0))
(#when (< 1 2) 5)

15
test/old_goal_tests/tests/test-conditional-compilation.gc
View File

@ -1,15 +0,0 @@
;-*-Scheme-*-
(test-setup 3 #f)
;; test the use of #cond to evaluate goos expressions.
(#cond
((> 2 (+ 2 1))
1
)
((< 2 (+ 1 2))
3
)
)

7
test/old_goal_tests/tests/test-cons.gc
View File

@ -1,7 +0,0 @@
;-*-Scheme-*-
(test-setup '(a) #f)
(printl (cons 'a '()))

14
test/old_goal_tests/tests/test-declare-inline.gc
View File

@ -1,14 +0,0 @@
;-*-Scheme-*-
(test-setup 32 #f)
;; test calling an inline function. doesn't actually verify the call is inline.
(defun inline-test-function-1 ((x integer))
;; inline this function by default.
(declare (inline))
(* 4 x)
)
(inline-test-function-1 8)

12
test/old_goal_tests/tests/test-defglobalconstant-1.gc
View File

@ -1,12 +0,0 @@
;-*-Scheme-*-
(test-setup 17 #f)
;; test defglobalconstant to define a goal constant
(defglobalconstant my-constant 12)
(defglobalconstant my-constant 17)
(defglobalconstant not-my-consant 13)
my-constant

15
test/old_goal_tests/tests/test-defglobalconstant-2.gc
View File

@ -1,15 +0,0 @@
;-*-Scheme-*-
(test-setup 18 #f)
;; test defglobalconstant to get a goos constant
(defmacro get-goos-by-name (name)
;; do the lookup in the goos global environment
(eval name)
)
(defglobalconstant my-constant 18)
(get-goos-by-name my-constant)

17
test/old_goal_tests/tests/test-define-1.gc
View File

@ -1,17 +0,0 @@
;-*-Scheme-*-
(test-setup 17 #f)
;; test the use of define.
(define first-var 1)
(define second-var 2)
(define first-var 12)
(begin
(define first-var 13)
(define second-var 12)
(define first-var 17)
second-var
first-var)

19
test/old_goal_tests/tests/test-defsmacro-defgmacro.gc
View File

@ -1,19 +0,0 @@
;-*-Scheme-*-
(test-setup 20 #f)
(defsmacro test-macro (x)
;; goos macro
`(+ ,x 2)
)
(defmacro test-macro (x)
;; goal macro which calls a goos macro of the same name
(let ((goos-expansion (test-macro x)))
`(+ ,goos-expansion 3)
)
)
(test-macro 15)

7
test/old_goal_tests/tests/test-defun-extern.gc
View File

@ -1,7 +0,0 @@
;-*-Scheme-*-
(test-setup 12345 #f)
;; this should be defun-extern'd in goal-lib.gc
;; and the function is a C Kernel function.
(+ (zero-func) 12345)

16
test/old_goal_tests/tests/test-defun-return-constant.gc
View File

@ -1,16 +0,0 @@
;-*-Scheme-*-
(test-setup 12 #f)
(defun return-13 ()
13)
(defun return-12 ()
12)
(defun return-11 ()
11)
(return-12)

14
test/old_goal_tests/tests/test-defun-return-symbol.gc
View File

@ -1,14 +0,0 @@
;-*-Scheme-*-
(test-setup 42 #f)
(define my-number 36)
(defun return-my-number ()
my-number)
(define my-number 42)
(return-my-number)

11
test/old_goal_tests/tests/test-delete-car.gc
View File

@ -1,11 +0,0 @@
(test-setup '((a . b) (e . f)) #f)
(let ((my-list (list (cons 'a 'b)
(cons 'c 'd)
(cons 'e 'f)
)
))
(delete-car! 'c my-list)
(format #t "~A~%" my-list)
(format #t "~A~%" (assoc 'c my-list))
)

4
test/old_goal_tests/tests/test-delete-list.gc
View File

@ -1,4 +0,0 @@
(test-setup '(a b d e) #f)
(format #t "~A~%"
(delete! 'c (list 'a 'b 'c 'd 'e)))

15
test/old_goal_tests/tests/test-desfun.gc
View File

@ -1,15 +0,0 @@
;-*-Scheme-*-
(test-setup 4 #f)
(desfun square (x)
(* x x)
)
(defmacro call-square (x)
(square x)
)
(call-square 2)

6
test/old_goal_tests/tests/test-div-1.gc
View File

@ -1,6 +0,0 @@
;-*-Scheme-*-
(test-setup 6 #f)
(+ 1 2 (/ (* 2 5) (+ 1 2)))

14
test/old_goal_tests/tests/test-div-2.gc
View File

@ -1,14 +0,0 @@
;-*-Scheme-*-
(test-setup 7 #f)
;; this computes nothing that we can check, but verifies that the coloring
;; doesn't do something crazy when constrained a little strangely
(rlet ((x :reg rsp :type int64))
(/ x 2)
(/ 2 x)
)
(let ((x 30))
(+ (/ x 10) 4)
)

11
test/old_goal_tests/tests/test-dotimes.gc
View File

@ -1,11 +0,0 @@
;-*-Scheme-*-
(test-setup 4950 #f)
(let ((sum 0))
(dotimes (i 100 7 8 9 sum)
(+! sum i)
;;(format #t "iter ~D sum ~D~%" i sum)
)
)

58
test/old_goal_tests/tests/test-dynamic-type.gc
View File

@ -1,58 +0,0 @@
(test-setup 1 #f)
(deftype test-dynamic-type (basic)
(
(pad0 int16 :offset 0)
(allocated-length int32 :offset 4)
(data int32 :dynamic :offset 8)
(over1 int32 :offset 8)
(over2 int32 :offset 12)
)
)
(defmethod new test-dynamic-type ((allocation symbol) (type-to-make type) (cnt integer))
;"Create a new inline-array. Sets the length, allocated-length to cnt. Uses the mysterious heap-base field
;of the type-to-make to determine the element size"
(let* ((sz (+ (-> type-to-make asize) (* 4 cnt)))
(new-object (object-new sz)))
;;(format 0 "create sz ~d at #x~X~%" sz new-object)
(unless (zero? new-object)
(set! (-> new-object allocated-length) cnt)
)
new-object
)
)
(defmethod length test-dynamic-type ((obj test-dynamic-type))
;"Get the length of it"
(-> obj allocated-length)
)
(defmethod asize-of test-dynamic-type ((obj test-dynamic-type))
;"Get the size in memory of it"
(+ (-> obj type asize)
(* (-> obj allocated-length) 4)
)
)
(define test-dynamic-obj
(the test-dynamic-type ((-> test-dynamic-type methods 0) 'global test-dynamic-type 40)))
;(inspect test-dynamic-obj)
(set! (-> test-dynamic-obj data 0) 12)
(set! (-> test-dynamic-obj data 1) 20)
;(inspect test-dynamic-obj)
; (format #t "should be same (~d ~d) (~d ~d)~%" (-> test-dynamic-obj data 0) (-> test-dynamic-obj over1)
; (-> test-dynamic-obj data 1) (-> test-dynamic-obj over2))
(expect-true (= (-> test-dynamic-obj data 0) (-> test-dynamic-obj over1)))
(expect-true (= (-> test-dynamic-obj data 1) (-> test-dynamic-obj over2)))
(set! (-> test-dynamic-obj pad0) 0)
(expect-true (= (-> test-dynamic-obj type) test-dynamic-type))
(expect-true (= (asize-of test-dynamic-obj) 180))
1

6
test/old_goal_tests/tests/test-empty-pair.gc
View File

@ -1,6 +0,0 @@
;-*-Scheme-*-
(test-setup '() #f)
(print '())
(format #t "~%")

15
test/old_goal_tests/tests/test-factorial-iterative.gc
View File

@ -1,15 +0,0 @@
;-*-Scheme-*-
(test-setup 3628800 #f)
(defun factorial-iterative ((x integer))
(let ((result 1))
(while (!= x 1)
(set! result (* result x))
(set! x (- x 1))
)
result
)
)
(factorial-iterative 10)

15
test/old_goal_tests/tests/test-factorial-recursive.gc
View File

@ -1,15 +0,0 @@
;-*-Scheme-*-
(test-setup 3628800 #f)
;; for now, recursive functions need to forward declare so they have their
;; return type.
(defun-extern factorial-recursive ((x integer)) integer)
(defun factorial-recursive ((x integer))
(cond ((= x 1) x)
(else (* x (factorial-recursive (- x 1))))
)
)
(factorial-recursive 10)

27
test/old_goal_tests/tests/test-find-parent-method.gc
View File

@ -1,27 +0,0 @@
;-*-Scheme-*-
(test-setup "test pass!" #f)
(let ((test-result "test fail!"))
;; first, do one where we get something
(if (eq?
(-> structure methods 1)
(find-parent-method bfloat 1)
)
(set! test-result "test pass!")
)
;; nothing
(if (not (eq?
(find-parent-method structure 5)
nothing
)
)
(format #t "TEST FAIL~%~%")
)
(print test-result)
)

4
test/old_goal_tests/tests/test-fixed-shifts.gc
View File

@ -1,4 +0,0 @@
(test-setup 4611686018427387914 #f)
(+ (shl 2 3) (shl 1 0) (shl 0 4) (shr 2 3) (shr 10 2) (shl -2 1) (sar -16 2) (shr -1 2))
;; 16 1 0 0 2 -4 -4

12
test/old_goal_tests/tests/test-float-function.gc
View File

@ -1,12 +0,0 @@
;-*-Scheme-*-
(test-setup 10.152 #f)
(defun float-testing-function ((x float) (y float))
(* x y (* x x))
)
(let ((x (float-testing-function (* 1.2 1.2) 3.4)))
(format #t "~,,3f~%" x)
)

Some files were not shown because too many files have changed in this diff Show More