mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-01 01:40:21 +02:00
137 lines
4.1 KiB
Scheme
137 lines
4.1 KiB
Scheme
;;; Guile VM code converters
|
|
|
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation; either version 2, or (at your option)
|
|
;; any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program; see the file COPYING. If not, write to
|
|
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
|
;; Boston, MA 02111-1307, USA.
|
|
|
|
;;; Code:
|
|
|
|
(define-module (system vm conv)
|
|
:use-module (system vm core)
|
|
:use-module (ice-9 match)
|
|
:use-module (ice-9 regex)
|
|
:export (code-pack code-unpack object->code object->dump-code code->object))
|
|
|
|
(define (code-pack code)
|
|
(match code
|
|
((inst (? integer? n))
|
|
(cond ((< n 10)
|
|
(let ((abbrev (string->symbol (format #f "~A:~A" inst n))))
|
|
(if (instruction? abbrev) (list abbrev) code)))
|
|
((> n 255)
|
|
(let ((double (string->symbol (format #f "~A*2" inst))))
|
|
(if (instruction? double)
|
|
(list double (quotient n 256) (modulo n 256))
|
|
(apply error "Index out of range:" code))))
|
|
(else code)))
|
|
(else code)))
|
|
|
|
(define (code-unpack code)
|
|
(let ((inst (symbol->string (car code))))
|
|
(cond
|
|
((string-match "^([^:]*):([0-9]+)$" inst) =>
|
|
(lambda (data)
|
|
(cons* (string->symbol (match:substring data 1))
|
|
(string->number (match:substring data 2))
|
|
(cdr code))))
|
|
(else code))))
|
|
|
|
(define (object->code x)
|
|
(cond ((eq? x #t) `(make-true))
|
|
((eq? x #f) `(make-false))
|
|
((null? x) `(make-eol))
|
|
((integer? x)
|
|
(cond ((and (<= -128 x) (< x 128))
|
|
`(make-int8 ,(modulo x 256)))
|
|
((and (<= -32768 x) (< x 32768))
|
|
(let ((n (if (< x 0) (+ x 65536) x)))
|
|
`(make-int16 ,(quotient n 256) ,(modulo n 256))))
|
|
(else #f)))
|
|
((char? x) `(make-char8 ,(char->integer x)))
|
|
(else #f)))
|
|
|
|
(define (object->dump-code x)
|
|
(let ((stack '()))
|
|
(define (push-code! code)
|
|
(set! stack (cons code stack)))
|
|
(let dump! ((x x))
|
|
(cond
|
|
((object->code x) => push-code!)
|
|
((string? x)
|
|
(push-code! `(load-string ,x)))
|
|
((symbol? x)
|
|
(push-code! `(load-symbol ,(symbol->string x))))
|
|
((keyword? x)
|
|
(push-code! `(load-keyword ,(symbol->string (keyword-dash-symbol x)))))
|
|
((list? x)
|
|
(push-code! `(mark))
|
|
(for-each dump! x)
|
|
(push-code! `(list)))
|
|
((pair? x)
|
|
(dump! (car x))
|
|
(dump! (cdr x))
|
|
(push-code! `(cons)))
|
|
((vector? x)
|
|
(push-code! `(mark))
|
|
(for-each dump! (vector->list x))
|
|
(push-code! `(vector)))
|
|
(else
|
|
(error "Cannot dump:" x))))
|
|
(reverse! stack)))
|
|
|
|
(define (code->object code)
|
|
(match code
|
|
(('make-true) #t)
|
|
(('make-false) #f) ;; FIXME: Same as the `else' case!
|
|
(('make-eol) '())
|
|
(('make-int8 n)
|
|
(if (< n 128) n (- n 256)))
|
|
(('make-int16 n1 n2)
|
|
(let ((n (+ (* n1 256) n2)))
|
|
(if (< n 32768) n (- n 65536))))
|
|
(('make-char8 n)
|
|
(integer->char n))
|
|
(else #f)))
|
|
|
|
(define-public (make-byte-decoder bytes)
|
|
(let ((addr 0) (size (string-length bytes)))
|
|
(define (pop)
|
|
(let ((byte (char->integer (string-ref bytes addr))))
|
|
(set! addr (1+ addr))
|
|
byte))
|
|
(define (pop-length)
|
|
(let ((len (pop)))
|
|
(cond ((< len 254) len)
|
|
((= len 254) (+ (* (pop) 256) (pop)))
|
|
(else (+ (* (pop) 256 256 256) (* (pop) 256 256)
|
|
(* (pop) 256) (pop))))))
|
|
(lambda ()
|
|
(if (< addr size)
|
|
(let* ((start addr)
|
|
(inst (opcode->instruction (pop)))
|
|
(n (instruction-length inst))
|
|
(code (if (< n 0)
|
|
;; variable length
|
|
(let* ((end (+ (pop-length) addr))
|
|
(str (substring bytes addr end)))
|
|
(set! addr end)
|
|
(list inst str))
|
|
;; fixed length
|
|
(do ((n n (1- n))
|
|
(l '() (cons (pop) l)))
|
|
((= n 0) (cons* inst (reverse! l)))))))
|
|
(values start code))
|
|
#f))))
|