value-inspector.red

Red [
	Title: 		"Red value inspector"
	Author:		"Rudolf W. MEIJER"
	File:		%value-inspector.red
	Rights:		{Copyright (c) Rudolf W. Meijer 2018}
	Purpose:	{To expose implementation information}
	Comment:	{This program shows, for a given Red value, the implementation
				 at hardware memory level; it is aware of the various Red/System
				 structures that implement value slots, and of the storage
				 schemes for series values, symbols, and contexts.}
	History:	[
					[0.0 25-Feb-2018 {Start of project}]
					[0.5 28-Feb-2018 {First working version}]
					[0.6  1-Mar-2018 {Some refactoring and
					 addition of string/symbol cache information}] 
					[0.7  2-Mar-2018 {Further refactoring and
					 streamlining of printout}]
	]
]

;---|----1----|----2----|----3----|----4----|----5----|----6----|----7----|-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; global constants
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; adapt the next line for your situation
red-sources: %/C/Users/Owner/Projects/Red/sources/

nl: "^/"
type-nr-mask: FFh
unit-size-mask: 1Fh

; further constants computed below

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; global variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

recur-stack: make block! 5

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; preliminaries
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; include ask function
; for this purpose the file %input.red and all of its dependencies
; (for Windows: %engine.red, %terminal.reds, %win32.reds and %wcwidth.reds)
; need to be present in the same directory; copy them over from red-sources
#include %input.red


; load type-data and check their consistency
#include %type-data.red

; load slot structure data and check their contents
#include %get-structures.red

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; further constants
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; set various global "constants"; the aim is to be as independent as possible
; of minor design changes in the relevant data structures

; firstly the offsets in the red-<type> structures
; of the fields that need to be further explored
; these are found through the structures-table

block-node-offset:		4 * index? find second find structures-table 'red-block!    'node
string-node-offset:		4 * index? find second find structures-table 'red-string!   'node
symbol-node-offset:		4 * index? find second find structures-table 'red-symbol!   'node
hash-node-offset:		4 * index? find second find structures-table 'red-hash!     'node
object-ctx-offset:		4 * index? find second find structures-table 'red-object!   'ctx
function-ctx-offset:	4 * index? find second find structures-table 'red-function! 'ctx
context-symbols-offset:	4 * index? find second find structures-table 'red-context!  'symbols
context-values-offset:	4 * index? find second find structures-table 'red-context!  'values
string-cache-offset:	4 * index? find second find structures-table 'red-string!   'cache
symbol-cache-offset:	4 * index? find second find structures-table 'red-symbol!   'cache

; the offsets in the series buffer are found from the file %runtime/allocator.reds
; the code to load the series-buffer! definition is in %get-structures.reds
 
series-offset-offset: 	(index? find series-def 'offset) - 1 * 2
series-tail-offset:		(index? find series-def 'tail)   - 1 * 2

; size of a value slot: 16 bytes = 4 words, i.e. header word + 3 words payload

slot-size: 16

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; include worker functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#include %value-impl.red

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; main loop
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

forever [
	clear recur-stack
	val: ask "Enter a single Red value (q to quit): "
	if val = "q" [halt]
	; check if user-supplied string is lexically valid
	unless val: attempt [load val] [
		print "not a Red value, try again"
		continue
	]
	; examine the value closer; special cases are block, word and get-word
	; event cannot be produced, error can! 
	case [
		; load packs more than one lexical item into a block
		; this block may contain a "constructor" e.g. charset or make
		; this calls for the application of reduce
		; but it may also be a literal block; in that case it is left as is
		; if the reduction fails because of a syntax error,
		; the block is also left as it is
		block? val [
			if all [
				res: attempt [reduce val]
				word? val/1
				any-function? get val/1
			][
				val: first res
			]
		]
		; bound words are evaluated
		word? val [
			; need to test explicitly for error?
			; otherwise false and none are not accepted
			unless error? res: try [do val][
				val: res
			]
		]
		; a get-word that evaluates to a function etc. will be
		; used as evaluated; other get-words will be used as is
		get-word? val [
			if all [
				not unset? attempt [do val]
				any-function? res: do val
			][
				val: :res
			]
		]
	]
	print-slot get-slot-addr 'val
]