lib/_kernel#.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_kernel#.scm"
   4
   5 ;;; Copyright (c) 1994-2012 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 ;;; Representation of exceptions.
  10
  11 (define-library-type exception
  12   id: 0bf9b656-b071-404a-a514-0fb9d05cf518
  13   constructor: #f
  14   extender: define-library-type-of-exception
  15   opaque:
  16 )
  17
  18 (define-library-type-of-exception heap-overflow-exception
  19   id: d69cd396-01e0-4dcb-87dc-31acea8e0e5f
  20   constructor: #f
  21   opaque:
  22 )
  23
  24 (define-library-type-of-exception stack-overflow-exception
  25   id: f512c9f6-3b24-4c5c-8c8b-cabd75b2f951
  26   constructor: #f
  27   opaque:
  28 )
  29
  30 (define-library-type-of-exception nonprocedure-operator-exception
  31   id: f39d07ce-436d-40ca-b81f-cdc65d16b7f2
  32   constructor: #f
  33   opaque:
  34
  35   (operator  unprintable: read-only:)
  36   (arguments unprintable: read-only:)
  37   (code      unprintable: read-only:)
  38   (rte       unprintable: read-only:)
  39 )
  40
  41 (define-library-type-of-exception wrong-number-of-arguments-exception
  42   id: 2138cd7f-8c42-4164-b56a-a8c7badf3323
  43   constructor: #f
  44   opaque:
  45
  46   (procedure unprintable: read-only:)
  47   (arguments unprintable: read-only:)
  48 )
  49
  50 (define-library-type-of-exception keyword-expected-exception
  51   id: 3fd6c57f-3c80-4436-a430-57ea4457c11e
  52   constructor: #f
  53   opaque:
  54
  55   (procedure unprintable: read-only:)
  56   (arguments unprintable: read-only:)
  57 )
  58
  59 (define-library-type-of-exception unknown-keyword-argument-exception
  60   id: 3f9f8aaa-ea21-4f2b-bc06-f65950e6c408
  61   constructor: #f
  62   opaque:
  63
  64   (procedure unprintable: read-only:)
  65   (arguments unprintable: read-only:)
  66 )
  67
  68 (define-library-type-of-exception cfun-conversion-exception
  69   id: 9f09b552-0fb7-42c5-b0d4-212155841d53
  70   constructor: #f
  71   opaque:
  72
  73   (procedure unprintable: read-only:)
  74   (arguments unprintable: read-only:)
  75   (code      unprintable: read-only:)
  76   (message   unprintable: read-only:)
  77 )
  78
  79 (define-library-type-of-exception sfun-conversion-exception
  80   id: 54dfbc02-718d-4a34-91ab-d1861da7500a
  81   constructor: #f
  82   opaque:
  83
  84   (procedure unprintable: read-only:)
  85   (arguments unprintable: read-only:)
  86   (code      unprintable: read-only:)
  87   (message   unprintable: read-only:)
  88 )
  89
  90 (define-library-type-of-exception multiple-c-return-exception
  91   id: 73c66686-a08f-4c7c-a0f1-5ad7771f242a
  92   constructor: #f
  93   opaque:
  94 )
  95
  96 (define-library-type-of-exception number-of-arguments-limit-exception
  97   id: f9519b37-d6d4-4748-8eb1-a0c8dc18c5e7
  98   constructor: #f
  99   opaque:
 100
 101   (procedure unprintable: read-only:)
 102   (arguments unprintable: read-only:)
 103 )
 104
 105 (define-library-type-of-exception type-exception
 106   id: cf06eccd-bf2c-4b30-a6ce-394b345a0dee
 107   constructor: #f
 108   opaque:
 109
 110   (procedure unprintable: read-only:)
 111   (arguments unprintable: read-only:)
 112   (arg-num   unprintable: read-only:)
 113   (type-id   unprintable: read-only:)
 114 )
 115
 116 (define-library-type-of-exception os-exception
 117   id: c1fc166b-d951-4871-853c-2b6c8c12d28d
 118   constructor: #f
 119   opaque:
 120
 121   (procedure unprintable: read-only:)
 122   (arguments unprintable: read-only:)
 123   (message   unprintable: read-only:)
 124   (code      unprintable: read-only:)
 125 )
 126
 127 (define-library-type-of-exception no-such-file-or-directory-exception
 128   id: 299ccee1-77d2-4a6d-ab24-2ebf14297315
 129   constructor: #f
 130   opaque:
 131
 132   (procedure unprintable: read-only:)
 133   (arguments unprintable: read-only:)
 134 )
 135
 136 ;;;----------------------------------------------------------------------------
 137
 138 ;;; Define type checking macros.
 139
 140 (define-check-type foreign 'foreign
 141   ##foreign?)
 142
 143 ;;;----------------------------------------------------------------------------
 144
 145 ;;; Debug settings.
 146
 147 (##define-macro (macro-debug-settings-level-mask)          15)
 148 (##define-macro (macro-debug-settings-level-shift)         0)
 149
 150 (##define-macro (macro-debug-settings-uncaught-mask)       16)
 151 (##define-macro (macro-debug-settings-uncaught-primordial) 0)
 152 (##define-macro (macro-debug-settings-uncaught-all)        1)
 153 (##define-macro (macro-debug-settings-uncaught-shift)      4)
 154
 155 (##define-macro (macro-debug-settings-error-mask)          96)
 156 (##define-macro (macro-debug-settings-error-repl)          0)
 157 (##define-macro (macro-debug-settings-error-single-step)   1)
 158 (##define-macro (macro-debug-settings-error-quit)          2)
 159 (##define-macro (macro-debug-settings-error-shift)         5)
 160
 161 (##define-macro (macro-debug-settings-repl-mask)           384)
 162 (##define-macro (macro-debug-settings-repl-ide)            0)
 163 (##define-macro (macro-debug-settings-repl-console)        1)
 164 (##define-macro (macro-debug-settings-repl-stdio)          2)
 165 (##define-macro (macro-debug-settings-repl-remote)         3)
 166 (##define-macro (macro-debug-settings-repl-shift)          7)
 167
 168 (##define-macro (macro-debug-settings-user-intr-mask)      1536)
 169 (##define-macro (macro-debug-settings-user-intr-repl)      0)
 170 (##define-macro (macro-debug-settings-user-intr-defer)     1)
 171 (##define-macro (macro-debug-settings-user-intr-quit)      2)
 172 (##define-macro (macro-debug-settings-user-intr-shift)     9)
 173
 174 (##define-macro (macro-debug-settings-level settings)
 175   `(##fixnum.arithmetic-shift-right
 176     (##fixnum.bitwise-and ,settings
 177                           (macro-debug-settings-level-mask))
 178     (macro-debug-settings-level-shift)))
 179
 180 (##define-macro (macro-debug-settings-uncaught settings)
 181   `(##fixnum.arithmetic-shift-right
 182     (##fixnum.bitwise-and ,settings
 183                           (macro-debug-settings-uncaught-mask))
 184     (macro-debug-settings-uncaught-shift)))
 185
 186 (##define-macro (macro-debug-settings-error settings)
 187   `(##fixnum.arithmetic-shift-right
 188     (##fixnum.bitwise-and ,settings
 189                           (macro-debug-settings-error-mask))
 190     (macro-debug-settings-error-shift)))
 191
 192 (##define-macro (macro-debug-settings-repl settings)
 193   `(##fixnum.arithmetic-shift-right
 194     (##fixnum.bitwise-and ,settings
 195                           (macro-debug-settings-repl-mask))
 196     (macro-debug-settings-repl-shift)))
 197
 198 (##define-macro (macro-debug-settings-user-intr settings)
 199   `(##fixnum.arithmetic-shift-right
 200     (##fixnum.bitwise-and ,settings
 201                           (macro-debug-settings-user-intr-mask))
 202     (macro-debug-settings-user-intr-shift)))
 203
 204 ;;;----------------------------------------------------------------------------
 205
 206 ;;; Terminal settings.
 207
 208 (##define-macro (macro-terminal-settings-encoding-mask)    15)
 209 (##define-macro (macro-terminal-settings-encoding-shift)   0)
 210 (##define-macro (macro-terminal-settings-enable-line-edit) 16)
 211
 212 (##define-macro (macro-terminal-settings-encoding settings)
 213   `(##fixnum.arithmetic-shift-right
 214     (##fixnum.bitwise-and ,settings
 215                           (macro-terminal-settings-encoding-mask))
 216     (macro-terminal-settings-encoding-shift)))
 217
 218 (##define-macro (macro-terminal-settings-enable-line-edit? settings)
 219   `(##not (##fixnum.=
 220            (##fixnum.bitwise-and ,settings
 221                                  (macro-terminal-settings-enable-line-edit))
 222            0)))
 223
 224 ;;;----------------------------------------------------------------------------
 225
 226 ;;; Exit codes.
 227
 228 (##define-macro (macro-EXIT-CODE-OK)          0)
 229 (##define-macro (macro-EXIT-CODE-USAGE)       64)
 230 (##define-macro (macro-EXIT-CODE-DATAERR)     65)
 231 (##define-macro (macro-EXIT-CODE-NOINPUT)     66)
 232 (##define-macro (macro-EXIT-CODE-NOUSER)      67)
 233 (##define-macro (macro-EXIT-CODE-NOHOST)      68)
 234 (##define-macro (macro-EXIT-CODE-UNAVAILABLE) 69)
 235 (##define-macro (macro-EXIT-CODE-SOFTWARE)    70)
 236 (##define-macro (macro-EXIT-CODE-OSERR)       71)
 237 (##define-macro (macro-EXIT-CODE-OSFILE)      72)
 238 (##define-macro (macro-EXIT-CODE-CANTCREAT)   73)
 239 (##define-macro (macro-EXIT-CODE-IOERR)       74)
 240 (##define-macro (macro-EXIT-CODE-TEMPFAIL)    75)
 241 (##define-macro (macro-EXIT-CODE-PROTOCOL)    76)
 242 (##define-macro (macro-EXIT-CODE-NOPERM)      77)
 243 (##define-macro (macro-EXIT-CODE-CONFIG)      78)
 244
 245 ;;;----------------------------------------------------------------------------
 246
 247 ;;; Representation of fifos.
 248
 249 (##define-macro (macro-make-fifo)
 250   `(let ((fifo (##cons '() '())))
 251      (macro-fifo-tail-set! fifo fifo)
 252      fifo))
 253
 254 (##define-macro (macro-fifo-next fifo)        `(##cdr ,fifo))
 255 (##define-macro (macro-fifo-next-set! fifo x) `(##set-cdr! ,fifo ,x))
 256 (##define-macro (macro-fifo-tail fifo)        `(##car ,fifo))
 257 (##define-macro (macro-fifo-tail-set! fifo x) `(##set-car! ,fifo ,x))
 258 (##define-macro (macro-fifo-elem fifo)        `(##car ,fifo))
 259 (##define-macro (macro-fifo-elem-set! fifo x) `(##set-car! ,fifo ,x))
 260
 261 (##define-macro (macro-fifo->list fifo)
 262   `(macro-fifo-next ,fifo))
 263
 264 (##define-macro (macro-fifo-remove-all! fifo)
 265   `(let ((fifo ,fifo))
 266
 267      (##declare (not interrupts-enabled))
 268
 269      (let ((head (macro-fifo-next fifo)))
 270        (macro-fifo-tail-set! fifo fifo)
 271        (macro-fifo-next-set! fifo '())
 272        head)))
 273
 274 (##define-macro (macro-fifo-remove-head! fifo)
 275   `(let ((fifo ,fifo))
 276
 277      (##declare (not interrupts-enabled))
 278
 279      (let ((head (macro-fifo-next fifo)))
 280        (if (##pair? head)
 281          (let ((next (macro-fifo-next head)))
 282            (if (##null? next)
 283              (macro-fifo-tail-set! fifo fifo))
 284            (macro-fifo-next-set! fifo next)
 285            (macro-fifo-next-set! head '())))
 286        head)))
 287
 288 (##define-macro (macro-fifo-insert-at-tail! fifo elem)
 289   `(let ((fifo ,fifo) (elem ,elem))
 290      (let ((x (##cons elem '())))
 291
 292        (##declare (not interrupts-enabled))
 293
 294        (let ((tail (macro-fifo-tail fifo)))
 295          (macro-fifo-next-set! tail x)
 296          (macro-fifo-tail-set! fifo x)
 297          (##void)))))
 298
 299 (##define-macro (macro-fifo-insert-at-head! fifo elem)
 300   `(let ((fifo ,fifo) (elem ,elem))
 301      (let ((x (##cons elem '())))
 302
 303        (##declare (not interrupts-enabled))
 304
 305        ;; To obtain an atomic update of the fifo, we must force a
 306        ;; garbage-collection to occur right away if needed by the
 307        ;; ##cons, so that any finalization that might mutate this fifo
 308        ;; will be done before updating the fifo.
 309
 310        (##check-heap-limit)
 311
 312        (let ((head (macro-fifo-next fifo)))
 313          (if (##null? head)
 314            (macro-fifo-tail-set! fifo x))
 315          (macro-fifo-next-set! fifo x)
 316          (macro-fifo-next-set! x head)
 317          (##void)))))
 318
 319 (##define-macro (macro-fifo-advance-to-tail! fifo)
 320   `(let ((fifo ,fifo))
 321      ;; It is assumed that the fifo contains at least one element
 322      ;; (i.e. the fifo's tail does not change).
 323      (let ((new-head (macro-fifo-tail fifo)))
 324        (macro-fifo-next-set! fifo new-head)
 325        (macro-fifo-elem new-head))))
 326
 327 (##define-macro (macro-fifo-advance! fifo)
 328   `(let ((fifo ,fifo))
 329      ;; It is assumed that the fifo contains at least two elements
 330      ;; (i.e. the fifo's tail does not change).
 331      (let* ((head (macro-fifo-next fifo))
 332             (new-head (macro-fifo-next head)))
 333        (macro-fifo-next-set! fifo new-head)
 334        (macro-fifo-elem new-head))))
 335
 336 ;;;============================================================================