mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Better range checks in the assembler

Browse source 
* module/system/vm/assembler.scm (pack-u8-u24, pack-u8-s24):
  (pack-u1-u7-u24, pack-u8-u12-u12, pack-u8-u8-u16, pack-u8-u8-u8-u8):
  Prevent adjacent fields from stompling each other.
This commit is contained in:
Andy Wingo 2013-10-31 22:57:06 +01:00
parent ef47c4229c
commit cb8054c7ac
1 changed files with 28 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

34
module/system/vm/assembler.scm
View file

@ -68,10 +68,14 @@
;;; RTL code consists of 32-bit units, often subdivided in some way.
;;; These helpers create one 32-bit unit from multiple components.
(define-syntax-rule (pack-u8-u24 x y)
(define-inlinable (pack-u8-u24 x y)
(unless (<= 0 x 255)
(error "out of range" x))
(logior x (ash y 8)))
(define-syntax-rule (pack-u8-s24 x y)
(define-inlinable (pack-u8-s24 x y)
(unless (<= 0 x 255)
(error "out of range" x))
(logior x (ash (cond
((< 0 (- y) #x800000)
(+ y #x1000000))
@ -80,16 +84,34 @@
(else (error "out of range" y)))
8)))
(define-syntax-rule (pack-u1-u7-u24 x y z)
(define-inlinable (pack-u1-u7-u24 x y z)
(unless (<= 0 x 1)
(error "out of range" x))
(unless (<= 0 y 127)
(error "out of range" y))
(logior x (ash y 1) (ash z 8)))
(define-syntax-rule (pack-u8-u12-u12 x y z)
(define-inlinable (pack-u8-u12-u12 x y z)
(unless (<= 0 x 255)
(error "out of range" x))
(unless (<= 0 y 4095)
(error "out of range" y))
(logior x (ash y 8) (ash z 20)))
(define-syntax-rule (pack-u8-u8-u16 x y z)
(define-inlinable (pack-u8-u8-u16 x y z)
(unless (<= 0 x 255)
(error "out of range" x))
(unless (<= 0 y 255)
(error "out of range" y))
(logior x (ash y 8) (ash z 16)))
(define-syntax-rule (pack-u8-u8-u8-u8 x y z w)
(define-inlinable (pack-u8-u8-u8-u8 x y z w)
(unless (<= 0 x 255)
(error "out of range" x))
(unless (<= 0 y 255)
(error "out of range" y))
(unless (<= 0 z 255)
(error "out of range" z))
(logior x (ash y 8) (ash z 16) (ash w 24)))
(define-syntax pack-flags