bug#4264: correction

bug#4264: correction

[jpff]

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))))