Add FAIL native for raising an error or error-spec

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}

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!]

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 [<invalid-key> {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)

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

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
 ]

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,19 +126,15 @@ 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
 	for-each-record-NO-RETURN rec table [
 		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

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
 

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

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
 	]

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
 	]

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)]
 	]
 ]
 

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}
 		]
 	]