module/language/assembly.scm

   1 ;;; Guile Virtual Machine Assembly
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (language assembly)
  23   #:use-module (system base pmatch)
  24   #:use-module (system vm instruction)
  25   #:export (byte-length
  26             assembly-pack assembly-unpack
  27             object->assembly assembly->object))
  28
  29 ;; nargs, nrest, nlocs, nexts, len, metalen
  30 (define *program-header-len* (+ 1 1 1 1 4 4))
  31
  32 ;; lengths are encoded in 3 bytes
  33 (define *len-len* 3)
  34
  35 (define (byte-length assembly)
  36   (pmatch assembly
  37     (,label (guard (not (pair? label)))
  38      0)
  39     ((load-integer ,str)
  40      (+ 1 *len-len* (string-length str)))
  41     ((load-number ,str)
  42      (+ 1 *len-len* (string-length str)))
  43     ((load-string ,str)
  44      (+ 1 *len-len* (string-length str)))
  45     ((load-symbol ,str)
  46      (+ 1 *len-len* (string-length str)))
  47     ((load-keyword ,str)
  48      (+ 1 *len-len* (string-length str)))
  49     ((define ,str)
  50      (+ 1 *len-len* (string-length str)))
  51     ((load-program ,nargs ,nrest ,nlocs ,nexts ,labels ,len ,meta . ,code)
  52      (+ 1 *program-header-len* len (if meta (1- (byte-length meta)) 0)))
  53     ((,inst . _) (guard (>= (instruction-length inst) 0))
  54      (+ 1 (instruction-length inst)))
  55     (else (error "unknown instruction" assembly))))
  56
  57 ;;;
  58 ;;; Code compress/decompression
  59 ;;;
  60
  61 (define *abbreviations*
  62   '(((make-int8 0) . (make-int8:0))
  63     ((make-int8 1) . (make-int8:1))))
  64
  65 (define *expansions*
  66   (map (lambda (x) (cons (cdr x) (car x))) *abbreviations*))
  67
  68 (define (assembly-pack code)
  69   (or (assoc-ref *abbreviations* code)
  70       code))
  71
  72 (define (assembly-unpack code)
  73   (or (assoc-ref *expansions* code)
  74       code))
  75
  76 \f
  77 ;;;
  78 ;;; Encoder/decoder
  79 ;;;
  80
  81 (define (object->assembly x)
  82   (cond ((eq? x #t) `(make-true))
  83         ((eq? x #f) `(make-false))
  84         ((null? x) `(make-eol))
  85         ((and (integer? x) (exact? x))
  86          (cond ((and (<= -128 x) (< x 128))
  87                 `(make-int8 ,(modulo x 256)))
  88                ((and (<= -32768 x) (< x 32768))
  89                 (let ((n (if (< x 0) (+ x 65536) x)))
  90                   `(make-int16 ,(quotient n 256) ,(modulo n 256))))
  91                (else #f)))
  92         ((char? x) `(make-char8 ,(char->integer x)))
  93         (else #f)))
  94
  95 (define (assembly->object code)
  96   (pmatch code
  97     ((make-true) #t)
  98     ((make-false) #f) ;; FIXME: Same as the `else' case!
  99     ((make-eol) '())
 100     ((make-int8 ,n)
 101      (if (< n 128) n (- n 256)))
 102     ((make-int16 ,n1 ,n2)
 103      (let ((n (+ (* n1 256) n2)))
 104        (if (< n 32768) n (- n 65536))))
 105     ((make-char8 ,n)
 106      (integer->char n))
 107     ((load-string ,s) s)
 108     ((load-symbol ,s) (string->symbol s))
 109     ((load-keyword ,s) (symbol->keyword (string->symbol s)))
 110     (else #f)))