From df1a02a7df6dac2918b2e8c37012a80a4fbffe2c Mon Sep 17 00:00:00 2001 From: Hostile Fork Date: Thu, 10 Sep 2015 15:50:55 -0400 Subject: [PATCH] Add FAIL native for raising an error or error-spec The FAIL native takes the place of DO'ing an error to raise it, and is also able to take a STRING! or a BLOCK!. The string is sent to MAKE ERROR! directly, while blocks are processed in a new kind of "error creation dialect". The dialect evaluates a WORD! as long as it does not evaluate to a function, and also will evaluate parens: fail ["Problem with foo:" foo "occurred at" (1 + 2)] ...this would behave equivalently to what has been written as: do make error! form reduce [ "problem with foo:" foo "occurred at" (1 + 2) ] Limiting types is to faciliate the dialect becoming more expressive. It may use SET-WORD!, TAG!, and other choices to cue the fields and formatting template structure for the error object being returned to TRAP. Hence those types are available for future expansion. In the meantime, the PAREN!'s general-purpose-escape will allow for any substitution that FORM REDUCE might otherwise achieve. It removes a commented out prior placeholder for a FAIL-like native that was named "CAUSE". That word may make sense when paired directly with something like a variable named `error`...but as a convenience routine that might be used with (for instance) a string it doesn't communicate that an error has occurred and that execution will be interrupted. (RAISE was rejected for similar reasons.) This is planned as the replacement for DO's handling of errors. So calling DO on an ERROR! will now still raise an error, but not the one you asked for...rather an error directing the user to the use of FAIL. Similarly, THROW directs users who try and pass errors to use FAIL (as it would be a common misconception for people from other languages to think that THROW is what you are supposed to use). While a refinement was considered to allow throwing errors, the rarity of the operation and the existence of workarounds (e.g. putting the error in a block) makes it seem better to leave it. Should throwing an ERROR! turn out to be actually common, this can be reconsidered and a refinement named. --- src/boot/errors.r | 8 +++- src/boot/natives.r | 10 ++--- src/core/n-control.c | 87 +++++++++++++++++++++++++++++++++++++++- src/mezz/prot-http.r | 2 +- src/mezz/prot-tls.r | 27 ++++++++----- src/tools/common.r | 14 +++---- src/tools/make-boot.r | 4 +- src/tools/make-headers.r | 2 +- src/tools/make-make.r | 2 +- src/tools/make-os-ext.r | 2 +- src/tools/make-zlib.r | 2 +- src/tools/systems.r | 8 ++-- test | 2 +- 13 files changed, 130 insertions(+), 40 deletions(-) diff --git a/src/boot/errors.r b/src/boot/errors.r index 1c95fd49cf..e08e6ca73c 100644 --- a/src/boot/errors.r +++ b/src/boot/errors.r @@ -135,6 +135,10 @@ Script: [ trap-with-expects: [{must allow} :arg1 {as ERROR! to be TRAP handler}] + ; Temporary error while DO MAKE ERROR! constructs are still outstanding + use-fail-for-error: {Use FAIL (instead of THROW or DO) to trigger ERROR!} + limited-fail-input: {FAIL requires complex expressions to be in a PAREN!} + invalid-arg: [{invalid argument:} :arg1] invalid-type: [:arg1 {type is not allowed here}] invalid-op: [{invalid operator:} :arg1] @@ -170,8 +174,8 @@ Script: [ no-return: {block did not return a value} block-lines: {expected block of lines} - no-catch: [{no CATCH for THROW of} :arg1] - no-catch-named: [{no CATCH for THROW of} :arg1 {with /NAME:} :arg2] + no-catch: [{Missing CATCH for THROW of} :arg1] + no-catch-named: [{Missing CATCH for THROW of} :arg1 {with /NAME:} :arg2] locked-word: [{protected variable - cannot modify:} :arg1] protected: {protected value or series - cannot modify} diff --git a/src/boot/natives.r b/src/boot/natives.r index 18082f528c..2907ef7946 100644 --- a/src/boot/natives.r +++ b/src/boot/natives.r @@ -83,11 +83,6 @@ catch: native [ handler [block! any-function!] {If FUNCTION!, spec matches [value name]} ] -;cause: native [ -; {Force error processing on an error value.} -; error [error!] -;] - comment: native [ {Ignores the argument value and returns nothing (no evaluations performed).} :value [block! any-string! scalar!] {Literal value to be ignored.} @@ -157,6 +152,11 @@ exit: native [ value [any-type!] ] +fail: native [ + {Interrupts execution by reporting an error (a TRAP can intercept it).} + reason [error! string! block!] {ERROR! value, message string, or failure spec} +] + find-script: native [ {Find a script header within a binary string. Returns starting position.} script [binary!] diff --git a/src/core/n-control.c b/src/core/n-control.c index 252626ca01..ee247f520a 100755 --- a/src/core/n-control.c +++ b/src/core/n-control.c @@ -674,6 +674,18 @@ enum { REBOOL named = D_REF(2); REBVAL * const name_value = D_ARG(3); + if (IS_ERROR(value)) { + // We raise an alert from within the implementation of throw for + // trying to use it to trigger errors, because if THROW just didn't + // take errors in the spec it wouldn't guide what *to* use. + // + raise Error_0(RE_USE_FAIL_FOR_ERROR); + + // Note: Caller can put the ERROR! in a block or use some other + // such trick if it wants to actually throw an error. + // (Better than complicating throw with /error-is-intentional!) + } + if (named) { // blocks as names would conflict with name_list feature in catch assert(!IS_BLOCK(name_value)); @@ -824,7 +836,9 @@ enum { return R_OUT; case REB_ERROR: - raise Error_Is(value); + // This path will no longer raise the error you asked for, though it + // will still raise *an* error directing you to use FAIL.) + raise Error_0(RE_USE_FAIL_FOR_ERROR); case REB_BINARY: case REB_STRING: @@ -903,6 +917,77 @@ enum { } +/*********************************************************************** +** +*/ REBNATIVE(fail) +/* +***********************************************************************/ +{ + REBVAL * const reason = D_ARG(1); + + if (IS_ERROR(reason)) { + raise Error_Is(reason); + } + else if (IS_STRING(reason) || IS_BLOCK(reason)) { + // Ultimately we'd like FAIL to use some clever error-creating + // dialect when passed a block, maybe something like: + // + // fail [ {The key} key-name: key {is invalid}] + // + // That could provide an error ID, the format message, and the + // values to plug into the slots to make the message...which could + // be extracted from the error if captured (e.g. error/id and + // `error/key-name`. Another option would be something like: + // + // fail/with [{The key} :key-name {is invalid}] [key-name: key] + // + if (IS_BLOCK(reason)) { + // Check to make sure we're only drawing from the limited types + // we accept (reserving room for future dialect expansion) + REBCNT index = VAL_INDEX(reason); + for (; index < SERIES_LEN(VAL_SERIES(reason)); index++) { + REBVAL *item = BLK_SKIP(VAL_SERIES(reason), index); + if (IS_STRING(item) || IS_SCALAR(item) || IS_PAREN(item)) + continue; + + // We don't want to dispatch functions directly (use parens) + + // !!! This keeps the option open of being able to know that + // strings that appear in the block appear in the error + // message so it can be templated. + + if (IS_WORD(item)) { + const REBVAL *var = TRY_GET_VAR(item); + if (!var || !ANY_FUNC(var)) + continue; + } + + // The only way to tell if a path resolves to a function + // or not is to actually evaluate it, and we are delegating + // to Reduce_Block ATM. For now we force you to use a PAREN! + // + // fail [{Erroring on} (the/safe/side) {for now.}] + + raise Error_0(RE_LIMITED_FAIL_INPUT); + } + + // We just reduce and form the result, but since we allow PAREN! + // it means you can put in pretty much any expression. + Reduce_Block(reason, VAL_SERIES(reason), VAL_INDEX(reason), FALSE); + Val_Init_String(reason, Copy_Form_Value(reason, 0)); + } + + if (!Make_Error_Object(D_OUT, reason)) { + assert(THROWN(D_OUT)); + return R_OUT; + } + raise Error_Is(D_OUT); + } + + DEAD_END; +} + + /*********************************************************************** ** */ REBNATIVE(if) diff --git a/src/mezz/prot-http.r b/src/mezz/prot-http.r index 9a4e31cc3c..ecc93ea49f 100644 --- a/src/mezz/prot-http.r +++ b/src/mezz/prot-http.r @@ -52,7 +52,7 @@ read-sync-awake: func [event [event!] /local error] [ error [ error: event/port/state/error event/port/state/error: none - do error + fail error ] ] [ false diff --git a/src/mezz/prot-tls.r b/src/mezz/prot-tls.r index 805970ab03..d5c53282cf 100644 --- a/src/mezz/prot-tls.r +++ b/src/mezz/prot-tls.r @@ -242,7 +242,7 @@ update-proto-state: func [ debug ["new-state:" new-state] ctx/protocol-state: new-state ] [ - do make error! "invalid protocol state" + fail "invalid protocol state" ] ] @@ -548,7 +548,7 @@ parse-protocol: func [ /local proto ] [ unless proto: select protocol-types data/1 [ - do make error! "unknown/invalid protocol type" + fail "unknown/invalid protocol type" ] return context [ type: proto @@ -686,7 +686,10 @@ parse-messages: func [ ctx/hash-size: 20 ] ] cipher-suites [ - do make error! rejoin ["Current version of TLS scheme doesn't support ciphersuite: " mold ctx/cipher-suite] + fail [ + "This TLS scheme doesn't support ciphersuite:" + (mold ctx/cipher-suite) + ] ] ctx/server-random: msg-obj/server-random @@ -749,7 +752,7 @@ parse-messages: func [ msg-obj ] ] [ - do make error! "Server-key-exchange message has been sent illegally." + fail "Server-key-exchange message sent illegally." ] ] server-hello-done [ @@ -771,7 +774,7 @@ parse-messages: func [ ctx/seq-num-r: 0 msg-content: copy/part at data 5 len either msg-content <> prf ctx/master-secret either ctx/server? ["client finished"] ["server finished"] rejoin [checksum/method ctx/handshake-messages 'md5 checksum/method ctx/handshake-messages 'sha1] 12 [ - do make error! "Bad 'finished' MAC" + fail "Bad 'finished' MAC" ] [ debug "FINISHED MAC verify: OK" ] @@ -796,7 +799,7 @@ parse-messages: func [ copy/part data len + 4 ] ctx/hash-method decode 'text ctx/server-mac-key [ - do make error! "Bad handshake record MAC" + fail "Bad handshake record MAC" ] 4 + ctx/hash-size ] [ @@ -826,7 +829,7 @@ parse-messages: func [ msg-obj/content ; content ] ctx/hash-method decode 'text ctx/server-mac-key [ - do make error! "Bad application record MAC" + fail "Bad application record MAC" ] ] ] @@ -842,14 +845,16 @@ parse-response: func [ ] [ proto: parse-protocol msg either empty? messages: parse-messages ctx proto [ - do make error! "unknown/invalid protocol message" + fail "unknown/invalid protocol message" ] [ proto/messages: messages ] debug ["processed protocol type:" proto/type "messages:" length proto/messages] - unless tail? skip msg proto/size + 5 [do make error! "invalid length of response fragment"] + unless tail? skip msg proto/size + 5 [ + fail "invalid length of response fragment" + ] return proto ] @@ -928,7 +933,7 @@ do-commands: func [ write ctx/connection ctx/msg unless no-wait [ - unless port? wait [ctx/connection 30] [do make error! "port timeout"] + unless port? wait [ctx/connection 30] [fail "port timeout"] ] ctx/resp ] @@ -1093,7 +1098,7 @@ tls-awake: function [event [event!]] [ ] ] [ close port - do make error! rejoin ["Unexpected TLS event: " event/type] + fail ["Unexpected TLS event:" (event/type)] ] false ] diff --git a/src/tools/common.r b/src/tools/common.r index 0a4548ec50..e58f23fc15 100644 --- a/src/tools/common.r +++ b/src/tools/common.r @@ -85,11 +85,11 @@ for-each-record-NO-RETURN: func [ /local headings result spec ] [ unless block? first table [ - do make error! {Table of records does not start with a header block} + fail {Table of records does not start with a header block} ] headings: map-each word first table [ unless word? word [ - do make error! rejoin [{Heading} space word space {is not a word}] + fail [{Heading} word {is not a word}] ] to-set-word word ] @@ -98,7 +98,7 @@ for-each-record-NO-RETURN: func [ set/any quote result: while [not empty? table] [ if (length headings) > (length table) [ - do make error! {Element count isn't even multiple of header count} + fail {Element count isn't even multiple of header count} ] spec: collect [ @@ -126,9 +126,7 @@ find-record-unique: func [ /local rec result ] [ unless find first table key [ - do make error! rejoin [ - key space {not found in table headers} space first table - ] + fail [key {not found in table headers:} (first table)] ] result: none @@ -136,9 +134,7 @@ find-record-unique: func [ unless value = select rec key [continue] if result [ - do make error! rejoin [ - {More than one table record matches} space key {=} value - ] + fail [{More than one table record matches} key {=} value] ] result: rec diff --git a/src/tools/make-boot.r b/src/tools/make-boot.r index 2b343ab336..c46cb24291 100644 --- a/src/tools/make-boot.r +++ b/src/tools/make-boot.r @@ -657,7 +657,7 @@ for-each [cat msgs] boot-errors [ either get-word? item [{ %v }] [item] ] ] - true [do make error! {Non-STRING! non-BLOCK! as %errors.r value}] + true [fail {Non-STRING! non-BLOCK! as %errors.r value}] ] append code null ] @@ -904,7 +904,7 @@ for-each [cat msgs] boot-errors [ emit newline ] -if errs [do make error! "Invalid errors.r input"] +if errs [fail "Invalid errors.r input"] emit-end diff --git a/src/tools/make-headers.r b/src/tools/make-headers.r index 77bd849e63..0ed3465bb5 100644 --- a/src/tools/make-headers.r +++ b/src/tools/make-headers.r @@ -85,7 +85,7 @@ func-header: [ newline http://stackoverflow.com/questions/693788/c-void-arguments ] - do make error! "C++ no-arg prototype used instead of C style" + fail "C++ no-arg prototype used instead of C style" ] append-spec spec diff --git a/src/tools/make-make.r b/src/tools/make-make.r index 5f2f057574..733b0a1d5a 100644 --- a/src/tools/make-make.r +++ b/src/tools/make-make.r @@ -279,7 +279,7 @@ append plat-id config/id/3 ; Collect OS-specific host files: unless os-specific-objs: select file-base to word! join "os-" config/os-base [ - do make error! rejoin [ + fail rejoin [ "make-make.r requires os-specific obj list in file-base.r" newline "none was provided for os-" config/os-base ] diff --git a/src/tools/make-os-ext.r b/src/tools/make-os-ext.r index bb4f2612b4..0a108c6a92 100644 --- a/src/tools/make-os-ext.r +++ b/src/tools/make-os-ext.r @@ -33,7 +33,7 @@ change-dir %../os/ ; Collect OS-specific host files: unless os-specific-objs: select file-base to word! join "os-" config/os-base [ - do make error! rejoin [ + fail rejoin [ "make-os-ext.r requires os-specific obj list in file-base.r" space "none was provided for os-" config/os-base ] diff --git a/src/tools/make-zlib.r b/src/tools/make-zlib.r index 1d5b3fecd4..715dd85dce 100644 --- a/src/tools/make-zlib.r +++ b/src/tools/make-zlib.r @@ -77,7 +77,7 @@ disable-user-includes: func [ ; If we inline a header, it should happen once and only once for each unless empty? headers [ - throw make error! rejoin [{Not all headers inlined by make-zlib:} space mold headers] + fail [{Not all headers inlined by make-zlib:} (mold headers)] ] ] diff --git a/src/tools/systems.r b/src/tools/systems.r index 66cb3af59a..4e5bbda474 100644 --- a/src/tools/systems.r +++ b/src/tools/systems.r @@ -188,7 +188,7 @@ config-system: func [ ][ ; Don't override a literal version tuple with a guess if all [guess version] [ - do make error! "config-system called with both /version and /guess" + fail "config-system called with both /version and /guess" ] id: any [ @@ -202,7 +202,7 @@ config-system: func [ probe hint hint: load hint unless tuple? hint [ - do make error! rejoin [ + fail [ "Expected platform id (tuple like 0.3.1), not:" hint ] ] @@ -214,8 +214,8 @@ config-system: func [ ] unless result: find-record-unique systems 'id id [ - do make error! rejoin [ - {No table entry for} space version space {found in systems.r} + fail [ + {No table entry for} version {found in systems.r} ] ] diff --git a/test b/test index 209cbcf04e..63758e9c58 160000 --- a/test +++ b/test @@ -1 +1 @@ -Subproject commit 209cbcf04e824d05e6f1b4ce8b0cee7a6abdc170 +Subproject commit 63758e9c5833d3007d2c907aa517b6e54b9d2f5a