FEAT: Binding ti deflateInit2_ added

FEAT: Binding ti deflateInit2_ added

Red/System [
  Title:   "Red/System ZLib Binding"
  Author:  "Bruno Anselme"
  EMail:   "be.red@free.fr"
  File:    %zlibs.reds
  Rights:  "Copyright (c) 2013 Bruno Anselme"
  License: {
    Distributed under the Boost Software License, Version 1.0.
    See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
  }
  Needs: {
    Red/System >= 0.3.2
    zlib       >= 1.2.6
  }
  References: {
    http://www.zlib.net/
  }
]

#include %../stdio.reds

zlib: context [

  #import [
    LIBC-file cdecl [
      re-allocate:  "realloc" [
        base       [byte-ptr!]
        size       [integer!]
        return:    [byte-ptr!]
      ]
    ]
  ]

  #define opaque!  integer!
  #define Z_NULL  0             ; for initializing zalloc, zfree, opaque

  ; Allowed flush values.
  #define Z_NO_FLUSH       0
  #define Z_PARTIAL_FLUSH  1
  #define Z_SYNC_FLUSH     2
  #define Z_FULL_FLUSH     3
  #define Z_FINISH         4
  #define Z_BLOCK          5
  #define Z_TREES          6

  ; Return codes for the compression/decompression functions. Negative values
  ;  are errors, positive values are used for special but normal events.
  #define Z_OK             0
  #define Z_STREAM_END     1
  #define Z_NEED_DICT      2
  #define Z_ERRNO         -1
  #define Z_STREAM_ERROR  -2
  #define Z_DATA_ERROR    -3
  #define Z_MEM_ERROR     -4
  #define Z_BUF_ERROR     -5
  #define Z_VERSION_ERROR -6

  ; Compression levels
  #define Z_NO_COMPRESSION         0
  #define Z_BEST_SPEED             1
  #define Z_BEST_COMPRESSION       9
  #define Z_DEFAULT_COMPRESSION   -1

  #define CHUNK 16384                   ; Buffer size for file (de)compression

  #switch OS [
    Windows   [
      #define z-library "zlib1.dll"
    ]
    MacOSX    [
      #define z-library "libz.1.dylib"  ; TODO: check this
    ]
    #default  [
      #define z-library "libz.so.1"
    ]
  ]

  z_stream!: alias struct! [
    next_in        [byte-ptr!]     ; next input byte
    avail_in       [integer!]      ; number of bytes available at next_in
    total_in       [integer!]      ; total number of input bytes read so far

    next_out       [byte-ptr!]     ; next output byte should be put there
    avail_out      [integer!]      ; remaining free space at next_out
    total_out      [integer!]      ; total number of bytes output so far

    msg            [c-string!]     ; last error message, NULL if no error
    state          [integer!]      ; not visible by applications

    zalloc         [opaque!]       ; used to allocate the internal state (function pointer)
    zfree          [opaque!]       ; used to free the internal state (function pointer)
    opaque         [opaque!]       ; private data object passed to zalloc and zfree (function pointer)

    data_type      [integer!]      ; best guess about the data type: binary or text
    adler          [integer!]      ; adler32 value of the uncompressed data
    reserved       [integer!]      ; reserved for future use
  ]

  #import [z-library cdecl [
    version: "zlibVersion" [       ; Return zlib library version.
      return:   [c-string!]
    ]

    deflateInit_: "deflateInit_" [
      strm         [z_stream!]
      level        [integer!]
      version      [c-string!]
      stream_size  [integer!]
      return:      [integer!]
    ]

    deflateInit2_: "deflateInit2_" [
      strm         [z_stream!]
      level        [integer!]
      method       [integer!]
      windowBits   [integer!]
      memlevel     [integer!]
      strategy     [integer!]
      return:      [integer!]
    ]

    z-deflateEnd: "deflateEnd" [
      strm         [z_stream!]
      return:      [integer!]
    ]

    z-deflate: "deflate" [
      strm         [z_stream!]
      flush        [integer!]
      return:      [integer!]
    ]

    inflateInit_: "inflateInit_" [
      strm         [z_stream!]
      version      [c-string!]
      stream_size  [integer!]
      return:      [integer!]
    ]

    z-inflateEnd: "inflateEnd" [
      strm         [z_stream!]
      return:      [integer!]
    ]

    z-inflate: "inflate" [
      strm         [z_stream!]
      flush        [integer!]
      return:      [integer!]
    ]

    compressBound: "compressBound" [
      sourceLen    [integer!]
      return:      [integer!]
    ]

    z-compress: "compress2" [
      out-buf      [byte-ptr!]           "Pointer to destination data"
      out-count    [int-ptr!]            "Pointer to destination size, returns output buffer size"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      level        [integer!]            "Compression level"
      return:      [integer!]
    ]

    z-uncompress: "uncompress" [
      out-buf      [byte-ptr!]           "Pointer to destination data"
      out-count    [int-ptr!]            "Pointer to destination size, returns output buffer size"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      return:      [integer!]
    ]

  ] ; cdecl
  ] ; #import [z-library

  ; Higher level interface ---------------------------- ---------------------------------------

  with zlib [

     z-inflateInit: function [
      strm         [z_stream!]
      return:      [integer!]
    ][
      inflateInit_ strm version size? z_stream!
    ]

    z-deflateInit: function [
      strm         [z_stream!]
      level        [integer!]
      return:      [integer!]
    ][
      deflateInit_ strm level version size? z_stream!
    ]

    z-deflateInit2: function [
      strm         [z_stream!]
      level        [integer!]
      method       [integer!]
      windowBits   [integer!]
      memlevel     [integer!]
      strategy     [integer!]
      return:      [integer!]
    ][
      deflateInit2_ strm level Z_DEFLATED (15 or 32) 8 Z_DEFAULT_STRATEGY
    ]

#define END_Z_FUNC   [z-deflateEnd strm  free buf-out  free buf-in  free as byte-ptr! strm]

    deflate: function [
      src          [file!]
      dest         [file!]
      level        [integer!]
      return:      [integer!]
      /local ret have flush buf-in buf-out
             strm     [z_stream!]
    ][
      strm: as z_stream! allocate (size? z_stream!)
      if strm = NULL [
        print [ "Deflate: Memory allocation error." lf ]
        return Z_ERRNO
      ]
      buf-in: allocate CHUNK
      if buf-in = NULL [
        print [ "Deflate: Input buffer allocation error." lf ]
        free as byte-ptr! strm
        return Z_ERRNO
      ]
      buf-out: allocate CHUNK
      if buf-out = NULL [
        print [ "Deflate: Output buffer allocation error." lf ]
        free buf-in
        free as byte-ptr! strm
        return Z_ERRNO
      ]
      strm/zalloc: Z_NULL
      strm/zfree: Z_NULL
      strm/opaque: Z_NULL
      ret: z-deflateInit strm level
      if ret <> Z_OK [
        print [ "Deflate: Error deflateInit : " ret lf ]
        END_Z_FUNC
        return Z_ERRNO
      ]
      until [
        strm/avail_in: read-file buf-in 1 CHUNK src
        if file-error? src [
          print [ "Deflate: Input file error : " ret lf ]
          END_Z_FUNC
          return Z_ERRNO ; FIXME: find best error number
        ]
        either file-tail? src [ flush: Z_FINISH ][ flush: Z_NO_FLUSH ]
        strm/next_in: buf-in
        until [
          strm/avail_out: CHUNK
          strm/next_out: buf-out
          ret: z-deflate strm flush
          if ret = Z_STREAM_ERROR [
            print [ "Deflate: Data stream error" lf ]
            END_Z_FUNC
            return Z_ERRNO
          ]
          have: CHUNK - strm/avail_out
          ret: write-file buf-out 1 have dest
          if any [ (ret <> have) (file-error?  dest) ][
            END_Z_FUNC
            return Z_ERRNO
          ]
          strm/avail_out <> 0
        ]
        flush = Z_FINISH
      ]
      END_Z_FUNC
      return Z_OK
    ]

    compress: func [                     "Compress a byte array"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      out-count    [int-ptr!]            "Pointer to integer, returns output buffer size"
      level        [integer!]            "Compression level"
      return:      [byte-ptr!]           "Returns a pointer to compressed data"
      /local ret out-buf tmp
    ][
      out-count/value: compressBound in-count
      out-buf: allocate out-count/value         ; allocate the size of original buffer
      if out-buf = NULL [
        print [ "Compress Error : Output buffer allocation error." lf ]
        return NULL
      ]
      ret: z-compress out-buf out-count in-buf in-count level
      either ret = Z_OK [
        tmp: re-allocate out-buf out-count/value        ; Resize output buffer to minimum size
        either tmp = NULL [                             ; reallocation failed, uses current output buffer
          print [ "Compress Warning : Impossible to reallocate output buffer." lf ]
        ][                                              ; reallocation succeeded, uses reallocated buffer
          out-buf: tmp
        ]
        return out-buf
      ][
        case [
          ret = Z_MEM_ERROR    [ print [ "Compress Error : not enough memory." lf ] ]
          ret = Z_BUF_ERROR    [ print [ "Compress Error : not enough room in the output buffer." lf ] ]
          ret = Z_STREAM_ERROR [ print [ "Compress Error : invalid compression level parameter." lf ] ]
        ]
        free out-buf
        return NULL
      ]
    ] ; compress

    decompress: func [                   "Decompress a byte array"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      return:      [byte-ptr!]           "Return a pointer to decompressed data"
      /local ret out-buf tmp
      out-count    [integer!]
    ][
      out-count: 2 * in-count                             ; allocate twice the size of original buffer
      out-buf: allocate out-count
      if out-buf = NULL [
        print [ "Decompress Error : Output buffer allocation error." lf ]
        return NULL
      ]
      until [
        ret: z-uncompress out-buf :out-count in-buf in-count
        if ret = Z_BUF_ERROR [                            ; need to expand output buffer
          out-count: 2 * out-count                        ; double buffer size
          tmp: re-allocate out-buf out-count              ; Resize output buffer to minimum size
          either tmp = NULL [                             ; reallocation failed, uses current output buffer
            print [ "Decompress Error : Impossible to reallocate output buffer." lf ]
            ret: Z_MEM_ERROR
          ][                                              ; reallocation succeeded, uses reallocated buffer
            out-buf: tmp
          ]
        ]
        any [ (ret = Z_OK) (ret = Z_MEM_ERROR) (ret = Z_STREAM_ERROR) ]
      ]
      either ret = Z_OK [
        tmp: re-allocate out-buf out-count              ; Resize output buffer to minimum size
        either tmp = NULL [                             ; reallocation failed, uses current output buffer
          print [ "Decompress Warning : Impossible to reallocate output buffer." lf ]
        ][                                              ; reallocation succeeded, uses reallocated buffer
          out-buf: tmp
        ]
        return out-buf
      ][
        case [
          ret = Z_MEM_ERROR    [ print [ "Decompress Error : not enough memory." lf ] ]
          ret = Z_BUF_ERROR    [ print [ "Decompress Error : not enough room in the output buffer." lf ] ]
          ret = Z_STREAM_ERROR [ print [ "Decompress Error : invalid compression level parameter." lf ] ]
        ]
      ]
      return out-buf
    ]

    bin-to-str: func [             "Convert a byte array into an hex string."
      address [byte-ptr!]          "Memory address where the conversion starts"
      limit   [integer!]           "Number of bytes to convert"
      return: [c-string!]          "Return a c string"
      /local i str cnum byte major minor
    ][
      str: make-c-string (1 + (2 * limit))
      i: 0
      cnum: 0
      until [
        byte: as integer! address/value
        minor: byte // 16
        if minor > 9 [minor: minor + 7]         ;-- 7 = (#"A" - 1) - #"9"
        byte: byte >>> 4
        major: byte // 16
        if major > 9 [major: major + 7]         ;-- 7 = (#"A" - 1) - #"9"

        cnum: cnum + 1
        str/cnum: #"0" + major
        cnum: cnum + 1
        str/cnum: #"0" + minor

        address: address + 1
        i: i + 1
        i = limit
      ]
      cnum: cnum + 1
      str/cnum: #"^(00)"  ; c string ending char
      str
    ]
  ] ; with zlib
] ; context zlib

Red/System [
  Title:   "Red/System ZLib Binding"
  Author:  "Bruno Anselme"
  EMail:   "be.red@free.fr"
  File:    %zlibs.reds
  Rights:  "Copyright (c) 2013 Bruno Anselme"
  License: {
    Distributed under the Boost Software License, Version 1.0.
    See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
  }
  Needs: {
    Red/System >= 0.3.2
    zlib       >= 1.2.6
  }
  References: {
    http://www.zlib.net/
  }
]

#include %../stdio.reds

zlib: context [

  #import [
    LIBC-file cdecl [
      re-allocate:  "realloc" [
        base       [byte-ptr!]
        size       [integer!]
        return:    [byte-ptr!]
      ]
    ]
  ]

  #define opaque!  integer!
  #define Z_NULL  0             ; for initializing zalloc, zfree, opaque

  ; Allowed flush values.
  #define Z_NO_FLUSH       0
  #define Z_PARTIAL_FLUSH  1
  #define Z_SYNC_FLUSH     2
  #define Z_FULL_FLUSH     3
  #define Z_FINISH         4
  #define Z_BLOCK          5
  #define Z_TREES          6

  ; Return codes for the compression/decompression functions. Negative values
  ;  are errors, positive values are used for special but normal events.
  #define Z_OK             0
  #define Z_STREAM_END     1
  #define Z_NEED_DICT      2
  #define Z_ERRNO         -1
  #define Z_STREAM_ERROR  -2
  #define Z_DATA_ERROR    -3
  #define Z_MEM_ERROR     -4
  #define Z_BUF_ERROR     -5
  #define Z_VERSION_ERROR -6

  ; Compression levels
  #define Z_NO_COMPRESSION         0
  #define Z_BEST_SPEED             1
  #define Z_BEST_COMPRESSION       9
  #define Z_DEFAULT_COMPRESSION   -1

  #define CHUNK 16384                   ; Buffer size for file (de)compression

  #switch OS [
    Windows   [
      #define z-library "zlib1.dll"
    ]
    MacOSX    [
      #define z-library "libz.1.dylib"  ; TODO: check this
    ]
    #default  [
      #define z-library "libz.so.1"
    ]
  ]

  z_stream!: alias struct! [
    next_in        [byte-ptr!]     ; next input byte
    avail_in       [integer!]      ; number of bytes available at next_in
    total_in       [integer!]      ; total number of input bytes read so far

    next_out       [byte-ptr!]     ; next output byte should be put there
    avail_out      [integer!]      ; remaining free space at next_out
    total_out      [integer!]      ; total number of bytes output so far

    msg            [c-string!]     ; last error message, NULL if no error
    state          [integer!]      ; not visible by applications

    zalloc         [opaque!]       ; used to allocate the internal state (function pointer)
    zfree          [opaque!]       ; used to free the internal state (function pointer)
    opaque         [opaque!]       ; private data object passed to zalloc and zfree (function pointer)

    data_type      [integer!]      ; best guess about the data type: binary or text
    adler          [integer!]      ; adler32 value of the uncompressed data
    reserved       [integer!]      ; reserved for future use
  ]

  #import [z-library cdecl [
    version: "zlibVersion" [       ; Return zlib library version.
      return:   [c-string!]
    ]

    deflateInit_: "deflateInit_" [
      strm         [z_stream!]
      level        [integer!]
      version      [c-string!]
      stream_size  [integer!]
      return:      [integer!]
    ]

    z-deflateEnd: "deflateEnd" [
      strm         [z_stream!]
      return:      [integer!]
    ]

    z-deflate: "deflate" [
      strm         [z_stream!]
      flush        [integer!]
      return:      [integer!]
    ]

    inflateInit_: "inflateInit_" [
      strm         [z_stream!]
      version      [c-string!]
      stream_size  [integer!]
      return:      [integer!]
    ]

    z-inflateEnd: "inflateEnd" [
      strm         [z_stream!]
      return:      [integer!]
    ]

    z-inflate: "inflate" [
      strm         [z_stream!]
      flush        [integer!]
      return:      [integer!]
    ]

    compressBound: "compressBound" [
      sourceLen    [integer!]
      return:      [integer!]
    ]

    z-compress: "compress2" [
      out-buf      [byte-ptr!]           "Pointer to destination data"
      out-count    [int-ptr!]            "Pointer to destination size, returns output buffer size"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      level        [integer!]            "Compression level"
      return:      [integer!]
    ]

    z-uncompress: "uncompress" [
      out-buf      [byte-ptr!]           "Pointer to destination data"
      out-count    [int-ptr!]            "Pointer to destination size, returns output buffer size"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      return:      [integer!]
    ]

  ] ; cdecl
  ] ; #import [z-library

  ; Higher level interface ---------------------------- ---------------------------------------

  with zlib [

     z-inflateInit: function [
      strm         [z_stream!]
      return:      [integer!]
    ][
      inflateInit_ strm version size? z_stream!
    ]

    z-deflateInit: function [
      strm         [z_stream!]
      level        [integer!]
      return:      [integer!]
    ][
      deflateInit_ strm level version size? z_stream!
    ]

#define END_Z_FUNC   [z-deflateEnd strm  free buf-out  free buf-in  free as byte-ptr! strm]

    deflate: function [
      src          [file!]
      dest         [file!]
      level        [integer!]
      return:      [integer!]
      /local ret have flush buf-in buf-out
             strm     [z_stream!]
    ][
      strm: as z_stream! allocate (size? z_stream!)
      if strm = NULL [
        print [ "Deflate: Memory allocation error." lf ]
        return Z_ERRNO
      ]
      buf-in: allocate CHUNK
      if buf-in = NULL [
        print [ "Deflate: Input buffer allocation error." lf ]
        free as byte-ptr! strm
        return Z_ERRNO
      ]
      buf-out: allocate CHUNK
      if buf-out = NULL [
        print [ "Deflate: Output buffer allocation error." lf ]
        free buf-in
        free as byte-ptr! strm
        return Z_ERRNO
      ]
      strm/zalloc: Z_NULL
      strm/zfree: Z_NULL
      strm/opaque: Z_NULL
      ret: z-deflateInit strm level
      if ret <> Z_OK [
        print [ "Deflate: Error deflateInit : " ret lf ]
        END_Z_FUNC
        return Z_ERRNO
      ]
      until [
        strm/avail_in: read-file buf-in 1 CHUNK src
        if file-error? src [
          print [ "Deflate: Input file error : " ret lf ]
          END_Z_FUNC
          return Z_ERRNO ; FIXME: find best error number
        ]
        either file-tail? src [ flush: Z_FINISH ][ flush: Z_NO_FLUSH ]
        strm/next_in: buf-in
        until [
          strm/avail_out: CHUNK
          strm/next_out: buf-out
          ret: z-deflate strm flush
          if ret = Z_STREAM_ERROR [
            print [ "Deflate: Data stream error" lf ]
            END_Z_FUNC
            return Z_ERRNO
          ]
          have: CHUNK - strm/avail_out
          ret: write-file buf-out 1 have dest
          if any [ (ret <> have) (file-error?  dest) ][
            END_Z_FUNC
            return Z_ERRNO
          ]
          strm/avail_out <> 0
        ]
        flush = Z_FINISH
      ]
      END_Z_FUNC
      return Z_OK
    ]

    compress: func [                     "Compress a byte array"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      out-count    [int-ptr!]            "Pointer to integer, returns output buffer size"
      level        [integer!]            "Compression level"
      return:      [byte-ptr!]           "Returns a pointer to compressed data"
      /local ret out-buf tmp
    ][
      out-count/value: compressBound in-count
      out-buf: allocate out-count/value         ; allocate the size of original buffer
      if out-buf = NULL [
        print [ "Compress Error : Output buffer allocation error." lf ]
        return NULL
      ]
      ret: z-compress out-buf out-count in-buf in-count level
      either ret = Z_OK [
        tmp: re-allocate out-buf out-count/value        ; Resize output buffer to minimum size
        either tmp = NULL [                             ; reallocation failed, uses current output buffer
          print [ "Compress Warning : Impossible to reallocate output buffer." lf ]
        ][                                              ; reallocation succeeded, uses reallocated buffer
          out-buf: tmp
        ]
        return out-buf
      ][
        case [
          ret = Z_MEM_ERROR    [ print [ "Compress Error : not enough memory." lf ] ]
          ret = Z_BUF_ERROR    [ print [ "Compress Error : not enough room in the output buffer." lf ] ]
          ret = Z_STREAM_ERROR [ print [ "Compress Error : invalid compression level parameter." lf ] ]
        ]
        free out-buf
        return NULL
      ]
    ] ; compress

    decompress: func [                   "Decompress a byte array"
      in-buf       [byte-ptr!]           "Pointer to source data"
      in-count     [integer!]            "Source data count (bytes)"
      return:      [byte-ptr!]           "Return a pointer to decompressed data"
      /local ret out-buf tmp
      out-count    [integer!]
    ][
      out-count: 2 * in-count                             ; allocate twice the size of original buffer
      out-buf: allocate out-count
      if out-buf = NULL [
        print [ "Decompress Error : Output buffer allocation error." lf ]
        return NULL
      ]
      until [
        ret: z-uncompress out-buf :out-count in-buf in-count
        if ret = Z_BUF_ERROR [                            ; need to expand output buffer
          out-count: 2 * out-count                        ; double buffer size
          tmp: re-allocate out-buf out-count              ; Resize output buffer to minimum size
          either tmp = NULL [                             ; reallocation failed, uses current output buffer
            print [ "Decompress Error : Impossible to reallocate output buffer." lf ]
            ret: Z_MEM_ERROR
          ][                                              ; reallocation succeeded, uses reallocated buffer
            out-buf: tmp
          ]
        ]
        any [ (ret = Z_OK) (ret = Z_MEM_ERROR) (ret = Z_STREAM_ERROR) ]
      ]
      either ret = Z_OK [
        tmp: re-allocate out-buf out-count              ; Resize output buffer to minimum size
        either tmp = NULL [                             ; reallocation failed, uses current output buffer
          print [ "Decompress Warning : Impossible to reallocate output buffer." lf ]
        ][                                              ; reallocation succeeded, uses reallocated buffer
          out-buf: tmp
        ]
        return out-buf
      ][
        case [
          ret = Z_MEM_ERROR    [ print [ "Decompress Error : not enough memory." lf ] ]
          ret = Z_BUF_ERROR    [ print [ "Decompress Error : not enough room in the output buffer." lf ] ]
          ret = Z_STREAM_ERROR [ print [ "Decompress Error : invalid compression level parameter." lf ] ]
        ]
      ]
      return out-buf
    ]

    bin-to-str: func [             "Convert a byte array into an hex string."
      address [byte-ptr!]          "Memory address where the conversion starts"
      limit   [integer!]           "Number of bytes to convert"
      return: [c-string!]          "Return a c string"
      /local i str cnum byte major minor
    ][
      str: make-c-string (1 + (2 * limit))
      i: 0
      cnum: 0
      until [
        byte: as integer! address/value
        minor: byte // 16
        if minor > 9 [minor: minor + 7]         ;-- 7 = (#"A" - 1) - #"9"
        byte: byte >>> 4
        major: byte // 16
        if major > 9 [major: major + 7]         ;-- 7 = (#"A" - 1) - #"9"

        cnum: cnum + 1
        str/cnum: #"0" + major
        cnum: cnum + 1
        str/cnum: #"0" + minor

        address: address + 1
        i: i + 1
        i = limit
      ]
      cnum: cnum + 1
      str/cnum: #"^(00)"  ; c string ending char
      str
    ]
  ] ; with zlib
] ; context zlib


FIX: issue #696 (red console: [";"] triggers multiline input => unmatched closing ])

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
				ReadConsole: 	 "ReadConsoleW" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
		line-buffer-size: 15 * 1024
		line-buffer: allocate line-buffer-size * 2 + 1
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

		rl-insert-wrapper: func [
			[cdecl]
			count   [integer!]
			key	    [integer!]
			return: [integer!]
		][
			rl-insert count key
		]

	]
]

#include %help.red

read-argument: routine [
	/local
		args [str-array!]
		str	 [red-string!]
][
	if system/args-count <> 2 [
		SET_RETURN(none-value)
		exit
	]
	args: system/args-list + 1							;-- skip binary filename
	str: simple-io/read-txt args/item
	SET_RETURN(str)
]

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "SetConsoleTitle failed!" halt]
	][
		rl-bind-key as-integer tab as-integer :rl-insert-wrapper
	]
]

input: routine [
	prompt [string!]
	/local
		len ret str buffer line pos
][
	#either OS = 'Windows [
		len: 0
		print as c-string! string/rs-head prompt
		ret: ReadConsole stdin line-buffer line-buffer-size :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		pos: (len * 2) - 3								;-- position at lower 8bits of CR character
		line-buffer/pos: null-byte						;-- overwrite CR with NUL
		str: string/load as-c-string line-buffer len - 1 UTF-16LE
	][
		line: read-line as-c-string string/rs-head prompt
		if line = null [halt]  ; EOF

		 #if OS <> 'MacOSX [add-history line]

		str: string/load line  1 + length? line UTF-8
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]
	c: none

	foreach c buffer [
		case [
			escaped?	[escaped?: no]
			in-comment? [if c = #"^/" [in-comment?: no]]
			'else [
				switch c [
					#"^^" [escaped?: yes]
					#";"  [if all [zero? list/2 not in-string?][in-comment?: yes]]
					#"["  [unless in-string? [list/1: list/1 + 1]]
					#"]"  [unless in-string? [list/1: list/1 - 1]]
					#"^"" [if zero? list/2 [in-string?: not in-string?]]
					#"{"  [if zero? list/2 [in-string?: yes] list/2: list/2 + 1]
					#"}"  [if 1 = list/2   [in-string?: no]  list/2: list/2 - 1]
				]
			]
		]
	]
	list
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				'mono
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer

		unless tail? code [
			set/any 'result do code

			unless unset? :result [
				if 67 = length? result: mold/part :result 67 [	;-- optimized for width = 72
					clear back tail result
					append result "..."
				]
				print ["==" result]
			]
		]
		clear buffer
	]

	while [true][
		unless tail? line: input prompt [
			append buffer line
			cnt: count-delimiters buffer
			append buffer lf							;-- needed for multiline modes

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

q: :quit

if script: read-argument [
	script: load script
	either any [
		script/1 <> 'Red
		not block? script/2
	][
		print "*** Error: not a Red program!"
	][
		do skip script 2
	]
	quit
]
init-console "Red Console"

print {
-=== Red Console alpha version ===-
Type HELP for starting information.
}

do-console

Red [
	Title:	"Red console"
	Author: ["Nenad Rakocevic" "Kaj de Vos"]
	File: 	%console.red
	Tabs: 	4
	Rights: "Copyright (C) 2012-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

#system-global [
	#either OS = 'Windows [
		#import [
			"kernel32.dll" stdcall [
				AttachConsole: 	 "AttachConsole" [
					processID		[integer!]
					return:			[integer!]
				]
				SetConsoleTitle: "SetConsoleTitleA" [
					title			[c-string!]
					return:			[integer!]
				]
				ReadConsole: 	 "ReadConsoleW" [
					consoleInput	[integer!]
					buffer			[byte-ptr!]
					charsToRead		[integer!]
					numberOfChars	[int-ptr!]
					inputControl	[int-ptr!]
					return:			[integer!]
				]
			]
		]
		line-buffer-size: 15 * 1024
		line-buffer: allocate line-buffer-size * 2 + 1
	][
		#switch OS [
			MacOSX [
				#define ReadLine-library "libreadline.dylib"
			]
			#default [
				#define ReadLine-library "libreadline.so.6"
				#define History-library  "libhistory.so.6"
			]
		]
		#import [
			ReadLine-library cdecl [
				read-line: "readline" [  ; Read a line from the console.
					prompt			[c-string!]
					return:			[c-string!]
				]
				rl-bind-key: "rl_bind_key" [
					key				[integer!]
					command			[integer!]
					return:			[integer!]
				]
				rl-insert:	 "rl_insert" [
					count			[integer!]
					key				[integer!]
					return:			[integer!]
				]
			]
			#if OS <> 'MacOSX [
				History-library cdecl [
					add-history: "add_history" [  ; Add line to the history.
						line		[c-string!]
					]
				]
			]
		]

		rl-insert-wrapper: func [
			[cdecl]
			count   [integer!]
			key	    [integer!]
			return: [integer!]
		][
			rl-insert count key
		]

	]
]

#include %help.red

read-argument: routine [
	/local
		args [str-array!]
		str	 [red-string!]
][
	if system/args-count <> 2 [
		SET_RETURN(none-value)
		exit
	]
	args: system/args-list + 1							;-- skip binary filename
	str: simple-io/read-txt args/item
	SET_RETURN(str)
]

init-console: routine [
	str [string!]
	/local
		ret
][
	#either OS = 'Windows [
		;ret: AttachConsole -1
		;if zero? ret [print-line "ReadConsole failed!" halt]

		ret: SetConsoleTitle as c-string! string/rs-head str
		if zero? ret [print-line "SetConsoleTitle failed!" halt]
	][
		rl-bind-key as-integer tab as-integer :rl-insert-wrapper
	]
]

input: routine [
	prompt [string!]
	/local
		len ret str buffer line pos
][
	#either OS = 'Windows [
		len: 0
		print as c-string! string/rs-head prompt
		ret: ReadConsole stdin line-buffer line-buffer-size :len null
		if zero? ret [print-line "ReadConsole failed!" halt]
		pos: (len * 2) - 3								;-- position at lower 8bits of CR character
		line-buffer/pos: null-byte						;-- overwrite CR with NUL
		str: string/load as-c-string line-buffer len - 1 UTF-16LE
	][
		line: read-line as-c-string string/rs-head prompt
		if line = null [halt]  ; EOF

		 #if OS <> 'MacOSX [add-history line]

		str: string/load line  1 + length? line UTF-8
;		free as byte-ptr! line
	]
	SET_RETURN(str)
]

count-delimiters: function [
	buffer	[string!]
	return: [block!]
][
	list: copy [0 0]
	c: none

	foreach c buffer [
		case [
			escaped?	[escaped?: no]
			in-comment? [if c = #"^/" [in-comment?: no]]
			'else [
				switch c [
					#"^^" [escaped?: yes]
					#";"  [if zero? list/2 [in-comment?: yes]]
					#"["  [unless in-string? [list/1: list/1 + 1]]
					#"]"  [unless in-string? [list/1: list/1 - 1]]
					#"{"  [if zero? list/2 [in-string?: yes] list/2: list/2 + 1]
					#"}"  [if 1 = list/2   [in-string?: no]  list/2: list/2 - 1]
				]
			]
		]
	]
	list
]

do-console: function [][
	buffer: make string! 10000
	prompt: red-prompt: "red>> "
	mode:  'mono

	switch-mode: [
		mode: case [
			cnt/1 > 0 ['block]
			cnt/2 > 0 ['string]
			'else 	  [
				prompt: red-prompt
				do eval
				'mono
			]
		]
		prompt: switch mode [
			block  ["[^-"]
			string ["{^-"]
			mono   [red-prompt]
		]
	]

	eval: [
		code: load/all buffer

		unless tail? code [
			set/any 'result do code

			unless unset? :result [
				if 67 = length? result: mold/part :result 67 [	;-- optimized for width = 72
					clear back tail result
					append result "..."
				]
				print ["==" result]
			]
		]
		clear buffer
	]

	while [true][
		unless tail? line: input prompt [
			append buffer line
			cnt: count-delimiters buffer
			append buffer lf							;-- needed for multiline modes

			switch mode [
				block  [if cnt/1 <= 0 [do switch-mode]]
				string [if cnt/2 <= 0 [do switch-mode]]
				mono   [do either any [cnt/1 > 0 cnt/2 > 0][switch-mode][eval]]
			]
		]
	]
]

q: :quit

if script: read-argument [
	script: load script
	either any [
		script/1 <> 'Red
		not block? script/2
	][
		print "*** Error: not a Red program!"
	][
		do skip script 2
	]
	quit
]
init-console "Red Console"

print {
-=== Red Console alpha version ===-
Type HELP for starting information.
}

do-console


FIX: minor correction to common.reds

FIX: minor correction to common.reds

Red/System [
	Title:   "Red/System OS-independent runtime"
	Author:  "Nenad Rakocevic"
	File: 	 %common.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-function!	7
#define type-struct!	1000
#define type-alias!?  [1001 <=]
#define any-struct?		[1000 <=]

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	alias		[integer!]					;-- aliases ID virtual access
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]				  		;-- type ID
	return: [c-string!]						;-- type representation as c-string
][
	if type = type-integer!    [return "integer!"]
	if type = type-c-string!   [return "c-string!"]
	if type = type-logic! 	   [return "logic!"]
	if type = type-byte! 	     [return "byte!"]
	if type = type-byte-ptr!   [return "pointer! [byte!]"]
	if type = type-int-ptr!    [return "pointer! [integer!]"]
	if type = type-struct!     [return "struct!"]
	if type = type-function!   [return "function!"]
	if type-alias!? type       [return "alias"]
	"not valid type"
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [
		#either config-name = 'Android [	;-- @@ see if declaring it as an OS wouldn't be too costly
			#define LIBC-file	"libc.so"
		][
			#define LIBC-file	"libc.so.6"	;-- Linux
		]
	]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]

Red/System [
	Title:   "Red/System OS-independent runtime"
	Author:  "Nenad Rakocevic"
	File: 	 %common.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-function!	7
#define type-struct!	1000
#define type-alias!?  [999 <=]
#define any-struct?		[1000 <=]

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
	alias		[integer!]					;-- aliases ID virtual access
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]				  		;-- type ID
	return: [c-string!]						;-- type representation as c-string
][
	if type = type-integer!    [return "integer!"]
	if type = type-c-string!   [return "c-string!"]
	if type = type-logic! 	   [return "logic!"]
	if type = type-byte! 	     [return "byte!"]
	if type = type-byte-ptr!   [return "pointer! [byte!]"]
	if type = type-int-ptr!    [return "pointer! [integer!]"]
	if type = type-struct!     [return "struct!"]
	if type = type-function!   [return "function!"]
	if type-alias!? type       [return "alias"]
	"not valid type"
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [
		#either config-name = 'Android [	;-- @@ see if declaring it as an OS wouldn't be too costly
			#define LIBC-file	"libc.so"
		][
			#define LIBC-file	"libc.so.6"	;-- Linux
		]
	]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]


FEAT: TO-TYPE function renamed to FORM-TYPE

Red/System [
	Title:   "Red/System OS-independent runtime"
	Author:  "Nenad Rakocevic"
	File: 	 %common.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-struct!	7
#define type-function!	8

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
form-type: func [
	type 	[integer!]						;-- type ID
	return: [c-string!]						;-- type representation as c-string
	/local msg
][
	if type = type-logic! 	 [msg: "logic!"]
	if type = type-integer!  [msg: "integer!"]
	if type = type-byte! 	 [msg: "byte!"]
	if type = type-c-string! [msg: "c-string!"]
	if type = type-byte-ptr! [msg: "pointer! [byte!]"]
	if type = type-int-ptr!  [msg: "pointer! [integer!]"]
	if type = type-struct!   [msg: "struct!"]
	if type = type-function! [msg: "function!"]
	msg
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [#define LIBC-file	"libc.so.6"]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]

Red/System [
	Title:   "Red/System OS-independent runtime"
	Author:  "Nenad Rakocevic"
	File: 	 %common.reds
	Rights:  "Copyright (C) 2011 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/red-system/runtime/BSL-License.txt
	}
]

#define zero? 		  [0 =]
#define positive?	  [0 < ]				;-- space required after the lesser-than symbol
#define negative?	  [0 > ]
#define negate		  [0 -]
#define null?		  [null =]

#define forever		  [while [true]]
#define does		  [func []]
#define unless		  [if not]
#define	raise-error	  ***-on-quit

#define as-byte		  [as byte!]
#define as-logic	  [as logic!]
#define as-integer	  [as integer!]
#define as-c-string	  [as c-string!]

#define null-byte	  #"^(00)"
#define yes			  true
#define no			  false
#define on			  true
#define off			  false

#define byte-ptr!	  [pointer! [byte!]]
#define int-ptr!	  [pointer! [integer!]]
#define make-c-string [as c-string! allocate]

#define type-logic!		1					;-- type ID list for 'typeinfo attribut
#define type-integer!	2
#define type-byte!	    3
#define type-c-string!  4
#define type-byte-ptr!  5
#define type-int-ptr!	6
#define type-struct!	7
#define type-function!	8

;-- Global variables definition --
stdout:		-1								;-- uninitialized default value
stdin:		-1								;-- uninitialized default value
stderr:		-1								;-- uninitialized default value

str-array!: alias struct! [
	item [c-string!]
]

typed-value!: alias struct! [
	value	[integer!]
	type	[integer!]
]

__stack!: alias struct! [
	top		[int-ptr!]
	frame	[int-ptr!]
]

system: declare struct! [					;-- store runtime accessible system values
	args-count	[integer!]					;-- command-line arguments count (do not move member)
	args-list	[str-array!]				;-- command-line arguments array pointer (do not move member)
	env-vars 	[str-array!]				;-- environment variables array pointer (always null for Windows)
	stack		[__stack!]					;-- stack virtual access
	pc			[byte-ptr!]					;-- CPU program counter value
]

;-------------------------------------------
;-- Convert a type ID to a c-string!
;-------------------------------------------
to-type: func [
	type 	[integer!]						;-- type ID
	return: [c-string!]						;-- type representation as c-string
	/local msg
][
	if type = type-logic! 	 [msg: "logic!"]
	if type = type-integer!  [msg: "integer!"]
	if type = type-byte! 	 [msg: "byte!"]
	if type = type-c-string! [msg: "c-string!"]
	if type = type-byte-ptr! [msg: "pointer! [byte!]"]
	if type = type-int-ptr!  [msg: "pointer! [integer!]"]
	if type = type-struct!   [msg: "struct!"]
	if type = type-function! [msg: "function!"]
	msg
]

#switch OS [
	Windows  [#define LIBC-file	"msvcrt.dll"]
	Syllable [#define LIBC-file	"libc.so.2"]
	MacOSX	 [#define LIBC-file	"libc.dylib"]
	#default [#define LIBC-file	"libc.so.6"]
]

#either use-natives? = no [					;-- C bindings or native counterparts
	#include %lib-C.reds
][
	#include %lib-natives.reds
]

#switch OS [								;-- loading OS-specific bindings
	Windows  [#include %win32.reds]
	Syllable [#include %syllable.reds]
	MacOSX	 [#include %darwin.reds]
	#default [#include %linux.reds]
]

#include %utils.reds						;-- load additional utility functions

#if debug? = yes [#include %debug.reds]		;-- loads optionally debug functions

;-- Run-time error handling --

#define RED_ERR_VMEM_RELEASE_FAILED		96
#define RED_ERR_VMEM_OUT_OF_MEMORY		97

***-on-quit: func [							;-- global exit handler
	status [integer!]
	address [integer!]
	/local msg
][
	unless zero? status [
		print [lf "*** Runtime Error " status ": "]

		if status =  1 [msg: "access violation"]
		if status =  2 [msg: "invalid alignment"]
		if status =  3 [msg: "breakpoint"]
		if status =  4 [msg: "single step"]
		if status =  5 [msg: "bounds exceeded"]
		if status =  6 [msg: "float denormal operan"]
		if status =  7 [msg: "float divide by zero"]
		if status =  8 [msg: "float inexact result"]
		if status =  9 [msg: "float invalid operation"]
		if status = 10 [msg: "float overflow"]
		if status = 11 [msg: "float stack check"]
		if status = 12 [msg: "float underflow"]
		if status = 13 [msg: "integer divide by zero"]
		if status = 14 [msg: "integer overflow"]
		if status = 15 [msg: "privileged instruction"]
		if status = 16 [msg: "invalid virtual address"]
		if status = 17 [msg: "illegal instruction"]
		if status = 18 [msg: "non-continuable exception"]
		if status = 19 [msg: "stack error or overflow"]
		if status = 20 [msg: "invalid disposition"]
		if status = 21 [msg: "guard page"]
		if status = 22 [msg: "invalid handle"]
		if status = 23 [msg: "illegal operand"]
		if status = 24 [msg: "illegal addressing mode"]
		if status = 25 [msg: "illegal trap"]
		if status = 26 [msg: "coprocessor error"]
		if status = 27 [msg: "non-existant physical address"]
		if status = 28 [msg: "object specific hardware error"]
		if status = 29 [msg: "hardware memory error consumed AR"]
		if status = 30 [msg: "hardware memory error consumed AO"]
		if status = 31 [msg: "privileged register"]

		if status = 96 [msg: "virtual memory release failed"]
		if status = 97 [msg: "out of memory"]
		if status = 98 [msg: "assertion failed"]
		if status = 99 [msg: "unknown error"]

		print msg

		#either debug? = yes [
			__print-debug-line as byte-ptr! address
		][
			print [lf "*** at: " as byte-ptr! address "h" lf]
		]
	]

	#if OS = 'Windows [						;-- special exit handler for Windows
		***-on-win32-quit
	]
	quit status
]


FEAT: minor improvement of an error message.

Red [
	Title:   "Red system object definition"
	Author:  "Nenad Rakocevic"
	File: 	 %system.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

system: context [
	version: #version
	build:	 #build-date

	words: func	["Return a block of global words available"][
		#system [_context/get-words]
	]

	platform: func ["Return a word identifying the operating system"][
		#system [
			#switch OS [
				Windows  [SET_RETURN(words/_windows)]
				Syllable [SET_RETURN(words/_syllable)]
				MacOSX	 [SET_RETURN(words/_macosx)]
				#default [SET_RETURN(words/_linux)]
			]
		]
	]

	catalog: context [
		datatypes:
		actions:
		natives: none

		errors: context [
			throw: object [
				code:				0
				type:				"Throw error"
				break:				"no loop to break"
				return:				"return or exit not in function"
				throw:				["no catch for throw:" :arg1]
				continue:			"no loop to continue"
			]
			note: object [
				code:				100
				type:				"note"
				no-load:			["cannot load: " :arg1]
			]
			syntax: object [
				code:				200
				type:				"Syntax error"
				invalid:			["invalid" :arg1 "at" :arg2]
				missing:			["missing" :arg2 "at" :arg1]
				no-header:			["script is missing a Red header:" :arg1]
				no-rs-header:		["script is missing a Red/System header:" :arg1]
				bad-header:			["script header is not valid:" :arg1]
				malconstruct:		["invalid construction spec:" :arg1]
				bad-char:			["invalid character in:" :arg1]
			]
			script: object [
				code:				300
				type:				"Script error"
				no-value:			[:arg1 "has no value"]
				need-value:			[:arg1 "needs a value"]
				not-defined:		[:arg1 "word is not bound to a context"]
				not-in-context:		[:arg1 "is not in the specified context"]
				no-arg:				[:arg1 "is missing its" :arg2 "argument"]
				expect-arg:			[:arg1 "does not allow" :arg2 "for its" :arg3 "argument"]
				expect-val:			["expected" :arg1 "not" :arg2]
				expect-type:		[:arg1 :arg2 "field must be of type" :arg3]
				cannot-use:			["cannot use" :arg1 "on" :arg2 "value"]
				invalid-arg:		["invalid argument:" :arg1]
				invalid-type:		[:arg1 "type is not allowed here"]
				invalid-op:			["invalid operator:" :arg1]
				no-op-arg:			[:arg1 "operator is missing an argument"]
				invalid-data:		["data not in correct format:" :arg1]
				invalid-part:		["invalid /part count:" :arg1]
				not-same-type:		"values must be of the same type"
				not-related:		["incompatible argument for" :arg1 "of" :arg2]
				bad-func-def:		["invalid function definition:" :arg1]
				bad-func-arg:		["function argument" :arg1 "is not valid"]
				bad-func-extern:	["invalid /extern value" :arg1]
				no-refine:			[:arg1 "has no refinement called" :arg2]
				bad-refines:		"incompatible or invalid refinements"
				bad-refine:			["incompatible refinement:" :arg1]
				invalid-path:		["cannot access" :arg2 "in path" :arg1]
				bad-path-type:		["path" :arg1 "is not valid for" :arg2 "type"]
				bad-path-set:		["cannot set" :arg2 "in path" :arg1]
				bad-field-set:		["cannot set" :arg1 "field to" :arg2 "datatype"]
				dup-vars:			["duplicate variable specified:" :arg1]
				past-end:			"out of range or past end"
				missing-arg:		"missing a required argument or refinement"
				out-of-range:		["value out of range:" :arg1]
				invalid-chars:		"contains invalid characters"
				invalid-compare:	["cannot compare" :arg1 "with" :arg2]
				wrong-type:			["datatype assertion failed for:" :arg1]
				invalid-refine-arg: ["invalid" :arg1 "argument:" :arg2]
				type-limit:			[:arg1 "overflow/underflow"]
				size-limit:			["maximum limit reached:" :arg1]
				no-return:			"block did not return a value"
				throw-usage:		"invalid use of a thrown error value"
				;locked-word:		["protected variable - cannot modify:" :arg1]
				;protected:			"protected value or series - cannot modify"
				;self-protected:	"cannot set/unset self - it is protected"
				bad-bad:			[:arg1 "error:" :arg2]
				bad-make-arg:		["cannot MAKE/TO" :arg1 "from:" :arg2]
				invalid-spec-field: ["invalid" :arg1 "field in spec block"]
				missing-spec-field: [:arg1 "not found in spec block"]
				;bad-decode:		"missing or unsupported encoding marker"
				;already-used:		["alias word is already in use:" :arg1]
				;wrong-denom:		[:arg1 "not same denomination as" :arg2]
				;bad-press:			["invalid compressed data - problem:" :arg1]
				;dialect:			["incorrect" :arg1 "dialect usage at:" :arg2]
				parse-rule:			["PARSE - invalid rule or usage of rule:" :arg1]
				parse-end:			["PARSE - unexpected end of rule after:" :arg1]
				;parse-variable:	["PARSE - expected a variable, not:" :arg1]
				;parse-command:		"PARSE - command cannot be used as variable:" :arg1]
				parse-invalid-ref:	["PARSE - get-word refers to a different series!" :arg1]
				parse-series:		["PARSE - input must be a series:" :arg1]
			]
			math: object [
				code:				400
				type:				"Math error"
				zero-divide:		"attempt to divide by zero"
				overflow:			"math or number overflow"
				positive:			"positive number required"
			]
			access: object [
				code:				500
				type:				"Access error"
				;cannot-open:		["cannot open:" :arg1 "reason:" :arg2]
				;not-open:			["port is not open:" :arg1]
				;already-open:		["port is already open:" :arg1]
				;no-connect:		["cannot connect:" :arg1 "reason:" :arg2]
				;not-connected:		["port is not connected:" :arg1]
				;no-script:			["script not found:" :arg1]
				;no-scheme-name:	["new scheme must have a name:" :arg1]
				;no-scheme:			["missing port scheme:" :arg1]
				;invalid-spec:		["invalid spec or options:" :arg1]
				;invalid-port:		["invalid port object (invalid field values)"]
				;invalid-actor:		["invalid port actor (must be native or object)"]
				;invalid-port-arg:	["invalid port argument:" arg1]
				;no-port-action:	["this port does not support:" :arg1]
				;protocol:			["protocol error:" :arg1]
				;invalid-check:		["invalid checksum (tampered file):" :arg1]
				;write-error:		["write failed:" :arg1 "reason:" :arg2]
				;read-error:		["read failed:" :arg1 "reason:" :arg2]
				;read-only:			["read-only - write not allowed:" :arg1]
				;no-buffer:			["port has no data buffer:" :arg1]
				;timeout:			["port action timed out:" :arg1]
				;no-create:			["cannot create:" :arg1]
				;no-delete:			["cannot delete:" :arg1]
				;no-rename:			["cannot rename:" :arg1]
				;bad-file-path:		["bad file path:" :arg1]
				;bad-file-mode:		["bad file mode:" :arg1]
				;security:			["security violation:" :arg1 " (refer to SECURE function)"]
				;security-level:	["attempt to lower security to" :arg1]
				;security-error:	["invalid" :arg1 "security policy:" :arg2]
				;no-codec:			["cannot decode or encode (no codec):" :arg1]
				;bad-media:			["bad media data (corrupt image, sound, video)"]
				;no-extension:		["cannot open extension:" :arg1]
				;bad-extension:		["invalid extension format:" :arg1]
				;extension-init:	["extension cannot be initialized (check version):" :arg1]
				;call-fail:			["external process failed:" :arg1]
			]
			user: object [
				code:				800
				type:				"User error"
				message:			[:arg1]
			]
			internal: object [
				code:				900
				type:				"Internal error"
				bad-path:			["bad path:" arg1]
				not-here:			[arg1 "not supported on your system"]
				no-memory:			"not enough memory"
				stack-overflow:		"stack overflow"
				;bad-series:		"invalid series"
				;limit-hit:			["internal limit reached:" :arg1]
				;bad-sys-func:		["invalid or missing system function:" :arg1]
				feature-na:			"feature not available"
				not-done:			"reserved for future use (or not yet implemented)"
				invalid-error:		"error object or fields were not valid"
			]
		]

	]

	state: context [
		interpreted?: func ["Return TRUE if called from the interpreter"][
			#system [logic/box stack/eval?]
		]

		last-error: none
	]

	modules: make block! 8
	codecs:  context []
	schemes: context []
	ports:	 context []

	locale: context [
		language:
		language*:										;-- in locale language
		locale:
		locale*: none									;-- in locale language

		collation: context [
			lower-to-upper: #system [stack/set-last as cell! case-folding/lower-to-upper]
			upper-to-lower: #system [stack/set-last as cell! case-folding/upper-to-lower]
		]

		months: [
		  "January" "February" "March" "April" "May" "June"
		  "July" "August" "September" "October" "November" "December"
		]

		days: [
		  "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"
		]
	]

	options: context [
		boot: 			none
		home: 			none
		path: 			none
		script: 		none
		args: 			none
		do-arg: 		none
		debug: 			none
		secure: 		none
		quiet: 			false
		binary-base: 	16
		decimal-digits: 15
		module-paths: 	make block! 1
		file-types: 	none

		;-- change the way float numbers are processed
		float: context [
			pretty?: false
			full?: 	 false

			on-change*: func [word old new][
				switch word [
					pretty? [
						either new [
							#system [float/pretty-print?: yes]
						][
							#system [float/pretty-print?: no]
						]
					]
					full? [
						either new [
							#system [float/full-support?: yes]
						][
							#system [float/full-support?: no]
						]
					]
				]
			]
		]
	]

	script: context [
		title: header: parent: path: args: none
	]

	standard: context [
		header: context [
			title: name: type: version: date: file: author: needs: none
		]
		error: context [
			code: type: id: arg1: arg2: arg3: near: where: stack: none
		]
	]

	view: context [
		screen: 	none
		event-port: none

		metrics: context [
			screen-size: 	none
			dpi:			none
			;scaling:		1x1
		]
	]

	lexer: none
	console: none
]

Red [
	Title:   "Red system object definition"
	Author:  "Nenad Rakocevic"
	File: 	 %system.red
	Tabs:	 4
	Rights:  "Copyright (C) 2011-2013 Nenad Rakocevic. All rights reserved."
	License: {
		Distributed under the Boost Software License, Version 1.0.
		See https://github.com/dockimbel/Red/blob/master/BSL-License.txt
	}
]

system: context [
	version: #version
	build:	 #build-date

	words: func	["Return a block of global words available"][
		#system [_context/get-words]
	]

	platform: func ["Return a word identifying the operating system"][
		#system [
			#switch OS [
				Windows  [SET_RETURN(words/_windows)]
				Syllable [SET_RETURN(words/_syllable)]
				MacOSX	 [SET_RETURN(words/_macosx)]
				#default [SET_RETURN(words/_linux)]
			]
		]
	]

	catalog: context [
		datatypes:
		actions:
		natives: none

		errors: context [
			throw: object [
				code:				0
				type:				"Throw error"
				break:				"no loop to break"
				return:				"return or exit not in function"
				throw:				["no catch for throw:" :arg1]
				continue:			"no loop to continue"
			]
			note: object [
				code:				100
				type:				"note"
				no-load:			["cannot load: " :arg1]
			]
			syntax: object [
				code:				200
				type:				"Syntax error"
				invalid:			["invalid" :arg1 "--" :arg2]
				missing:			["missing" :arg2 "at" :arg1]
				no-header:			["script is missing a Red header:" :arg1]
				no-rs-header:		["script is missing a Red/System header:" :arg1]
				bad-header:			["script header is not valid:" :arg1]
				malconstruct:		["invalid construction spec:" :arg1]
				bad-char:			["invalid character in:" :arg1]
			]
			script: object [
				code:				300
				type:				"Script error"
				no-value:			[:arg1 "has no value"]
				need-value:			[:arg1 "needs a value"]
				not-defined:		[:arg1 "word is not bound to a context"]
				not-in-context:		[:arg1 "is not in the specified context"]
				no-arg:				[:arg1 "is missing its" :arg2 "argument"]
				expect-arg:			[:arg1 "does not allow" :arg2 "for its" :arg3 "argument"]
				expect-val:			["expected" :arg1 "not" :arg2]
				expect-type:		[:arg1 :arg2 "field must be of type" :arg3]
				cannot-use:			["cannot use" :arg1 "on" :arg2 "value"]
				invalid-arg:		["invalid argument:" :arg1]
				invalid-type:		[:arg1 "type is not allowed here"]
				invalid-op:			["invalid operator:" :arg1]
				no-op-arg:			[:arg1 "operator is missing an argument"]
				invalid-data:		["data not in correct format:" :arg1]
				invalid-part:		["invalid /part count:" :arg1]
				not-same-type:		"values must be of the same type"
				not-related:		["incompatible argument for" :arg1 "of" :arg2]
				bad-func-def:		["invalid function definition:" :arg1]
				bad-func-arg:		["function argument" :arg1 "is not valid"]
				bad-func-extern:	["invalid /extern value" :arg1]
				no-refine:			[:arg1 "has no refinement called" :arg2]
				bad-refines:		"incompatible or invalid refinements"
				bad-refine:			["incompatible refinement:" :arg1]
				invalid-path:		["cannot access" :arg2 "in path" :arg1]
				bad-path-type:		["path" :arg1 "is not valid for" :arg2 "type"]
				bad-path-set:		["cannot set" :arg2 "in path" :arg1]
				bad-field-set:		["cannot set" :arg1 "field to" :arg2 "datatype"]
				dup-vars:			["duplicate variable specified:" :arg1]
				past-end:			"out of range or past end"
				missing-arg:		"missing a required argument or refinement"
				out-of-range:		["value out of range:" :arg1]
				invalid-chars:		"contains invalid characters"
				invalid-compare:	["cannot compare" :arg1 "with" :arg2]
				wrong-type:			["datatype assertion failed for:" :arg1]
				invalid-refine-arg: ["invalid" :arg1 "argument:" :arg2]
				type-limit:			[:arg1 "overflow/underflow"]
				size-limit:			["maximum limit reached:" :arg1]
				no-return:			"block did not return a value"
				throw-usage:		"invalid use of a thrown error value"
				;locked-word:		["protected variable - cannot modify:" :arg1]
				;protected:			"protected value or series - cannot modify"
				;self-protected:	"cannot set/unset self - it is protected"
				bad-bad:			[:arg1 "error:" :arg2]
				bad-make-arg:		["cannot MAKE/TO" :arg1 "from:" :arg2]
				invalid-spec-field: ["invalid" :arg1 "field in spec block"]
				missing-spec-field: [:arg1 "not found in spec block"]
				;bad-decode:		"missing or unsupported encoding marker"
				;already-used:		["alias word is already in use:" :arg1]
				;wrong-denom:		[:arg1 "not same denomination as" :arg2]
				;bad-press:			["invalid compressed data - problem:" :arg1]
				;dialect:			["incorrect" :arg1 "dialect usage at:" :arg2]
				parse-rule:			["PARSE - invalid rule or usage of rule:" :arg1]
				parse-end:			["PARSE - unexpected end of rule after:" :arg1]
				;parse-variable:	["PARSE - expected a variable, not:" :arg1]
				;parse-command:		"PARSE - command cannot be used as variable:" :arg1]
				parse-invalid-ref:	["PARSE - get-word refers to a different series!" :arg1]
				parse-series:		["PARSE - input must be a series:" :arg1]
			]
			math: object [
				code:				400
				type:				"Math error"
				zero-divide:		"attempt to divide by zero"
				overflow:			"math or number overflow"
				positive:			"positive number required"
			]
			access: object [
				code:				500
				type:				"Access error"
				;cannot-open:		["cannot open:" :arg1 "reason:" :arg2]
				;not-open:			["port is not open:" :arg1]
				;already-open:		["port is already open:" :arg1]
				;no-connect:		["cannot connect:" :arg1 "reason:" :arg2]
				;not-connected:		["port is not connected:" :arg1]
				;no-script:			["script not found:" :arg1]
				;no-scheme-name:	["new scheme must have a name:" :arg1]
				;no-scheme:			["missing port scheme:" :arg1]
				;invalid-spec:		["invalid spec or options:" :arg1]
				;invalid-port:		["invalid port object (invalid field values)"]
				;invalid-actor:		["invalid port actor (must be native or object)"]
				;invalid-port-arg:	["invalid port argument:" arg1]
				;no-port-action:	["this port does not support:" :arg1]
				;protocol:			["protocol error:" :arg1]
				;invalid-check:		["invalid checksum (tampered file):" :arg1]
				;write-error:		["write failed:" :arg1 "reason:" :arg2]
				;read-error:		["read failed:" :arg1 "reason:" :arg2]
				;read-only:			["read-only - write not allowed:" :arg1]
				;no-buffer:			["port has no data buffer:" :arg1]
				;timeout:			["port action timed out:" :arg1]
				;no-create:			["cannot create:" :arg1]
				;no-delete:			["cannot delete:" :arg1]
				;no-rename:			["cannot rename:" :arg1]
				;bad-file-path:		["bad file path:" :arg1]
				;bad-file-mode:		["bad file mode:" :arg1]
				;security:			["security violation:" :arg1 " (refer to SECURE function)"]
				;security-level:	["attempt to lower security to" :arg1]
				;security-error:	["invalid" :arg1 "security policy:" :arg2]
				;no-codec:			["cannot decode or encode (no codec):" :arg1]
				;bad-media:			["bad media data (corrupt image, sound, video)"]
				;no-extension:		["cannot open extension:" :arg1]
				;bad-extension:		["invalid extension format:" :arg1]
				;extension-init:	["extension cannot be initialized (check version):" :arg1]
				;call-fail:			["external process failed:" :arg1]
			]
			user: object [
				code:				800
				type:				"User error"
				message:			[:arg1]
			]
			internal: object [
				code:				900
				type:				"Internal error"
				bad-path:			["bad path:" arg1]
				not-here:			[arg1 "not supported on your system"]
				no-memory:			"not enough memory"
				stack-overflow:		"stack overflow"
				;bad-series:		"invalid series"
				;limit-hit:			["internal limit reached:" :arg1]
				;bad-sys-func:		["invalid or missing system function:" :arg1]
				feature-na:			"feature not available"
				not-done:			"reserved for future use (or not yet implemented)"
				invalid-error:		"error object or fields were not valid"
			]
		]

	]

	state: context [
		interpreted?: func ["Return TRUE if called from the interpreter"][
			#system [logic/box stack/eval?]
		]

		last-error: none
	]

	modules: make block! 8
	codecs:  context []
	schemes: context []
	ports:	 context []

	locale: context [
		language:
		language*:										;-- in locale language
		locale:
		locale*: none									;-- in locale language

		collation: context [
			lower-to-upper: #system [stack/set-last as cell! case-folding/lower-to-upper]
			upper-to-lower: #system [stack/set-last as cell! case-folding/upper-to-lower]
		]

		months: [
		  "January" "February" "March" "April" "May" "June"
		  "July" "August" "September" "October" "November" "December"
		]

		days: [
		  "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"
		]
	]

	options: context [
		boot: 			none
		home: 			none
		path: 			none
		script: 		none
		args: 			none
		do-arg: 		none
		debug: 			none
		secure: 		none
		quiet: 			false
		binary-base: 	16
		decimal-digits: 15
		module-paths: 	make block! 1
		file-types: 	none

		;-- change the way float numbers are processed
		float: context [
			pretty?: false
			full?: 	 false

			on-change*: func [word old new][
				switch word [
					pretty? [
						either new [
							#system [float/pretty-print?: yes]
						][
							#system [float/pretty-print?: no]
						]
					]
					full? [
						either new [
							#system [float/full-support?: yes]
						][
							#system [float/full-support?: no]
						]
					]
				]
			]
		]
	]

	script: context [
		title: header: parent: path: args: none
	]

	standard: context [
		header: context [
			title: name: type: version: date: file: author: needs: none
		]
		error: context [
			code: type: id: arg1: arg2: arg3: near: where: stack: none
		]
	]

	view: context [
		screen: 	none
		event-port: none

		metrics: context [
			screen-size: 	none
			dpi:			none
			;scaling:		1x1
		]
	]

	lexer: none
	console: none
]