From 5c9aa3facd63823afda62d81292bbec202069ca4 Mon Sep 17 00:00:00 2001 From: water111 <48171810+water111@users.noreply.github.com> Date: Sun, 30 Apr 2023 14:13:52 -0400 Subject: [PATCH] [jak2] try to speed up compile a bit (#2596) --- common/goos/Interpreter.cpp | 111 ++++++++------ common/goos/Object.cpp | 2 +- game/overlord/jak2/iso.cpp | 19 +-- .../sprite/sparticle/sparticle-launcher-h.gc | 143 ++++++++++-------- .../sprite/particles/sparticle-launcher-h.gc | 119 +++++++++------ .../reference/jak1/decompiler-macros.gc | 126 +++++++++------ .../reference/jak2/decompiler-macros.gc | 119 +++++++++------ 7 files changed, 378 insertions(+), 261 deletions(-) diff --git a/common/goos/Interpreter.cpp b/common/goos/Interpreter.cpp index 4c68c8d086..2d9ccdd70b 100644 --- a/common/goos/Interpreter.cpp +++ b/common/goos/Interpreter.cpp @@ -202,9 +202,8 @@ void Interpreter::throw_eval_error(const Object& o, const std::string& err) { */ Object Interpreter::eval_with_rewind(const Object& obj, const std::shared_ptr& env) { - Object result = Object::make_empty_list(); try { - result = eval(obj, env); + return eval(obj, env); } catch (std::runtime_error& e) { if (!disable_printing) { printf("-----------------------------------------\n"); @@ -212,7 +211,6 @@ Object Interpreter::eval_with_rewind(const Object& obj, } throw e; } - return result; } /*! @@ -262,14 +260,14 @@ Arguments Interpreter::get_args(const Object& form, const Object& rest, const Ar Arguments args; // loop over forms in list - Object current = rest; - while (!current.is_empty_list()) { - auto arg = current.as_pair()->car; + const Object* current = &rest; + while (!current->is_empty_list()) { + const auto& arg = current->as_pair()->car; // did we get a ":keyword" if (arg.is_symbol() && arg.as_symbol()->name.at(0) == ':') { auto key_name = arg.as_symbol()->name.substr(1); - auto kv = spec.named.find(key_name); + const auto& kv = spec.named.find(key_name); // check for unknown key name if (!spec.varargs && kv == spec.named.end()) { @@ -282,12 +280,12 @@ Arguments Interpreter::get_args(const Object& form, const Object& rest, const Ar } // check for well-formed :key value expression - current = current.as_pair()->cdr; - if (current.is_empty_list()) { + current = ¤t->as_pair()->cdr; + if (current->is_empty_list()) { throw_eval_error(form, "Key argument didn't have a value"); } - args.named[key_name] = current.as_pair()->car; + args.named[key_name] = current->as_pair()->car; } else { // not a keyword. Add to unnamed or rest, depending on what we expect if (spec.varargs || args.unnamed.size() < spec.unnamed.size()) { @@ -296,12 +294,12 @@ Arguments Interpreter::get_args(const Object& form, const Object& rest, const Ar args.rest.push_back(arg); } } - current = current.as_pair()->cdr; + current = ¤t->as_pair()->cdr; } // Check expected key args and set default values on unset ones if possible for (auto& kv : spec.named) { - auto defined_kv = args.named.find(kv.first); + const auto& defined_kv = args.named.find(kv.first); if (defined_kv == args.named.end()) { // key arg not given by user, try to use a default value. if (kv.second.has_default) { @@ -558,7 +556,7 @@ bool try_symbol_lookup(const Object& sym, // loop up envs until we find it. EnvironmentObject* search_env = env.get(); for (;;) { - auto kv = search_env->vars.find(sym.as_symbol()); + const auto& kv = search_env->vars.find(sym.as_symbol()); if (kv != search_env->vars.end()) { *dest = kv->second; return true; @@ -595,22 +593,22 @@ bool Interpreter::eval_symbol(const Object& sym, * Evaluate a pair, either as special form, builtin form, macro application, or lambda application. */ Object Interpreter::eval_pair(const Object& obj, const std::shared_ptr& env) { - auto pair = obj.as_pair(); - Object head = pair->car; - Object rest = pair->cdr; + const auto& pair = obj.as_pair(); + const Object& head = pair->car; + const Object& rest = pair->cdr; // first see if we got a symbol: if (head.type == ObjectType::SYMBOL) { - auto head_sym = head.as_symbol(); + const auto& head_sym = head.as_symbol(); // try a special form first - auto kv_sf = special_forms.find(head_sym->name); + const auto& kv_sf = special_forms.find(head_sym->name); if (kv_sf != special_forms.end()) { return ((*this).*(kv_sf->second))(obj, rest, env); } // try builtins next - auto kv_b = builtin_forms.find(head_sym->name); + const auto& kv_b = builtin_forms.find(head_sym->name); if (kv_b != builtin_forms.end()) { Arguments args = get_args(obj, rest, make_varargs()); // all "built-in" forms expect arguments to be evaluated (that's why they aren't special) @@ -619,7 +617,7 @@ Object Interpreter::eval_pair(const Object& obj, const std::shared_ptrname); + const auto& kv_u = m_custom_forms.find(head_sym->name); if (kv_u != m_custom_forms.end()) { Arguments args = get_args(obj, rest, make_varargs()); return (kv_u->second)(obj, args, env); @@ -628,7 +626,7 @@ Object Interpreter::eval_pair(const Object& obj, const std::shared_ptrargs); auto mac_env_obj = EnvironmentObject::make_new(); @@ -646,7 +644,7 @@ Object Interpreter::eval_pair(const Object& obj, const std::shared_ptrargs); eval_args(&args, env); auto lam_env_obj = EnvironmentObject::make_new(); @@ -822,53 +820,55 @@ Object Interpreter::eval_quote(const Object& form, */ Object Interpreter::quasiquote_helper(const Object& form, const std::shared_ptr& env) { - Object lst = form; + const Object* lst_iter = &form; std::vector result; for (;;) { - if (lst.type == ObjectType::PAIR) { - Object item = lst.as_pair()->car; + if (lst_iter->type == ObjectType::PAIR) { + const Object& item = lst_iter->as_pair()->car; if (item.type == ObjectType::PAIR) { if (item.as_pair()->car.type == ObjectType::SYMBOL && item.as_pair()->car.as_symbol()->name == "unquote") { - Object unquote_arg = item.as_pair()->cdr; + const Object& unquote_arg = item.as_pair()->cdr; if (unquote_arg.type != ObjectType::PAIR || unquote_arg.as_pair()->cdr.type != ObjectType::EMPTY_LIST) { throw_eval_error(form, "unquote must have exactly 1 arg"); } - item = eval_with_rewind(unquote_arg.as_pair()->car, env); + result.push_back(eval_with_rewind(unquote_arg.as_pair()->car, env)); + lst_iter = &lst_iter->as_pair()->cdr; + continue; } else if (item.as_pair()->car.type == ObjectType::SYMBOL && item.as_pair()->car.as_symbol()->name == "unquote-splicing") { - Object unquote_arg = item.as_pair()->cdr; + const Object& unquote_arg = item.as_pair()->cdr; if (unquote_arg.type != ObjectType::PAIR || unquote_arg.as_pair()->cdr.type != ObjectType::EMPTY_LIST) { throw_eval_error(form, "unquote must have exactly 1 arg"); } - item = eval_with_rewind(unquote_arg.as_pair()->car, env); // bypass normal addition: - lst = lst.as_pair()->cdr; - Object to_add = item; + lst_iter = &lst_iter->as_pair()->cdr; + Object splice_result = eval_with_rewind(unquote_arg.as_pair()->car, env); + const Object* to_add = &splice_result; for (;;) { - if (to_add.type == ObjectType::PAIR) { - result.push_back(to_add.as_pair()->car); - to_add = to_add.as_pair()->cdr; - } else if (to_add.type == ObjectType::EMPTY_LIST) { + if (to_add->type == ObjectType::PAIR) { + result.push_back(to_add->as_pair()->car); + to_add = &to_add->as_pair()->cdr; + } else if (to_add->type == ObjectType::EMPTY_LIST) { break; } else { throw_eval_error(form, "malformed unquote-splicing result"); } } continue; - } - - else { - item = quasiquote_helper(item, env); + } else { + result.push_back(quasiquote_helper(item, env)); + lst_iter = &lst_iter->as_pair()->cdr; + continue; } } - lst = lst.as_pair()->cdr; result.push_back(item); - } else if (lst.type == ObjectType::EMPTY_LIST) { - return build_list(result); + lst_iter = &lst_iter->as_pair()->cdr; + } else if (lst_iter->type == ObjectType::EMPTY_LIST) { + return build_list(std::move(result)); } else { throw_eval_error(form, "malformed quasiquote"); } @@ -1832,9 +1832,17 @@ Object Interpreter::eval_make_string_hash_table(const Object& form, Object Interpreter::eval_hash_table_set(const Object& form, Arguments& args, const std::shared_ptr& /*env*/) { - vararg_check(form, args, {ObjectType::STRING_HASH_TABLE, ObjectType::STRING, {}}, {}); - args.unnamed.at(0).as_string_hash_table()->data[args.unnamed.at(1).as_string()->data] = - args.unnamed.at(2); + vararg_check(form, args, {ObjectType::STRING_HASH_TABLE, {}, {}}, {}); + const char* str = nullptr; + if (args.unnamed.at(1).is_symbol()) { + str = args.unnamed.at(1).as_symbol()->name.c_str(); + } else if (args.unnamed.at(1).is_string()) { + str = args.unnamed.at(1).as_string()->data.c_str(); + } else { + throw_eval_error(form, "Hash table must use symbol or string as the key."); + } + + args.unnamed.at(0).as_string_hash_table()->data[str] = args.unnamed.at(2); return Object::make_empty_list(); } @@ -1844,9 +1852,18 @@ Object Interpreter::eval_hash_table_set(const Object& form, Object Interpreter::eval_hash_table_try_ref(const Object& form, Arguments& args, const std::shared_ptr& /*env*/) { - vararg_check(form, args, {ObjectType::STRING_HASH_TABLE, ObjectType::STRING}, {}); + vararg_check(form, args, {ObjectType::STRING_HASH_TABLE, {}}, {}); const auto* table = args.unnamed.at(0).as_string_hash_table(); - const auto& it = table->data.find(args.unnamed.at(1).as_string()->data); + + const char* str = nullptr; + if (args.unnamed.at(1).is_symbol()) { + str = args.unnamed.at(1).as_symbol()->name.c_str(); + } else if (args.unnamed.at(1).is_string()) { + str = args.unnamed.at(1).as_string()->data.c_str(); + } else { + throw_eval_error(form, "Hash table must use symbol or string as the key."); + } + const auto& it = table->data.find(str); if (it == table->data.end()) { // not in table return PairObject::make_new(SymbolObject::make_new(reader.symbolTable, "#f"), diff --git a/common/goos/Object.cpp b/common/goos/Object.cpp index 465304b158..c2c4bcf9e2 100644 --- a/common/goos/Object.cpp +++ b/common/goos/Object.cpp @@ -204,7 +204,7 @@ Object build_list(std::vector&& objects) { Object result; result.type = ObjectType::PAIR; - result.heap_obj = head; + result.heap_obj = std::move(head); return result; } diff --git a/game/overlord/jak2/iso.cpp b/game/overlord/jak2/iso.cpp index a69ff313cd..6a59caa9c0 100644 --- a/game/overlord/jak2/iso.cpp +++ b/game/overlord/jak2/iso.cpp @@ -198,11 +198,11 @@ void IsoQueueVagStream(VagCmd* cmd, int param_2) { VagCmd* pVVar7; VagCmd* new_stereo_cmd; - // HACK - if (!cmd->vag_dir_entry) { - printf("IsoQueueVagStream: no entry for %s\n", cmd->name); - return; - } + // we added a few null checks on vag_dir_entry. + // as far as I can tell, it's "okay" that some animations (like Jak's idle animation) + // don't have a corresponding audio. There's checks later on in this function that skip + // trying to open the VAG file when this happens, but the stereo/mono checks don't have this + // check. So we added them. if (param_2 == 1) { // CpuSuspendIntr(local_20); @@ -210,8 +210,9 @@ void IsoQueueVagStream(VagCmd* cmd, int param_2) { new_stereo_cmd = nullptr; // allocate/find a vag cmd to hold this stream command. We don't own the incoming command. - if ((cmd->id == 0) || (((cmd->vag_dir_entry->flag & 1U) != 0 && - (iVar1 = HowManyBelowThisPriority(cmd->priority, 0), iVar1 < 2)))) + if ((cmd->id == 0) || + (((cmd->vag_dir_entry && cmd->vag_dir_entry->flag & 1U) != 0 && // added null check + (iVar1 = HowManyBelowThisPriority(cmd->priority, 0), iVar1 < 2)))) goto LAB_000049dc; new_cmd = FindThisVagStream(cmd->name, cmd->id); if (!new_cmd) { @@ -264,7 +265,7 @@ void IsoQueueVagStream(VagCmd* cmd, int param_2) { new_cmd->sb_scanned = true; // check for stereo - if ((new_cmd->vag_dir_entry->flag & 1U) != 0) { + if (cmd->vag_dir_entry && (new_cmd->vag_dir_entry->flag & 1U) != 0) { // added null check // try allocating it new_stereo_cmd = SmartAllocVagCmd(cmd); if (!new_stereo_cmd) { @@ -298,7 +299,7 @@ void IsoQueueVagStream(VagCmd* cmd, int param_2) { new_cmd->sb_scanned = false; RemoveVagCmd(new_cmd, 0); FreeVagCmd(new_cmd, 0); - if ((new_cmd->vag_dir_entry->flag & 1U) != 0) { + if (cmd->vag_dir_entry && (new_cmd->vag_dir_entry->flag & 1U) != 0) { // added null check new_stereo_cmd->sb_scanned = false; RemoveVagCmd(new_stereo_cmd, 0); FreeVagCmd(new_stereo_cmd, 0); diff --git a/goal_src/jak1/engine/gfx/sprite/sparticle/sparticle-launcher-h.gc b/goal_src/jak1/engine/gfx/sprite/sparticle/sparticle-launcher-h.gc index 7b48b13798..7269dc75b7 100644 --- a/goal_src/jak1/engine/gfx/sprite/sparticle/sparticle-launcher-h.gc +++ b/goal_src/jak1/engine/gfx/sprite/sparticle/sparticle-launcher-h.gc @@ -28,7 +28,7 @@ ;; The `*part-group-id-table*` array stores a reference to every launch-group, indexed by group id. ;; Each launch-group is just a list of sparticle-launchers, stored as an index -;; A launcher is a single particle effect. +;; A launcher is a single particle effect. ;; The `*part-id-table*` has references to all particle effects. ;; It contains a list of "field-init-specs". When the particle effect starts, the system ;; iterates through this list and sets parameters about particles. @@ -46,7 +46,7 @@ ;; These are the user-settable state variables for each particle effect (defenum sp-field-id :type uint16 - + (misc-fields-start 0) (spt-texture 1) (spt-anim 2) @@ -56,7 +56,7 @@ (spt-num 6) (spt-sound 7) (misc-fields-end 8) - + (sprite-fields-start 9) (spt-x 10) (spt-y 11) @@ -71,7 +71,7 @@ (spt-b 20) (spt-a 21) (sprite-fields-end 22) - + (cpu-fields-start 23) (spt-omega 24) (spt-vel-x 25) @@ -102,7 +102,7 @@ (spt-next-time 50) (spt-next-launcher 51) (cpu-fields-end 52) - + (launch-fields-start 53) (spt-launchrot-x 54) (spt-launchrot-y 55) @@ -115,7 +115,7 @@ (spt-conerot-radius 62) (spt-rotate-y 63) (launch-fields-end 64) - + (spt-scale 65) (spt-scalevel 66) (spt-end 67) @@ -322,27 +322,44 @@ `(-> *part-group-id-table* ,id) ) +(desfun param-float? (p) + (or (float? p) (and (pair? p) (eq? 'meters (car p))) (and (pair? p) (eq? 'degrees (car p)))) + ) + +(desfun param-int? (p) + (or (integer? p) (and (pair? p) (eq? 'seconds (car p)))) + ) + +(desfun param-symbol? (p) + (and (pair? p) (eq? 'quote (car p))) + ) + (seval (begin -(define *sparticle-fields* '()) +(define *sparticle-fields* (make-string-hash-table)) (doenum (name val 'sp-field-id) - (append!! *sparticle-fields* (list (if (string-starts-with? (symbol->string name) "spt-") - (string->symbol (string-substr (symbol->string name) 4 0)) - name) - val name (member name '(spt-vel-x - spt-vel-y - spt-vel-z - spt-scalevel-x - spt-scalevel-y - spt-rotvel-x - spt-rotvel-y - spt-rotvel-z - spt-fade-r - spt-fade-g - spt-fade-b - spt-fade-a - spt-accel-x - spt-accel-y - spt-accel-z)))) + (hash-table-set! + *sparticle-fields* + (if (string-starts-with? (symbol->string name) "spt-") + (string->symbol (string-substr (symbol->string name) 4 0)) + name) + (list + val name (member name '(spt-vel-x + spt-vel-y + spt-vel-z + spt-scalevel-x + spt-scalevel-y + spt-rotvel-x + spt-rotvel-y + spt-rotvel-z + spt-fade-r + spt-fade-g + spt-fade-b + spt-fade-a + spt-accel-x + spt-accel-y + spt-accel-z)) + ) + ) ) ;; you cannot define these fields ever. (define *sparticle-fields-banned* '(misc-fields-start @@ -356,37 +373,35 @@ end )) )) -(defmacro defpart (id &key (init-specs ())) - "define a new sparticle-launcher" - (let ((last-field-id -1) - (param-float? (lambda (p) (or (float? p) (and (pair? p) (eq? 'meters (car p))) (and (pair? p) (eq? 'degrees (car p)))))) - (param-int? (lambda (p) (or (integer? p) (and (pair? p) (eq? 'seconds (car p)))))) - (param-symbol? (lambda (p) (and (pair? p) (eq? 'quote (car p)))))) - `(set! (-> *part-id-table* ,id) - (new 'static 'sparticle-launcher - :init-specs (new 'static 'inline-array sp-field-init-spec ,(1+ (length init-specs)) - ,@(apply (lambda (x) - (let* ((head (symbol->string (car x))) +;; the last field ID defined, to make sure that fields are defined in order. +(seval (define *last-field-id* -1)) + +(desfun process-init-spec (x) + (let* ((head (symbol->string (car x))) (params (cdr x)) (field-name (string->symbol (string-substr head 1 0))) - (field (assoc field-name *sparticle-fields*))) - (when (not field) + (field-lookup (hash-table-try-ref *sparticle-fields* field-name)) + (field (cdr field-lookup)) + (store? (member ':store params)) + (param-count (if store? (1- (length params)) (length params))) + ) + (when (not (car field-lookup)) (fmt #t "unknown sparticle field {}\n" x)) (when (neq? (string-ref head 0) #\:) (fmt #t "invalid sparticle field {}\n" x)) - (when (member field-name *sparticle-fields-banned*) - (fmt #t "you cannot use sparticle field {}\n" field-name)) - (let* ((field-id (cadr field)) - (field-enum-name (caddr field)) - (vel? (and #f (cadddr field))) - (param-count (length params)) + ; (when (member field-name *sparticle-fields-banned*) + ; (fmt #t "you cannot use sparticle field {}\n" field-name)) + (let ((field-id (car field)) + (field-enum-name (cadr field)) + (vel? (and #f (caddr field))) (param0 (and (>= param-count 1) (first params))) (param1 (and (>= param-count 2) (second params))) (param2 (and (>= param-count 3) (third params)))) - (when (>= last-field-id field-id) - (fmt #t "field {} must come after field {}, not before\n" field-name (car (nth last-field-id *sparticle-fields*)))) - (set! last-field-id field-id) + (when (>= *last-field-id* field-id) + (fmt #t "field {} must come after field {}, not before\n" field-name (car (nth *last-field-id* *sparticle-fields*))) + ) + (set! *last-field-id* field-id) (cond ((eq? field-name 'flags) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :initial-value (sp-cpuinfo-flag ,@param0) :random-mult 1) @@ -401,36 +416,37 @@ `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :sound ,param0 :flags (sp-flag object)) ) ((and (= 2 param-count) (symbol? param0) (eq? param0 ':copy)) - (let* ((other-field (assoc (cadr (member ':copy params)) *sparticle-fields*)) - (other-field-id (cadr other-field))) + (let* ((other-field-lookup (hash-table-try-ref *sparticle-fields* (cadr (member ':copy params)))) + (other-field (cdr other-field-lookup)) + (other-field-id (car other-field))) (when (>= other-field-id field-id) - (fmt #t "warning copying to sparticle field {} - you can only copy from fields before this one!\n" field-name)) + (fmt #t "warning copying to sparticle field {} from {} - you can only copy from fields before this one!\n" field-name (cadr other-field)) ) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag copy-from-other) :initial-value ,(- other-field-id field-id) :random-mult 1) ) ) ((and (= 2 param-count) (symbol? param0) (eq? param0 ':data)) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag object) - :pntr (the-as pointer ,(cadr (member ':data params)))) + :object ,(cadr (member ':data params))) ) ((and (= 1 param-count) (param-symbol? param0)) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag symbol) :sym ,param0) ) ((and (= 1 param-count) (param-float? param0)) - `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag float) + `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag ,(if store? 'float-store 'float)) :initial-valuef ,(if vel? `(/ ,param0 60.0) param0) :random-rangef 0.0 :random-multf 1.0) ) ((and (= 2 param-count) (param-float? param0) (param-float? param1)) - `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag float) + `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag ,(if store? 'float-store 'float)) :initial-valuef ,(if vel? `(/ ,param0 60.0) param0) :random-rangef ,(if vel? `(/ ,param1 60.0) param1) :random-multf 1.0) ) ((and (= 3 param-count) (param-float? param0) (param-float? param1) (param-float? param2)) - `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag float) + `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag ,(if store? 'float-store 'float)) :initial-valuef ,(if vel? `(/ ,param0 60.0) param0) :random-rangef ,param1 :random-multf ,(if vel? `(/ ,param2 60.0) param2)) @@ -463,12 +479,19 @@ `(new 'static 'sp-field-init-spec :field (sp-field-id spt-end)) ) ) - )) - ) init-specs) + ) + ) + ) + +(defmacro defpart (id &key (init-specs ())) + "define a new sparticle-launcher" + (begin + (set! *last-field-id* -1) + `(set! (-> *part-id-table* ,id) + (new 'static 'sparticle-launcher + :init-specs (new 'static 'inline-array sp-field-init-spec ,(1+ (length init-specs)) + ,@(apply process-init-spec init-specs) (new 'static 'sp-field-init-spec :field (sp-field-id spt-end)) ))) ) - ) - - - + ) \ No newline at end of file diff --git a/goal_src/jak2/engine/gfx/sprite/particles/sparticle-launcher-h.gc b/goal_src/jak2/engine/gfx/sprite/particles/sparticle-launcher-h.gc index 6662e688af..8c9c5f69f5 100644 --- a/goal_src/jak2/engine/gfx/sprite/particles/sparticle-launcher-h.gc +++ b/goal_src/jak2/engine/gfx/sprite/particles/sparticle-launcher-h.gc @@ -188,27 +188,44 @@ ) ) +(desfun param-float? (p) + (or (float? p) (and (pair? p) (eq? 'meters (car p))) (and (pair? p) (eq? 'degrees (car p)))) + ) + +(desfun param-int? (p) + (or (integer? p) (and (pair? p) (eq? 'seconds (car p)))) + ) + +(desfun param-symbol? (p) + (and (pair? p) (eq? 'quote (car p))) + ) + (seval (begin -(define *sparticle-fields* '()) +(define *sparticle-fields* (make-string-hash-table)) (doenum (name val 'sp-field-id) - (append!! *sparticle-fields* (list (if (string-starts-with? (symbol->string name) "spt-") - (string->symbol (string-substr (symbol->string name) 4 0)) - name) - val name (member name '(spt-vel-x - spt-vel-y - spt-vel-z - spt-scalevel-x - spt-scalevel-y - spt-rotvel-x - spt-rotvel-y - spt-rotvel-z - spt-fade-r - spt-fade-g - spt-fade-b - spt-fade-a - spt-accel-x - spt-accel-y - spt-accel-z)))) + (hash-table-set! + *sparticle-fields* + (if (string-starts-with? (symbol->string name) "spt-") + (string->symbol (string-substr (symbol->string name) 4 0)) + name) + (list + val name (member name '(spt-vel-x + spt-vel-y + spt-vel-z + spt-scalevel-x + spt-scalevel-y + spt-rotvel-x + spt-rotvel-y + spt-rotvel-z + spt-fade-r + spt-fade-g + spt-fade-b + spt-fade-a + spt-accel-x + spt-accel-y + spt-accel-z)) + ) + ) ) ;; you cannot define these fields ever. (define *sparticle-fields-banned* '(misc-fields-start @@ -222,38 +239,35 @@ end )) )) -(defmacro defpart (id &key (init-specs ())) - "define a new sparticle-launcher" - (let ((last-field-id -1) - (param-float? (lambda (p) (or (float? p) (and (pair? p) (eq? 'meters (car p))) (and (pair? p) (eq? 'degrees (car p)))))) - (param-int? (lambda (p) (or (integer? p) (and (pair? p) (eq? 'seconds (car p)))))) - (param-symbol? (lambda (p) (and (pair? p) (eq? 'quote (car p)))))) - `(set! (-> *part-id-table* ,id) - (new 'static 'sparticle-launcher - :init-specs (new 'static 'inline-array sp-field-init-spec ,(1+ (length init-specs)) - ,@(apply (lambda (x) - (let* ((head (symbol->string (car x))) +;; the last field ID defined, to make sure that fields are defined in order. +(seval (define *last-field-id* -1)) + +(desfun process-init-spec (x) + (let* ((head (symbol->string (car x))) (params (cdr x)) (field-name (string->symbol (string-substr head 1 0))) - (field (assoc field-name *sparticle-fields*))) - (when (not field) + (field-lookup (hash-table-try-ref *sparticle-fields* field-name)) + (field (cdr field-lookup)) + (store? (member ':store params)) + (param-count (if store? (1- (length params)) (length params))) + ) + (when (not (car field-lookup)) (fmt #t "unknown sparticle field {}\n" x)) (when (neq? (string-ref head 0) #\:) (fmt #t "invalid sparticle field {}\n" x)) - (when (member field-name *sparticle-fields-banned*) - (fmt #t "you cannot use sparticle field {}\n" field-name)) - (let* ((field-id (cadr field)) - (field-enum-name (caddr field)) - (vel? (and #f (cadddr field))) - (store? (member ':store params)) - (param-count (if store? (1- (length params)) (length params))) + ; (when (member field-name *sparticle-fields-banned*) + ; (fmt #t "you cannot use sparticle field {}\n" field-name)) + (let ((field-id (car field)) + (field-enum-name (cadr field)) + (vel? (and #f (caddr field))) (param0 (and (>= param-count 1) (first params))) (param1 (and (>= param-count 2) (second params))) (param2 (and (>= param-count 3) (third params)))) - (when (>= last-field-id field-id) - (fmt #t "field {} must come after field {}, not before\n" field-name (car (nth last-field-id *sparticle-fields*)))) - (set! last-field-id field-id) + (when (>= *last-field-id* field-id) + (fmt #t "field {} must come after field {}, not before\n" field-name (car (nth *last-field-id* *sparticle-fields*))) + ) + (set! *last-field-id* field-id) (cond ((eq? field-name 'flags) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :initial-value (sp-cpuinfo-flag ,@param0) :random-mult 1) @@ -268,10 +282,11 @@ `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :sound ,param0 :flags (sp-flag object)) ) ((and (= 2 param-count) (symbol? param0) (eq? param0 ':copy)) - (let* ((other-field (assoc (cadr (member ':copy params)) *sparticle-fields*)) - (other-field-id (cadr other-field))) + (let* ((other-field-lookup (hash-table-try-ref *sparticle-fields* (cadr (member ':copy params)))) + (other-field (cdr other-field-lookup)) + (other-field-id (car other-field))) (when (>= other-field-id field-id) - (fmt #t "warning copying to sparticle field {} - you can only copy from fields before this one!\n" field-name)) + (fmt #t "warning copying to sparticle field {} from {} - you can only copy from fields before this one!\n" field-name (cadr other-field)) ) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag copy-from-other) :initial-value ,(- other-field-id field-id) :random-mult 1) ) @@ -330,8 +345,18 @@ `(new 'static 'sp-field-init-spec :field (sp-field-id spt-end)) ) ) - )) - ) init-specs) + ) + ) + ) + +(defmacro defpart (id &key (init-specs ())) + "define a new sparticle-launcher" + (begin + (set! *last-field-id* -1) + `(set! (-> *part-id-table* ,id) + (new 'static 'sparticle-launcher + :init-specs (new 'static 'inline-array sp-field-init-spec ,(1+ (length init-specs)) + ,@(apply process-init-spec init-specs) (new 'static 'sp-field-init-spec :field (sp-field-id spt-end)) ))) ) diff --git a/test/decompiler/reference/jak1/decompiler-macros.gc b/test/decompiler/reference/jak1/decompiler-macros.gc index ed41b360ea..5033a19f68 100644 --- a/test/decompiler/reference/jak1/decompiler-macros.gc +++ b/test/decompiler/reference/jak1/decompiler-macros.gc @@ -693,27 +693,44 @@ `(-> *part-group-id-table* ,id) ) +(desfun param-float? (p) + (or (float? p) (and (pair? p) (eq? 'meters (car p))) (and (pair? p) (eq? 'degrees (car p)))) + ) + +(desfun param-int? (p) + (or (integer? p) (and (pair? p) (eq? 'seconds (car p)))) + ) + +(desfun param-symbol? (p) + (and (pair? p) (eq? 'quote (car p))) + ) + (seval (begin -(define *sparticle-fields* '()) +(define *sparticle-fields* (make-string-hash-table)) (doenum (name val 'sp-field-id) - (append!! *sparticle-fields* (list (if (string-starts-with? (symbol->string name) "spt-") - (string->symbol (string-substr (symbol->string name) 4 0)) - name) - val name (member name '(spt-vel-x - spt-vel-y - spt-vel-z - spt-scalevel-x - spt-scalevel-y - spt-rotvel-x - spt-rotvel-y - spt-rotvel-z - spt-fade-r - spt-fade-g - spt-fade-b - spt-fade-a - spt-accel-x - spt-accel-y - spt-accel-z)))) + (hash-table-set! + *sparticle-fields* + (if (string-starts-with? (symbol->string name) "spt-") + (string->symbol (string-substr (symbol->string name) 4 0)) + name) + (list + val name (member name '(spt-vel-x + spt-vel-y + spt-vel-z + spt-scalevel-x + spt-scalevel-y + spt-rotvel-x + spt-rotvel-y + spt-rotvel-z + spt-fade-r + spt-fade-g + spt-fade-b + spt-fade-a + spt-accel-x + spt-accel-y + spt-accel-z)) + ) + ) ) ;; you cannot define these fields ever. (define *sparticle-fields-banned* '(misc-fields-start @@ -727,37 +744,35 @@ end )) )) -(defmacro defpart (id &key (init-specs ())) - "define a new sparticle-launcher" - (let ((last-field-id -1) - (param-float? (lambda (p) (or (float? p) (and (pair? p) (eq? 'meters (car p))) (and (pair? p) (eq? 'degrees (car p)))))) - (param-int? (lambda (p) (or (integer? p) (and (pair? p) (eq? 'seconds (car p)))))) - (param-symbol? (lambda (p) (and (pair? p) (eq? 'quote (car p)))))) - `(set! (-> *part-id-table* ,id) - (new 'static 'sparticle-launcher - :init-specs (new 'static 'inline-array sp-field-init-spec ,(1+ (length init-specs)) - ,@(apply (lambda (x) - (let* ((head (symbol->string (car x))) +;; the last field ID defined, to make sure that fields are defined in order. +(seval (define *last-field-id* -1)) + +(desfun process-init-spec (x) + (let* ((head (symbol->string (car x))) (params (cdr x)) (field-name (string->symbol (string-substr head 1 0))) - (field (assoc field-name *sparticle-fields*))) - (when (not field) + (field-lookup (hash-table-try-ref *sparticle-fields* field-name)) + (field (cdr field-lookup)) + (store? (member ':store params)) + (param-count (if store? (1- (length params)) (length params))) + ) + (when (not (car field-lookup)) (fmt #t "unknown sparticle field {}\n" x)) (when (neq? (string-ref head 0) #\:) (fmt #t "invalid sparticle field {}\n" x)) - (when (member field-name *sparticle-fields-banned*) - (fmt #t "you cannot use sparticle field {}\n" field-name)) - (let* ((field-id (cadr field)) - (field-enum-name (caddr field)) - (vel? (and #f (cadddr field))) - (param-count (length params)) + ; (when (member field-name *sparticle-fields-banned*) + ; (fmt #t "you cannot use sparticle field {}\n" field-name)) + (let ((field-id (car field)) + (field-enum-name (cadr field)) + (vel? (and #f (caddr field))) (param0 (and (>= param-count 1) (first params))) (param1 (and (>= param-count 2) (second params))) (param2 (and (>= param-count 3) (third params)))) - (when (>= last-field-id field-id) - (fmt #t "field {} must come after field {}, not before\n" field-name (car (nth last-field-id *sparticle-fields*)))) - (set! last-field-id field-id) + (when (>= *last-field-id* field-id) + (fmt #t "field {} must come after field {}, not before\n" field-name (car (nth *last-field-id* *sparticle-fields*))) + ) + (set! *last-field-id* field-id) (cond ((eq? field-name 'flags) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :initial-value (sp-cpuinfo-flag ,@param0) :random-mult 1) @@ -772,36 +787,37 @@ `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :sound ,param0 :flags (sp-flag object)) ) ((and (= 2 param-count) (symbol? param0) (eq? param0 ':copy)) - (let* ((other-field (assoc (cadr (member ':copy params)) *sparticle-fields*)) - (other-field-id (cadr other-field))) + (let* ((other-field-lookup (hash-table-try-ref *sparticle-fields* (cadr (member ':copy params)))) + (other-field (cdr other-field-lookup)) + (other-field-id (car other-field))) (when (>= other-field-id field-id) - (fmt #t "warning copying to sparticle field {} - you can only copy from fields before this one!\n" field-name)) + (fmt #t "warning copying to sparticle field {} from {} - you can only copy from fields before this one!\n" field-name (cadr other-field)) ) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag copy-from-other) :initial-value ,(- other-field-id field-id) :random-mult 1) ) ) ((and (= 2 param-count) (symbol? param0) (eq? param0 ':data)) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag object) - :pntr (the-as pointer ,(cadr (member ':data params)))) + :object ,(cadr (member ':data params))) ) ((and (= 1 param-count) (param-symbol? param0)) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag symbol) :sym ,param0) ) ((and (= 1 param-count) (param-float? param0)) - `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag float) + `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag ,(if store? 'float-store 'float)) :initial-valuef ,(if vel? `(/ ,param0 60.0) param0) :random-rangef 0.0 :random-multf 1.0) ) ((and (= 2 param-count) (param-float? param0) (param-float? param1)) - `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag float) + `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag ,(if store? 'float-store 'float)) :initial-valuef ,(if vel? `(/ ,param0 60.0) param0) :random-rangef ,(if vel? `(/ ,param1 60.0) param1) :random-multf 1.0) ) ((and (= 3 param-count) (param-float? param0) (param-float? param1) (param-float? param2)) - `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag float) + `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag ,(if store? 'float-store 'float)) :initial-valuef ,(if vel? `(/ ,param0 60.0) param0) :random-rangef ,param1 :random-multf ,(if vel? `(/ ,param2 60.0) param2)) @@ -834,8 +850,18 @@ `(new 'static 'sp-field-init-spec :field (sp-field-id spt-end)) ) ) - )) - ) init-specs) + ) + ) + ) + +(defmacro defpart (id &key (init-specs ())) + "define a new sparticle-launcher" + (begin + (set! *last-field-id* -1) + `(set! (-> *part-id-table* ,id) + (new 'static 'sparticle-launcher + :init-specs (new 'static 'inline-array sp-field-init-spec ,(1+ (length init-specs)) + ,@(apply process-init-spec init-specs) (new 'static 'sp-field-init-spec :field (sp-field-id spt-end)) ))) ) diff --git a/test/decompiler/reference/jak2/decompiler-macros.gc b/test/decompiler/reference/jak2/decompiler-macros.gc index e03a3361e6..4b6771e270 100644 --- a/test/decompiler/reference/jak2/decompiler-macros.gc +++ b/test/decompiler/reference/jak2/decompiler-macros.gc @@ -1037,27 +1037,44 @@ ) ) +(desfun param-float? (p) + (or (float? p) (and (pair? p) (eq? 'meters (car p))) (and (pair? p) (eq? 'degrees (car p)))) + ) + +(desfun param-int? (p) + (or (integer? p) (and (pair? p) (eq? 'seconds (car p)))) + ) + +(desfun param-symbol? (p) + (and (pair? p) (eq? 'quote (car p))) + ) + (seval (begin -(define *sparticle-fields* '()) +(define *sparticle-fields* (make-string-hash-table)) (doenum (name val 'sp-field-id) - (append!! *sparticle-fields* (list (if (string-starts-with? (symbol->string name) "spt-") - (string->symbol (string-substr (symbol->string name) 4 0)) - name) - val name (member name '(spt-vel-x - spt-vel-y - spt-vel-z - spt-scalevel-x - spt-scalevel-y - spt-rotvel-x - spt-rotvel-y - spt-rotvel-z - spt-fade-r - spt-fade-g - spt-fade-b - spt-fade-a - spt-accel-x - spt-accel-y - spt-accel-z)))) + (hash-table-set! + *sparticle-fields* + (if (string-starts-with? (symbol->string name) "spt-") + (string->symbol (string-substr (symbol->string name) 4 0)) + name) + (list + val name (member name '(spt-vel-x + spt-vel-y + spt-vel-z + spt-scalevel-x + spt-scalevel-y + spt-rotvel-x + spt-rotvel-y + spt-rotvel-z + spt-fade-r + spt-fade-g + spt-fade-b + spt-fade-a + spt-accel-x + spt-accel-y + spt-accel-z)) + ) + ) ) ;; you cannot define these fields ever. (define *sparticle-fields-banned* '(misc-fields-start @@ -1071,38 +1088,35 @@ end )) )) -(defmacro defpart (id &key (init-specs ())) - "define a new sparticle-launcher" - (let ((last-field-id -1) - (param-float? (lambda (p) (or (float? p) (and (pair? p) (eq? 'meters (car p))) (and (pair? p) (eq? 'degrees (car p)))))) - (param-int? (lambda (p) (or (integer? p) (and (pair? p) (eq? 'seconds (car p)))))) - (param-symbol? (lambda (p) (and (pair? p) (eq? 'quote (car p)))))) - `(set! (-> *part-id-table* ,id) - (new 'static 'sparticle-launcher - :init-specs (new 'static 'inline-array sp-field-init-spec ,(1+ (length init-specs)) - ,@(apply (lambda (x) - (let* ((head (symbol->string (car x))) +;; the last field ID defined, to make sure that fields are defined in order. +(seval (define *last-field-id* -1)) + +(desfun process-init-spec (x) + (let* ((head (symbol->string (car x))) (params (cdr x)) (field-name (string->symbol (string-substr head 1 0))) - (field (assoc field-name *sparticle-fields*))) - (when (not field) + (field-lookup (hash-table-try-ref *sparticle-fields* field-name)) + (field (cdr field-lookup)) + (store? (member ':store params)) + (param-count (if store? (1- (length params)) (length params))) + ) + (when (not (car field-lookup)) (fmt #t "unknown sparticle field {}\n" x)) (when (neq? (string-ref head 0) #\:) (fmt #t "invalid sparticle field {}\n" x)) - (when (member field-name *sparticle-fields-banned*) - (fmt #t "you cannot use sparticle field {}\n" field-name)) - (let* ((field-id (cadr field)) - (field-enum-name (caddr field)) - (vel? (and #f (cadddr field))) - (store? (member ':store params)) - (param-count (if store? (1- (length params)) (length params))) + ; (when (member field-name *sparticle-fields-banned*) + ; (fmt #t "you cannot use sparticle field {}\n" field-name)) + (let ((field-id (car field)) + (field-enum-name (cadr field)) + (vel? (and #f (caddr field))) (param0 (and (>= param-count 1) (first params))) (param1 (and (>= param-count 2) (second params))) (param2 (and (>= param-count 3) (third params)))) - (when (>= last-field-id field-id) - (fmt #t "field {} must come after field {}, not before\n" field-name (car (nth last-field-id *sparticle-fields*)))) - (set! last-field-id field-id) + (when (>= *last-field-id* field-id) + (fmt #t "field {} must come after field {}, not before\n" field-name (car (nth *last-field-id* *sparticle-fields*))) + ) + (set! *last-field-id* field-id) (cond ((eq? field-name 'flags) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :initial-value (sp-cpuinfo-flag ,@param0) :random-mult 1) @@ -1117,10 +1131,11 @@ `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :sound ,param0 :flags (sp-flag object)) ) ((and (= 2 param-count) (symbol? param0) (eq? param0 ':copy)) - (let* ((other-field (assoc (cadr (member ':copy params)) *sparticle-fields*)) - (other-field-id (cadr other-field))) + (let* ((other-field-lookup (hash-table-try-ref *sparticle-fields* (cadr (member ':copy params)))) + (other-field (cdr other-field-lookup)) + (other-field-id (car other-field))) (when (>= other-field-id field-id) - (fmt #t "warning copying to sparticle field {} - you can only copy from fields before this one!\n" field-name)) + (fmt #t "warning copying to sparticle field {} from {} - you can only copy from fields before this one!\n" field-name (cadr other-field)) ) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :flags (sp-flag copy-from-other) :initial-value ,(- other-field-id field-id) :random-mult 1) ) @@ -1179,8 +1194,18 @@ `(new 'static 'sp-field-init-spec :field (sp-field-id spt-end)) ) ) - )) - ) init-specs) + ) + ) + ) + +(defmacro defpart (id &key (init-specs ())) + "define a new sparticle-launcher" + (begin + (set! *last-field-id* -1) + `(set! (-> *part-id-table* ,id) + (new 'static 'sparticle-launcher + :init-specs (new 'static 'inline-array sp-field-init-spec ,(1+ (length init-specs)) + ,@(apply process-init-spec init-specs) (new 'static 'sp-field-init-spec :field (sp-field-id spt-end)) ))) )