diff --git a/common/goos/Interpreter.cpp b/common/goos/Interpreter.cpp index cbbe806c1..4c68c8d08 100644 --- a/common/goos/Interpreter.cpp +++ b/common/goos/Interpreter.cpp @@ -328,6 +328,48 @@ Arguments Interpreter::get_args(const Object& form, const Object& rest, const Ar return args; } +/*! + * Same as get_args, but named :key arguments are not parsed. + */ +Arguments Interpreter::get_args_no_named(const Object& form, + const Object& rest, + const ArgumentSpec& spec) { + Arguments args; + + // Check expected key args, which should be none + if (!spec.named.empty()) { + throw_eval_error(form, "key arguments were expected in get_args_no_named"); + } + + // loop over forms in list + Object current = rest; + while (!current.is_empty_list()) { + auto arg = current.as_pair()->car; + + // not a keyword. Add to unnamed or rest, depending on what we expect + if (spec.varargs || args.unnamed.size() < spec.unnamed.size()) { + args.unnamed.push_back(arg); + } else { + args.rest.push_back(arg); + } + current = current.as_pair()->cdr; + } + + // Check argument size, if spec defines it + if (!spec.varargs) { + if (args.unnamed.size() < spec.unnamed.size()) { + throw_eval_error(form, "didn't get enough arguments"); + } + ASSERT(args.unnamed.size() == spec.unnamed.size()); + + if (!args.rest.empty() && spec.rest.empty()) { + throw_eval_error(form, "got too many arguments"); + } + } + + return args; +} + /*! * Evaluate arguments in-place in the given environment. * Evaluation order is: @@ -768,8 +810,10 @@ Object Interpreter::eval_quote(const Object& form, const Object& rest, const std::shared_ptr& env) { (void)env; - auto args = get_args(form, rest, make_varargs()); - vararg_check(form, args, {{}}, {}); + auto args = get_args_no_named(form, rest, make_varargs()); + if (args.unnamed.size() != 1) { + throw_eval_error(form, "invalid number of arguments to quote"); + } return args.unnamed.front(); } diff --git a/common/goos/Interpreter.h b/common/goos/Interpreter.h index e3c959962..fb2c69ca6 100644 --- a/common/goos/Interpreter.h +++ b/common/goos/Interpreter.h @@ -31,6 +31,7 @@ class Interpreter { const std::shared_ptr& env, Object* result); Arguments get_args(const Object& form, const Object& rest, const ArgumentSpec& spec); + Arguments get_args_no_named(const Object& form, const Object& rest, const ArgumentSpec& spec); void set_args_in_env(const Object& form, const Arguments& args, const ArgumentSpec& arg_spec, diff --git a/common/goos/ParseHelpers.cpp b/common/goos/ParseHelpers.cpp index 74cd581e0..e80d18fbf 100644 --- a/common/goos/ParseHelpers.cpp +++ b/common/goos/ParseHelpers.cpp @@ -39,6 +39,18 @@ bool get_va(const goos::Object& rest, std::string* err_string, goos::Arguments* return true; } +bool get_va_no_named(const goos::Object& rest, std::string* err_string, goos::Arguments* result) { + goos::Arguments args; + // loop over forms in list + goos::Object current = rest; + while (!current.is_empty_list()) { + args.unnamed.push_back(current.as_pair()->car); + current = current.as_pair()->cdr; + } + *result = args; + return true; +} + bool va_check( const goos::Arguments& args, const std::vector>& unnamed, diff --git a/common/goos/ParseHelpers.h b/common/goos/ParseHelpers.h index 665558434..41718e18d 100644 --- a/common/goos/ParseHelpers.h +++ b/common/goos/ParseHelpers.h @@ -9,6 +9,7 @@ namespace goos { bool get_va(const goos::Object& rest, std::string* err_string, goos::Arguments* result); +bool get_va_no_named(const goos::Object& rest, std::string* err_string, goos::Arguments* result); bool va_check( const goos::Arguments& args, const std::vector>& unnamed, @@ -28,4 +29,4 @@ void for_each_in_list(const goos::Object& list, T f) { } int list_length(const goos::Object& list); -} // namespace goos \ No newline at end of file +} // namespace goos 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 dd5ce82f9..7b48b1379 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 @@ -326,8 +326,8 @@ (define *sparticle-fields* '()) (doenum (name val 'sp-field-id) (append!! *sparticle-fields* (list (if (string-starts-with? (symbol->string name) "spt-") - (string-substr (symbol->string name) 4 0) - (symbol->string name)) + (string->symbol (string-substr (symbol->string name) 4 0)) + name) val name (member name '(spt-vel-x spt-vel-y spt-vel-z @@ -369,13 +369,13 @@ ,@(apply (lambda (x) (let* ((head (symbol->string (car x))) (params (cdr x)) - (field-name (string-substr head 1 0)) + (field-name (string->symbol (string-substr head 1 0))) (field (assoc field-name *sparticle-fields*))) (when (not field) (fmt #t "unknown sparticle field {}\n" x)) (when (neq? (string-ref head 0) #\:) (fmt #t "invalid sparticle field {}\n" x)) - (when (member (string->symbol field-name) *sparticle-fields-banned*) + (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)) @@ -388,20 +388,20 @@ (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") + ((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) ) - ((eq? field-name "texture") + ((eq? field-name 'texture) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :tex ,param0 :flags (sp-flag int)) ) - ((eq? field-name "next-launcher") + ((eq? field-name 'next-launcher) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :initial-value ,param0 :flags (sp-flag launcher)) ) - ((eq? field-name "sound") + ((eq? field-name 'sound) `(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? (symbol->string param0) ":copy")) - (let* ((other-field (assoc (symbol->string (cadr (member (string->symbol ":copy") params))) *sparticle-fields*)) + ((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))) (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)) @@ -409,9 +409,9 @@ :initial-value ,(- other-field-id field-id) :random-mult 1) ) ) - ((and (= 2 param-count) (symbol? param0) (eq? (symbol->string param0) ":data")) + ((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 (string->symbol ":data") params)))) + :pntr (the-as pointer ,(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) 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 a65cce0f5..6662e688a 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 @@ -192,8 +192,8 @@ (define *sparticle-fields* '()) (doenum (name val 'sp-field-id) (append!! *sparticle-fields* (list (if (string-starts-with? (symbol->string name) "spt-") - (string-substr (symbol->string name) 4 0) - (symbol->string name)) + (string->symbol (string-substr (symbol->string name) 4 0)) + name) val name (member name '(spt-vel-x spt-vel-y spt-vel-z @@ -235,18 +235,18 @@ ,@(apply (lambda (x) (let* ((head (symbol->string (car x))) (params (cdr x)) - (field-name (string-substr head 1 0)) + (field-name (string->symbol (string-substr head 1 0))) (field (assoc field-name *sparticle-fields*))) (when (not field) (fmt #t "unknown sparticle field {}\n" x)) (when (neq? (string-ref head 0) #\:) (fmt #t "invalid sparticle field {}\n" x)) - (when (member (string->symbol field-name) *sparticle-fields-banned*) + (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 (string->symbol ":store") params)) + (store? (member ':store params)) (param-count (if store? (1- (length params)) (length params))) (param0 (and (>= param-count 1) (first params))) (param1 (and (>= param-count 2) (second params))) @@ -255,20 +255,20 @@ (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") + ((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) ) - ((eq? field-name "texture") + ((eq? field-name 'texture) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :tex ,param0 :flags (sp-flag int)) ) - ((eq? field-name "next-launcher") + ((eq? field-name 'next-launcher) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :initial-value ,param0 :flags (sp-flag launcher)) ) - ((eq? field-name "sound") + ((eq? field-name 'sound) `(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? (symbol->string param0) ":copy")) - (let* ((other-field (assoc (symbol->string (cadr (member (string->symbol ":copy") params))) *sparticle-fields*)) + ((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))) (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)) @@ -276,9 +276,9 @@ :initial-value ,(- other-field-id field-id) :random-mult 1) ) ) - ((and (= 2 param-count) (symbol? param0) (eq? (symbol->string param0) ":data")) + ((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) - :object ,(cadr (member (string->symbol ":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) diff --git a/goalc/compiler/Compiler.h b/goalc/compiler/Compiler.h index 36313462c..269d4327a 100644 --- a/goalc/compiler/Compiler.h +++ b/goalc/compiler/Compiler.h @@ -212,6 +212,7 @@ class Compiler { const std::function& f); goos::Arguments get_va(const goos::Object& form, const goos::Object& rest); + goos::Arguments get_va_no_named(const goos::Object& form, const goos::Object& rest); void va_check(const goos::Object& form, const goos::Arguments& args, const std::vector>& unnamed, diff --git a/goalc/compiler/Util.cpp b/goalc/compiler/Util.cpp index a1a4e12d0..203c58181 100644 --- a/goalc/compiler/Util.cpp +++ b/goalc/compiler/Util.cpp @@ -167,6 +167,19 @@ goos::Arguments Compiler::get_va(const goos::Object& form, const goos::Object& r return args; } +/*! + * Parse arguments into a goos::Arguments format. + */ +goos::Arguments Compiler::get_va_no_named(const goos::Object& form, const goos::Object& rest) { + goos::Arguments args; + + std::string err; + if (!goos::get_va_no_named(rest, &err, &args)) { + throw_compiler_error(form, err); + } + return args; +} + /*! * Check arguments in a goos::Arguments format (named and unnamed) and throw a compiler error if it * fails. diff --git a/goalc/compiler/compilation/Macro.cpp b/goalc/compiler/compilation/Macro.cpp index edde94ac3..5a178b23e 100644 --- a/goalc/compiler/compilation/Macro.cpp +++ b/goalc/compiler/compilation/Macro.cpp @@ -136,9 +136,11 @@ Val* Compiler::compile_gscond(const goos::Object& form, const goos::Object& rest * Current only supports 'thing or '(). Static lists/pairs should be added at some point. */ Val* Compiler::compile_quote(const goos::Object& form, const goos::Object& rest, Env* env) { - auto args = get_va(form, rest); - va_check(form, args, {{}}, {}); - auto thing = args.unnamed.at(0); + auto args = get_va_no_named(form, rest); + if (args.unnamed.size() != 1) { + throw_compiler_error(form, "invalid number of arguments to compile quote"); + } + auto& thing = args.unnamed.front(); switch (thing.type) { case goos::ObjectType::SYMBOL: return compile_get_sym_obj(thing.as_symbol()->name, env); diff --git a/test/decompiler/reference/jak1/decompiler-macros.gc b/test/decompiler/reference/jak1/decompiler-macros.gc index a3f492db3..ed41b360e 100644 --- a/test/decompiler/reference/jak1/decompiler-macros.gc +++ b/test/decompiler/reference/jak1/decompiler-macros.gc @@ -697,8 +697,8 @@ (define *sparticle-fields* '()) (doenum (name val 'sp-field-id) (append!! *sparticle-fields* (list (if (string-starts-with? (symbol->string name) "spt-") - (string-substr (symbol->string name) 4 0) - (symbol->string name)) + (string->symbol (string-substr (symbol->string name) 4 0)) + name) val name (member name '(spt-vel-x spt-vel-y spt-vel-z @@ -740,13 +740,13 @@ ,@(apply (lambda (x) (let* ((head (symbol->string (car x))) (params (cdr x)) - (field-name (string-substr head 1 0)) + (field-name (string->symbol (string-substr head 1 0))) (field (assoc field-name *sparticle-fields*))) (when (not field) (fmt #t "unknown sparticle field {}\n" x)) (when (neq? (string-ref head 0) #\:) (fmt #t "invalid sparticle field {}\n" x)) - (when (member (string->symbol field-name) *sparticle-fields-banned*) + (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)) @@ -759,20 +759,20 @@ (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") + ((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) ) - ((eq? field-name "texture") + ((eq? field-name 'texture) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :tex ,param0 :flags (sp-flag int)) ) - ((eq? field-name "next-launcher") + ((eq? field-name 'next-launcher) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :initial-value ,param0 :flags (sp-flag launcher)) ) - ((eq? field-name "sound") + ((eq? field-name 'sound) `(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? (symbol->string param0) ":copy")) - (let* ((other-field (assoc (symbol->string (cadr (member (string->symbol ":copy") params))) *sparticle-fields*)) + ((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))) (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)) @@ -780,9 +780,9 @@ :initial-value ,(- other-field-id field-id) :random-mult 1) ) ) - ((and (= 2 param-count) (symbol? param0) (eq? (symbol->string param0) ":data")) + ((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 (string->symbol ":data") params)))) + :pntr (the-as pointer ,(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) diff --git a/test/decompiler/reference/jak2/decompiler-macros.gc b/test/decompiler/reference/jak2/decompiler-macros.gc index 1d34764a5..e03a3361e 100644 --- a/test/decompiler/reference/jak2/decompiler-macros.gc +++ b/test/decompiler/reference/jak2/decompiler-macros.gc @@ -1041,8 +1041,8 @@ (define *sparticle-fields* '()) (doenum (name val 'sp-field-id) (append!! *sparticle-fields* (list (if (string-starts-with? (symbol->string name) "spt-") - (string-substr (symbol->string name) 4 0) - (symbol->string name)) + (string->symbol (string-substr (symbol->string name) 4 0)) + name) val name (member name '(spt-vel-x spt-vel-y spt-vel-z @@ -1084,18 +1084,18 @@ ,@(apply (lambda (x) (let* ((head (symbol->string (car x))) (params (cdr x)) - (field-name (string-substr head 1 0)) + (field-name (string->symbol (string-substr head 1 0))) (field (assoc field-name *sparticle-fields*))) (when (not field) (fmt #t "unknown sparticle field {}\n" x)) (when (neq? (string-ref head 0) #\:) (fmt #t "invalid sparticle field {}\n" x)) - (when (member (string->symbol field-name) *sparticle-fields-banned*) + (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 (string->symbol ":store") params)) + (store? (member ':store params)) (param-count (if store? (1- (length params)) (length params))) (param0 (and (>= param-count 1) (first params))) (param1 (and (>= param-count 2) (second params))) @@ -1104,20 +1104,20 @@ (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") + ((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) ) - ((eq? field-name "texture") + ((eq? field-name 'texture) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :tex ,param0 :flags (sp-flag int)) ) - ((eq? field-name "next-launcher") + ((eq? field-name 'next-launcher) `(new 'static 'sp-field-init-spec :field (sp-field-id ,field-enum-name) :initial-value ,param0 :flags (sp-flag launcher)) ) - ((eq? field-name "sound") + ((eq? field-name 'sound) `(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? (symbol->string param0) ":copy")) - (let* ((other-field (assoc (symbol->string (cadr (member (string->symbol ":copy") params))) *sparticle-fields*)) + ((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))) (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)) @@ -1125,9 +1125,9 @@ :initial-value ,(- other-field-id field-id) :random-mult 1) ) ) - ((and (= 2 param-count) (symbol? param0) (eq? (symbol->string param0) ":data")) + ((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) - :object ,(cadr (member (string->symbol ":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)