[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)))
(t
(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))
(t
(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)))
(t
(setq pc (+ 3 pc))
(cons (lsh off -8)
(cons (logand off 255)
(cons (+ (symbol-value op) 7)
bytes))))))))
(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))))
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- bug#4264: correction,
jpff <=