-
Notifications
You must be signed in to change notification settings - Fork 7
/
Copy pathexceptions.lisp
186 lines (177 loc) · 9.4 KB
/
exceptions.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
;;; -*- Syntax: Common-Lisp; Base: 10 -*-
;;;
;;; Copyright (c) 2024 Gary Palter
;;;
;;; Licensed under the MIT License;
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; https://opensource.org/license/mit
(in-package #:forth)
(defvar *forth-exceptions-map* (make-hash-table))
(defmacro define-forth-exceptions (&body body)
`(progn
(clrhash *forth-exceptions-map*)
(dolist (exception ',body)
(destructuring-bind (key code default-phrase)
exception
(setf (gethash key *forth-exceptions-map*) (list code default-phrase))))))
(define-forth-exceptions
(:abort -1 "ABORT")
(:abort\" -2 "ABORT\"")
(:stack-overflow -3 "Stack overflow")
(:stack-underflow -4 "Stack underflow")
(:return-stack-overflow -5 "Return stack overflow")
(:return-stack-underflow -6 "Return stack underflow")
(:do-loops-nesting -7 "DO loops nested too deeply during execution")
(:dictionary-overflow -8 "Dictionary overflow")
(:invalid-memory -9 "Invalid memory address")
(:divide-by-zero -10 "Division by zero")
(:out-of-range -11 "Result out of range")
(:type-mismatch -12 "Argument type mismatch")
(:undefined-word -13 "Undefined word")
(:compile-only-word -14 "Interpreting a compile-only word")
(:invalid-forget -15 "Invalid FORGET")
(:zero-length-name -16 "Attempt to use zero-length string as a name")
(:pictured-output-overflow -17 "Pictured numeric output string overflow")
(:parse-string-overflow -18 "Parsed string overflow")
(:name-too-long -19 "Definition name too long")
(:write-to-read-only-memory -20 "Write to a read-only location")
(:unsuppored-operation -21 "Unsupported operation")
(:control-mismatch -22 "Control structure mismatch")
(:aligment-exception -23 "Address alignment exception")
(:invalid-numeric-argument -24 "Invalid numeric argument")
(:return-stack-imbalance -25 "Return stack imbalance")
(:no-loop-parameters -26 "Loop parameters unavailable")
(:invalid-recursion -27 "Invalid recursion")
(:user-interrupt -28 "User interrupt")
(:recursive-compile -29 "Compiler nesting")
(:obsolete-feature -30 "Obsolescent feature")
(:invalid->body -31 ">BODY used on non-CREATEd definition")
(:invalid-name-argument -32 "Invalid name argument")
(:block-read-exception -33 "Block read exception")
(:block-write-exception -34 "Block write exception")
(:invalid-block-number -35 "Invalid block number")
(:invalid-file-position -36 "Invalid file position")
(:file-i/o-exception -37 "File I/O exception")
(:file-not-found -38 "Non-existent file")
(:unexpected-eof -39 "Unexpected end of file")
(:invalid-floating-base -40 "Invalid BASE for floating point conversion")
(:loss-of-precision -41 "Loss of precision")
(:floating-divide-by-zero -42 "Floating-point divide by zero")
(:floating-out-of-range -43 "Floating-point result out of range")
(:float-stack-overflow -44 "Floating-point stack overflow")
(:float-stack-underflow -45 "Floating-point stack underflow")
(:float-invalid-argument -46 "Floating-point invalid argument")
(:compilation-word-list-deleted -47 "Compilation word list deleted")
(:invalid-postpone -48 "Invalid POSTPONE")
(:search-order-overflow -49 "Search-order overflow")
(:search-order-underflow -50 "Search-order underflow")
(:compilation-word-list-changed -51 "Compilation word list changed")
(:control-flow-stack-overflow -52 "Control-flow stack overflow")
(:exception-stack-overflow -53 "Exception stack overflow")
(:float-underflow -54 "Floating-point underflow")
(:float-unknown-fault -55 "Floating-point unidentified fault")
(:quit -56 "QUIT")
(:send/receive-char-exception -57 "Exception in sending or receiving a character")
(:if/then/else-exception -58 "[IF], [ELSE], or [THEN] exception")
(:allocate-exception -59 "ALLOCATE exception")
(:free-exception -60 "FREE exception")
(:resize-exception -61 "RESIZE exception")
(:close-file-exception -62 "CLOSE-FILE exception")
(:create-file-exception -63 "CREATE-FILE exception")
(:delete-file-exception -64 "DELETE-FILE exception")
(:file-position-exception -65 "FILE-POSITION exception")
(:file-size-exception -66 "FILE-SIZE exception")
(:file-status-exception -67 "FILE-STATUS exception")
(:flush-file-exception -68 "FLUSH-FILE exception")
(:open-file-exception -69 "OPEN-FILE exception")
(:read-file-exception -70 "READ-FILE exception")
(:read-line-exception -71 "READ-LINE exception")
(:rename-file-exception -72 "RENAME-FILE exception")
(:reposition-file-exception -73 "REPOSITION-FILE exception")
(:resize-file-exception -74 "RESIZE-FILE exception")
(:write-file-exception -75 "WRITE-FILE exception")
(:write-line-exception -76 "WRITE-LINE exception")
(:malformed-xchar -77 "Malformed extended character")
(:substitute-exception -78 "SUBSTITUTE exception")
(:replaces-exception -79 "REPLACES exception")
;;
;; CL-Forth specific exceptions
(:unknown-slot -256 "Unknown slot")
(:control-flow-stack-underflow -257 "Control-flow stack empty")
(:unknown-word-list -258 "Unknown word list")
(:duplicate-word-list -259 "A word list by that name already exists")
(:source-stack-overflow -260 "Input source stack overflow")
(:source-stack-underflow -261 "Input source stack underflow")
(:not-compiling -262 "Not compiling a definition")
(:parse-integer-failure -263 "Conversion to an integer failed")
(:optional-not-in-file -264 "OPTIONAL can only be used when including a file")
(:no-execution-token -265 "No execution token available")
(:recursive-pictured-output -266 "Pictured output already in progress")
(:no-pictured-output -267 "Pictured output not in progress")
(:definitions-stack-overflow -268 "Too many DOES> words in definition")
(:definitions-stack-underflow -269 "Internal error: definitions stack underflow")
(:save-restore-input-mismatch -270 "Saved input source doesn't match current source")
(:not-defer -271 "Not a DEFER definition")
(:defer-not-set -272 "Execution token not set in DEFER definition")
(:not-a-name-token -273 "Not a name token")
(:exception-stack-underflow -274 "Exception stack underflow")
(:loop-stack-underflow -275 "DO loops stack underflow")
(:interpret-only-word -276 "Compiling an interpreted-only word")
(:data-space-overflow -277 "Out of memory")
(:invalid-does> -278 "DOES> used on non-CREATEd definition")
(:too-many-locals -279 "Too many locals in a definition")
(:multiple-local-blocks -280 "Only one set of locals per definition is allowed")
(:locals-in-control-flow -281 "Can't define locals inside control flow structures")
(:unterminated-locals-block -282 "Locals block not complete")
(:invalid-local-name -283 "Invalid name for a LOCAL")
(:no-foreign-library -301 "No foreign library loaded")
(:cant-load-foreign-library -302 "Can't load foreign library")
(:undefined-foreign-function -303 "Foreign function not defined")
(:undefined-foreign-global -304 "Foreign global not defined")
(:invalid-foreign-parameter-list -305 "Invalid foreign function parameter llist")
(:missing-foreign-definition -306 "AS or [OPTIONAL] not followed by LIBRARY, FUNCTION:, or GLOBAL:")
(:no-platform-library -307 "No library for this platform found")
(:null-pointer-reference -308 "Attempt to reference through a null pointer")
(:duplicate-as-clauses -309 "AS appears more than once in a definition")
(:duplicate-optional-clauses -310 "[OPTIONAL] appears more than once in a definition")
(:optimizer-stack-overflow -311 "Expression too complex for optimizer")
(:optimizer-stack-underflow -312 "Optimizer stack underflow")
)
(define-condition forth-exception (error)
((key :initarg :key :reader forth-exception-key)
(code :initarg :code :reader forth-exception-code)
(phrase :initarg :phrase :reader forth-exception-phrase))
(:report (lambda (fe stream)
(format stream "Forth exception ~D: ~A" (forth-exception-code fe) (forth-exception-phrase fe)))))
(defun forth-exception (key &optional phrase &rest phrase-arguments)
(let ((entry (gethash key *forth-exceptions-map*))
(phrase (and phrase (apply #'format nil phrase phrase-arguments))))
(if entry
(destructuring-bind (code default-phrase) entry
(error 'forth-exception :key key :code code :phrase (or phrase default-phrase)))
(error 'forth-exception :key :bad-exception-key :code -999 :phrase (format nil "Unrecognized exception key ~S" key)))))
(defun forth-exception-key-to-code (key)
(let ((entry (gethash key *forth-exceptions-map*)))
(and entry
(destructuring-bind (code default-phrase) entry
(declare (ignore default-phrase))
code))))
(defun forth-exception-key-to-phrase (key)
(let ((entry (gethash key *forth-exceptions-map*)))
(and entry
(destructuring-bind (code default-phrase) entry
(declare (ignore code))
default-phrase))))
(defun forth-exception-by-code (code)
(let ((key (block find-key
(maphash #'(lambda (key entry) (when (= (car entry) code) (return-from find-key key))) *forth-exceptions-map*)
nil)))
(cond (key
(forth-exception key))
((plusp code)
(error 'forth-exception :key :user-defined :code code :phrase (format nil "User defined exception code ~D" code)))
(t
(error 'forth-exception :key :system-defined :code code
:phrase (format nil "Unrecognized system exception code ~D" code))))))