[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

bug#4264: correction

From: jpff
Subject: bug#4264: correction
Date: Wed, 26 Aug 2009 06:36:58 +0100

That function should be as below -- at least it works this way
==John ffitch

(defun byte-compile-lapcode (lap)
  "Turns lapcode into bytecode.  The lapcode is destroyed."
  ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
  (let ((pc 0)                  ; Program counter
        op off                  ; Operation & offset
        (bytes '())             ; Put the output bytes here
        (patchlist nil))        ; List of tags and goto's to patch
    (while lap
      (setq op (car (car lap))
            off (cdr (car lap)))
      (cond ((not (symbolp op))
             (error "Non-symbolic opcode `%s'" op))
            ((eq op 'TAG)
             (setcar off pc)
             (setq patchlist (cons off patchlist)))
            ((memq op byte-goto-ops)
             (setq pc (+ pc 3))
             (setq bytes (cons (cons pc (cdr off))
                               (cons nil
                                     (cons (symbol-value op) bytes))))
             (setq patchlist (cons bytes patchlist)))
             (setq bytes
                   (cond ((cond ((consp off)
                                 ;; Variable or constant reference
                                 (setq off (cdr off))
                                 (eq op 'byte-constant)))
                          (cond ((< off byte-constant-limit)
                                 (setq pc (1+ pc))
                                 (cons (+ byte-constant off) bytes))
                                 (setq pc (+ 3 pc))
                                 (cons (lsh off -8)
                                       (cons (logand off 255)
                                             (cons byte-constant2 bytes))))))
                         ((<= byte-listN (symbol-value op))
                          (setq pc (+ 2 pc))
                          (cons off (cons (symbol-value op) bytes)))
                         ((< off 6)
                          (setq pc (1+ pc))
                          (cons (+ (symbol-value op) off) bytes))
                         ((< off 256)
                          (setq pc (+ 2 pc))
                          (cons off (cons (+ (symbol-value op) 6) bytes)))
                          (setq pc (+ 3 pc))
                          (cons (lsh off -8)
                                (cons (logand off 255)
                                      (cons (+ (symbol-value op) 7)
      (setq lap (cdr lap)))
    ;;(if (not (= pc (length bytes)))
    ;;    (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
    ;; Patch PC into jumps
    (let (bytes)
      (while patchlist
        (setq bytes (car patchlist))
        (cond ((atom (car bytes)))      ; Tag
              (t                        ; Absolute jump
               (setq pc (car (cdr (car bytes))))        ; Pick PC from tag
               (setcar (cdr bytes) (logand pc 255))
               (setcar bytes (lsh pc -8))
               ;; FIXME: Replace this by some workaround.
               (if (> (car bytes) 255) (error "Bytecode overflow"))))
        (setq patchlist (cdr patchlist))))
    (apply 'unibyte-string (nreverse bytes))))

reply via email to

[Prev in Thread] Current Thread [Next in Thread]