home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / swat / scheme / control-floating-errors.scm < prev    next >
Text File  |  1995-08-02  |  2KB  |  74 lines
  1. ;;; -*-Scheme-*-
  2.  
  3. #|
  4.     (set-floating-error-mask! <fixnum>)
  5.  
  6.     sets the floating-point enables to the bottom 5 bits of fixnum.
  7.     returns a fixnum with the old floating-point enables in the bottom 5 bits.
  8.  
  9.     Warning: This does not check the argument type.
  10.  
  11.     Flags:     V    valid operation        16
  12.         Z    zero divide         8
  13.         O    overflow         4
  14.         U    underflow         2
  15.         I    inexact             1
  16.  
  17.     This version is long because it compiles under both 7.4 and 8.0
  18. |#
  19.  
  20. (declare (usual-integrations))
  21.  
  22. (define-macro (deflap name . lap)
  23.   `(define ,name
  24.      (scode-eval
  25.       ',((access lap->code (->environment '(compiler top-level)))
  26.      name
  27.      lap)
  28.       system-global-environment)))
  29.  
  30. (define set-floating-error-mask!
  31.   (let ()
  32.     (deflap set-floating-error-mask/8.0!
  33.       (entry-point set-floating-error-mask/8.0!)
  34.       (scheme-object CONSTANT-0 #F)
  35.       (scheme-object CONSTANT-1 0)
  36.       (external-label () #x202 (@pcr set-floating-error-mask/8.0!))
  37.  
  38.       (LABEL set-floating-error-mask/8.0!)
  39.                     ; arg = 2, cont = 19
  40.       (fstws () 0 (offset 0 0 21))    ; flags to free
  41.       (ldw () (offset 0 0 21) 6)    ; flags to reg 6
  42.       (copy () 6 7)            ; copy flags to 7
  43.       (dep () 2 31 5 7)            ; arg merged with flags in 7
  44.       (stw () 7 (offset 0 0 21))    ; new flags to free
  45.       (dep () 6 31 5 2)            ; flags merged with arg in 2
  46.       (fldws () (offset 0 0 21) 0)    ; store flags
  47.       (bv (n) 0 19)            ; return
  48.       )
  49.  
  50.     (deflap set-floating-error-mask/7.4!
  51.       (entry-point set-floating-error-mask/7.4!)
  52.       (scheme-object CONSTANT-0 #F)
  53.       (scheme-object CONSTANT-1 0)
  54.       (external-label () #x202 (@pcr set-floating-error-mask/7.4!))
  55.  
  56.       (LABEL set-floating-error-mask/7.4!)
  57.  
  58.       (fstws () 0 (offset 0 0 21))    ; flags to free
  59.       (ldw () (offset 0 0 #x16) 2)    ; arg to reg 2
  60.       (ldw () (offset 0 0 21) 6)    ; flags to reg 6
  61.       (copy () 6 7)            ; copy flags to 7
  62.       (dep () 2 31 5 7)            ; arg merged with flags in 7
  63.       (stw () 7 (offset 0 0 21))    ; new flags to free
  64.       (dep () 6 31 5 2)            ; flags merged with arg in 2
  65.       (fldws () (offset 0 0 21) 0)    ; store flags
  66.       (ldo () (offset 4 0 #x16) #x16)    ; pop arg
  67.       (ldwm () (offset 4 0 #x16) 6)    ; pop ret add
  68.       (dep () 5 5 6 6)            ; remove tag
  69.       (bv (n) 0 6)            ; return
  70.       )
  71.  
  72.     (if (object-type? 0 0)        ; untagged fixnums?
  73.     set-floating-error-mask/8.0!
  74.     set-floating-error-mask/7.4!)))