;;;
;;; compiler.lisp
;;;
;;; Smalltalk bytecode compiler.
;;;

(cl:in-package :speakeasy)


;;;
;;; converter of literals to in-core representation
;;;

(defun intern-literal (literal)
  (etypecase literal
    (character
     (obj-oop +character-table-oop+ (char-code literal)))

    (string
     (intern-string literal))

    ((cons (eql :oop))
     (cadr literal))

    ((cons (eql :symbol))
     (intern-symbol (cadr literal)))

    ((cons (eql :number))
     (if (typep (cadr literal) '(unsigned-byte 15))
	 (box-integer (cadr literal))
	 (error "Unable to box number ~D" (cadr literal))))

    ((cons (eql :array))
     (let ((oop (allocate-oop))
	   (data (cdr literal)))
       (make-object oop :pointers (length data) +array-class-oop+)
       (loop
	  for i from 0
	  for datum in data
	  do (setf (obj-oop oop i) (intern-literal datum)))
       oop))))


;;;
;;; compiler for method bodies to symbolic instruction sequences
;;;

;; Instruction types:
;;
;; JUMP   (jump <kind> <target>)
;;   Where <kind> is (member :always :backwards :false :true or :long).
;;   Where <target> is a gensym.
;;
;; SEND   (send <selector-name> <num-args>)
;;   Where <selector-name> is a string.
;;   Where <num-args> is an integer.
;;
;; SEND-SUPER    (send-super <selector-name> <num-args>)
;;   Same as SEND.
;;
;; RETURN    (return <kind> <value>)
;;   Where <kind> is (member :block :method).
;;   Where <value> is :stack-top, a literal, or an identifier.
;;
;; DROP    (drop)
;;
;; PUSH    (push <value>)
;;   Where <value> is (member :stack-top :current-context), a literal
;; or an identifier.
;;
;; BLOCK-ARGS    (block-args <name>*)
;;   Where <name>* is one or more strings naming block arguments.
;;
;; STORE    (store <keep-value> <location>)
;;   Where <keep-value> is true if the value should be left on the
;; stack and <location> is an identifier.

(defun compile-conditional-expression (expression keep-value)
  (let ((branch-end (gensym))
	(final-end (gensym))
	(alternative-code
	 (compile-statements (third (cadddr expression))
			     (if keep-value :stack :none))))
    `(,@(compile-expression (cadr expression) t)
      (jump ,(if (string= "ifTrue:" (car expression) :end2 7)
		 :false :true)
	    ,branch-end)
      ,@(compile-statements (third (caddr expression))
			    (if keep-value :stack :none)
			    (if (or keep-value alternative-code)
				`((jump :always ,final-end))
				nil))
      ,branch-end
      ,@alternative-code
      ,final-end)))

(defun compile-loop-expression (expression keep-value)
  (let ((loop-start (gensym))
	(loop-exit (gensym)))
    `(,@(compile-expression (cadr expression) t)
      ,loop-start
      (push :stack-top)
      (send "value" 0)
      (jump ,(if (equal "whileTrue:" (car expression))
		 :false :true)
	    ,loop-exit)
      ,@(compile-statements (third (caddr expression)) :none)
      (jump :backwards ,loop-start)
      ,loop-exit
      (drop)
      ,@(when keep-value
	   '((push (:identifier "nil")))))))

(defun compile-expression (expression keep-value)
  (cond
    ((eql (car expression) #\_)
     ;; assignment
     (append (compile-expression (caddr expression) t)
	     `((store ,keep-value ,(cadr expression)))))

    ((eq (car expression) :block)
     (if (not keep-value)
	 (warn "eliminating dead expression ~S" expression)
	 (let ((target (gensym)))
	   `(,@(when (cadr expression)
		     `((block-args ,@(cadr expression))))
	     (push :active-context)
	     (push (:literal (:number ,(length (cadr expression)))))
	     (send "blockCopy:" 1)
	     (jump :long ,target)
	     ,@(nreverse (loop
			    for arg in (cadr expression)
			    collect `(store nil (:identifier ,arg))))
	     ,@(compile-statements (caddr expression) :block)
	     ,target))))

    ((member (car expression) '(:literal :identifier))
     (if (not keep-value)
	 (warn "eliminating dead expression ~S" expression)
	 `((push ,expression))))

    ((stringp (car expression))
     ;; method send
     ;(print expression)
     (cond
       ((and (member (car expression) '("ifTrue:" "ifFalse:"
					"ifTrue:ifFalse:"
					"ifFalse:ifTrue:")
		     :test #'equal)
	     ;; first arg is block with no args
	     (eq (car (caddr expression)) :block)
	     (null (cadr (caddr expression)))
	     ;; second arg is block with no args or nonexistant
	     (or (endp (cdddr expression))
		 (and (eq (car (cadddr expression)) :block)
		      (null (cadr (cadddr expression))))))
	;(print "conditional")
	(compile-conditional-expression expression keep-value))

       ((and (member (car expression) '("whileTrue:" "whileFalse:")
		     :test #'equal)
	     ;; receiver is block with no args
	     (eq (caadr expression) :block)
	     (null (cadr (cadr expression)))
	     ;; arg is block with no args
	     (eq (caaddr expression) :block)
	     (null (cadr (caddr expression))))
	(compile-loop-expression expression keep-value))

       (t
	`(,@(if (equal (cadr expression) '(:identifier "super"))
		'((push (:identifier "self")))
		(compile-expression (cadr expression) t))
	    ,@(loop
		 for argument in (cddr expression)
		 append (compile-expression argument t))
	    (,(if (equal (cadr expression) '(:identifier "super"))
		  'send-super
		  'send)
	      ,(car expression) ,(length (cddr expression)))
	    ,@(unless keep-value
		      '((drop)))))))

    (t (error "unable to compile expression ~S" expression))))

(defun compile-default-return (return-style control-transfer)
  (ecase return-style
    (:block
	'((return :block (:identifier "nil"))))
    (:method
	'((return :method (:identifier "self"))))
    (:stack
        (append '((push (:identifier "nil"))) control-transfer))
    (:none control-transfer)))

(defun compile-statement (statement return-style control-transfer)
  (let* ((keep-value (member return-style '(:stack :block)))
	 (instruction-tail control-transfer))

    ;; Default method return.
    (when (eq return-style :method)
      (setf instruction-tail '((return :method (:identifier "self")))))

    ;; Specific method return.
    (when (eql #\^ (car statement))
      (setf statement (cadr statement))
      (setf return-style :method)
      (setf keep-value t))

    ;; Non-default return.
    (when (and keep-value (not (eq return-style :stack)))
      (let ((return-value :stack-top))

	(when (member (car statement) '(:literal :identifier))
	  (setf return-value statement)
	  (setf statement nil))

	(setf instruction-tail
	      `((return ,return-style ,return-value)))))

    (if statement
	(append (compile-expression statement keep-value) instruction-tail)
	instruction-tail)))

(defun compile-statements (statements return-style &optional control-transfer)
  (if statements
      (loop
	 for (statement . is-more) on statements
	 for instructions = (compile-statement statement
					       (and (not is-more)
						    return-style)
					       (and (not is-more)
						    control-transfer))
	 appending instructions)
      (compile-default-return return-style control-transfer)))


;;;
;;; bytecode assembler
;;;

;; The bytecode assembler functions in two separate stages.
;; First, all non-jump instructions are encoded, as these
;; instructions have a fixed length and are not dependent on the
;; relative position of other instructions.  Second, the jump
;; instructions are encoded.

(defparameter +known-selectors+
  #("+"          "-"       "<"       ">"
    "<="         ">="      "="       "~="
    "*"          "/"       "\\"      "@"
    "bitShift:"  "\\\\"    "bitAnd:" "bitOr:"
    "at:"        "at:put:" "size"    "next"
    "nextPut:"   "atEnd"   "=="      "class"
    "blockCopy:" "value"   "value:"  "do:"
    "new"        "new:"    "x"       "y"))

(defun find-pool-variable (name pools)
  (let ((name-oop (find-symbol-in-image name)))
    (when name-oop
      (loop
	 for pool in pools
	 for association = (dictionary-association-at pool name-oop)
	 if association
	 return `(:oop ,association)))))

(defun encode-instruction (instruction block instance-vars
			   temporaries literals pools)
  (flet ((literal-index-for (value)
	   (or (position value literals :test #'equal)
	       (prog1
		   (fill-pointer literals)
		 (vector-push-extend value literals))))
	 (emit-byte (value)
	   (vector-push-extend value block)))
    (ecase (car instruction)
      (send
       (let* ((selector (second instruction))
	      (args (third instruction))
	      (known-selector-index (position selector +known-selectors+
					      :test #'equal))
	      (literal-index (unless known-selector-index
			       (literal-index-for `(:symbol ,selector)))))
	 (cond
	   (known-selector-index
	    (emit-byte (+ #xb0 known-selector-index)))

	   ((and (< args 3)
		 (< literal-index 16))
	    (emit-byte (+ #xd0 (ash args 4) literal-index)))

	   ((and (< args 8)
		 (< literal-index 32))
	    (emit-byte #x83)
	    (emit-byte (dpb args (byte 3 5) literal-index)))

	   ((and (< args 256)
		 (< literal-index 256))
	    (emit-byte #x84)
	    (emit-byte args)
	    (emit-byte literal-index))

	   (t
	    (error "too many args (~A) or literals (~A) to assemble SEND"
		   args (fill-pointer literals))))))

      (send-super
       (let* ((selector (second instruction))
	      (args (third instruction))
	      (literal-index (literal-index-for `(:symbol ,selector))))
	 (cond
	   ((and (< args 8)
		 (< literal-index 32))
	    (emit-byte #x85)
	    (emit-byte (dpb args (byte 3 5) literal-index)))

	   ((and (< args 256)
		 (< literal-index 256))
	    (emit-byte #x86)
	    (emit-byte args)
	    (emit-byte literal-index))

	   (t
	    (error "too many args (~A) or literals (~A) to assemble SEND-SUPER"
		   args (fill-pointer literals))))))

      (return
	(let ((kind (second instruction))
	      (value (third instruction)))
	  ;(format t "~S kind: ~S value: ~S~%" instruction kind value)
	  (if (and (eq kind :method)
		   (typep value '(cons (eql :identifier)))
		   (member (second value) '("self" "true" "false" "nil")
			   :test #'equal))
	      (emit-byte (+ #x78 (position (second value)
					   '("self" "true" "false" "nil")
					   :test #'equal)))
	      (progn
		(unless (eq value :stack-top)
		  (encode-instruction `(push ,value)
				      block instance-vars
				      temporaries literals pools))
		(emit-byte (if (eq kind :block) #x7d #x7c))))))

      (drop
       (emit-byte #x87))

      (push
       (let* ((value (second instruction))
	      (quick-push (position value '((:identifier "self")
					    (:identifier "true")
					    (:identifier "false")
					    (:identifier "nil")
					    (:literal (:number -1))
					    (:literal (:number 0))
					    (:literal (:number 1))
					    (:literal (:number 2)))
				    :test #'equal)))
	 (if quick-push
	     (emit-byte (+ #x70 quick-push))
	     (etypecase value
	       ((eql :stack-top)
		(emit-byte #x88))

	       ((eql :active-context)
		(emit-byte #x89))

	       ((cons (eql :identifier))
		(let* ((name (cadr value))
		       (receiver-index (position name instance-vars
						 :test #'equal))
		       (temporary-index (position name temporaries
						  :test #'equal))
		       (pool-literal (find-pool-variable name pools))
		       (pool-index (and pool-literal
					(not (or receiver-index
						 temporary-index))
					(literal-index-for pool-literal))))
		  (cond
		    (temporary-index
		     (cond
		       ((< temporary-index 16)
			(emit-byte (+ #x10 temporary-index)))
		       ((< temporary-index 64)
			(emit-byte #x80)
			(emit-byte (+ #x40 temporary-index)))
		       (t (error "too many temporaries to assemble PUSH"))))

		    (receiver-index
		     (cond
		       ((< receiver-index 16)
			(emit-byte (+ #x00 receiver-index)))
		       ((< receiver-index 64)
			(emit-byte #x80)
			(emit-byte (+ #x00 receiver-index)))
		       (t (error "too many instance vars to assemble PUSH"))))

		    (pool-index
		     (cond
		       ((< pool-index 32)
			(emit-byte (+ #x40 pool-index)))
		       ((< pool-index 64)
			(emit-byte #x80)
			(emit-byte (+ #xc0 pool-index)))
		       (t (error "too many literals to assemble PUSH"))))

		    (t (error "unable to find identifier for PUSH")))))

	       ((cons (eql :literal))
		(let ((literal-index (literal-index-for (second value))))
		  (cond
		    ((< literal-index 32)
		     (emit-byte (+ #x20 literal-index)))
		    ((< literal-index 64)
		     (emit-byte #x80)
		     (emit-byte (+ #x80 literal-index)))
		    (t (error "too many literals to assemble PUSH")))))))))

      (store
       (let* ((keep-value (second instruction))
	      (location (third instruction))
	      (name (second location))
	      (receiver-index (position name instance-vars :test #'equal))
	      (temporary-index (position name temporaries :test #'equal))
	      (pool-literal (find-pool-variable name pools))
	      (pool-index (and pool-literal
			       (not (or receiver-index temporary-index))
			       (literal-index-for pool-literal))))
	 (cond
	   (temporary-index
	    (cond
	      ((< temporary-index 8)
	       (when keep-value
		 (emit-byte #x88))
	       (emit-byte (+ #x68 temporary-index)))
	      ((< temporary-index 64)
	       (emit-byte (if keep-value #x81 #x82))
	       (emit-byte (+ #x40 temporary-index)))
	      (t (error "too many temporaries to assemble STORE"))))

	   (receiver-index
	    (cond
	      ((< receiver-index 8)
	       (when keep-value
		 (emit-byte #x88))
	       (emit-byte (+ #x60 receiver-index)))
	      ((< receiver-index 64)
	       (emit-byte (if keep-value #x81 #x82))
	       (emit-byte (+ #x00 receiver-index)))
	      (t (error "too many instance vars to assemble STORE"))))

	   (pool-index
	    (cond
	      ((< pool-index 64)
	       (emit-byte (if keep-value #x81 #x82))
	       (emit-byte (+ #xc0 pool-index)))
	      (t (error "too many literals to assemble STORE"))))

	   (t (error "unable to find identifier for STORE")))))

      (block-args
       ;; Does nothing, for informational purposes at a previous step.
       ))))

(defun encode-non-jump-instructions (instructions instance-vars
				     temporaries literals pools)
  ;; INSTRUCTIONS is a list of instructions (lists) and branch
  ;; labels (symbols).  Each list not beginning with the symbol
  ;; JUMP is replaced with an array containing the encoded form
  ;; of the instruction.  INSTANCE-VARS is a list of instance
  ;; variable names for the class as strings (in order of their
  ;; slots, usable with POSITION).  TEMPORARIES is a list of
  ;; temporary variable names as strings (this includes method
  ;; argument names, as they share storage) also as strings.
  ;; LITERALS is a vector with a fill pointer (for VECTOR-PUSH-
  ;; EXTEND) in which to store those literals used in the
  ;; instruction stream.
  ;;
  ;; I lied about the replacement of each instruction by an
  ;; array of its encoded form.  Each contiguous set of non-
  ;; jump instructions is replaced by a single vector of their
  ;; combined encoded forms.

  (let ((position instructions)
	(current-block nil)
	(instruction (car instructions)))
    (tagbody
       ;; Can't believe I'm using a tagbody...

       start
       ;; For debugging.
       ;;(format t "instruction: ~S~%" instruction)
       ;;(print instructions)
       ;;(print instruction)
       ;;(print (car position))
       ;;(terpri)

       ;; Check for end.
       (when (endp position)
	 (go finish))

       ;; Don't assemble labels or jumps.
       (when (typep instruction '(or symbol (cons (eql jump))))
	 (go next-position))

       ;; This is nasty: If we have a current block, INSTRUCTION
       ;; is a copy of what's in POSITION's CADR, so we patch out
       ;; that element of INSTRUCTIONS.  Otherwise, INSTRUCTION
       ;; is POSITION's CDR, where we need to store our new block.
       (if (arrayp (car position))
	   (setf (cdr position) (cddr position))
	   (progn
	     (setf current-block (make-array 32 :element-type '(unsigned-byte 8)
					     :fill-pointer 0))
	     (setf (car position) current-block)))

       ;; Actually encode the instruction.
       (encode-instruction instruction current-block instance-vars
			   temporaries literals pools)

       ;; Pick out the next instruction to be assembled.
       (setf instruction (cadr position))
       (go start)

       next-position
       ;; If we have a current block, this just ends up skipping
       ;; past it and re-evaluating the current instruction, which
       ;; is no loss, as we just end up here again and have to skip
       ;; again, ending up at a new instruction.
       (setf position (cdr position))
       (setf instruction (car position))
       (go start)

       finish)))

(defun encode-jump-instructions (instructions)
  ;; INSTRUCTIONS is a list of jump instructions (lists), branch
  ;; labels (symbols) and already-assembled code (arrays).  It
  ;; is altered by replacing each jump instruction with an array
  ;; containing its encoded form.

  ;; The format of a jump instruction is (JUMP <kind> <target>).

  ;; Jump kinds are (member :always :backwards :false :true
  ;; :long).  Only kinds :always and :false have single-byte
  ;; versions.  All other kinds use a two-byte encoding.

  ;; Our strategy is to make as many passes over INSTRUCTIONS as
  ;; needed.  Each pass resolves any jumps it finds that it can
  ;; compute the distance (and thus final encoding) for.

  ;; This algorithm will complete on any valid input. Proof:
  ;;
  ;; 1.) On each pass, all unresolved jumps that are not
  ;;     :incomputable are resolved. [axiom]
  ;; 2.) The only jumps which are :incomputable have an :always
  ;;     or a :false jump within their span. [axiom]
  ;; 3.) :always and :false jumps are forward-only. [axiom]
  ;; 4.) The last unresolved :always or :false jump on each pass
  ;;     is always resolved. [per 3, it is a forward jump; per
  ;;     2, it is not :incomputable (being the last such jump,
  ;;     it cannot have another within its span); per 1, it is
  ;;     therefore resolved]
  ;; 5.) Any pass with no unresolved :always or :false jumps
  ;;     remaining will resolve all unresolved jumps. [per 2,
  ;;     no unresolved jumps are :incomputable; per 1, all jumps
  ;;     that are not :incomputable are resolved]
  ;; 6.) Each pass can always resolve at least one unresolved
  ;;     jump. [per 4, if there are :always or :false jumps, the
  ;;     last one can be resolved; per 5, if there are no
  ;;     :always or :false jumps all jumps can be resolved]
  ;;
  ;; The algorithm makes successive passes until all jumps are
  ;; resolved.  Per 6, each pass resolves at least one jump.  As
  ;; there are a finite number of instructions (and thus jumps)
  ;; in the input, there will be a pass in which the last
  ;; unresolved jump is resolved.  Q.E.D.

  (labels
      ((find-jump-target (target)
	 "Given TARGET, a symbol, return the cons cell in INSTRUCTIONS
          that contains it or NIL if it is not found."
	 (loop
	    for candidate on instructions
	    when (eq target (car candidate))
	    return candidate))

       (compute-jump-distance (start end)
	 "Given START and END, two cons cells in INSTRUCTIONS, return
          the number of octets of assembled code between the two
          (exclusive of START so as to not bias forward jumps,
          inclusive of END so as to correctly bias backward jumps) or
          :INCOMPUTABLE if there is a jump of kind :always or :false
          within the span."
	 (unless (and start end)
	   (error "jump target not found"))
	 (loop
	    for element on (cdr start)
	    when (typep element '(cons array))
	    sum (length (car element))
	    when (typep element '(cons (cons (eql jump)
					(cons (member :backwards :true
						      :long)))))
	    sum 2
	    when (typep element '(cons (cons (eql jump)
					(cons (member :always :false)))))
	    return :incomputable
	    until (eq element end)))

       (encode-jump (position kind distance)
	 "Replace the jump instruction of KIND for DISTANCE in the
          CAR of POSITION with a vector containing its encoded form."
	 (flet ((encode (&rest values)
		  (setf (car position)
			(make-array (length values)
				    :element-type '(unsigned-byte 8)
				    :initial-contents values))))
	   (cond
	     ((and (eql kind :always)
		   (<= 1 distance 8))
	      (encode (+ #x90 distance -1)))

	     ((and (eql kind :false)
		   (<= 1 distance 8))
	      (encode (+ #x98 distance -1)))

	     ((and (member kind '(:always :long))
		   (< distance #x400))
	      (encode (+ #xa4 (ldb (byte 2 8) distance))
		      (ldb (byte 8 0) distance)))

	     ((and (eql kind :backwards)
		   (<= distance #x400))
	      (let ((distance (- #x400 distance)))
		(encode (+ #xa0 (ldb (byte 2 8) distance))
			(ldb (byte 8 0) distance))))

	     ((and (eql kind :true)
		   (< distance #x400))
	      (encode (+ #xa8 (ldb (byte 2 8) distance))
		      (ldb (byte 8 0) distance)))

	     ((and (eql kind :false)
		   (< distance #x400))
	      (encode (+ #xac (ldb (byte 2 8) distance))
		      (ldb (byte 8 0) distance)))

	     (t (error "unable to encode jump kind ~A distance ~A"
		       kind distance)))))

       (try-resolve-jump (position)
	 "Attempt to resolve the jump instruction in the cons cell
          POSITION in INSTRUCTIONS, replacing its CAR with a vector
          of the instructions encoded form if resolution was possible."
	 (destructuring-bind
	       (kind target)
	     (cdar position)
	   (let* ((destination (find-jump-target target))
		  (distance
		   (if (eq kind :backwards)
		       (compute-jump-distance destination position)
		       (compute-jump-distance position destination))))
	     (unless (eq distance :incomputable)
	       (encode-jump position kind distance))))))

    (loop
       while (some #'listp instructions)
       do (loop
	     for instruction on instructions
	     when (listp (car instruction))
	     do (try-resolve-jump instruction)))))

(defun coalesce-bytecodes (instructions)
  (loop
     with length = (loop
		      for element in instructions
		      when (arrayp element)
		      sum (length element))
     with result = (make-array length :element-type '(unsigned-byte 8))
     with position = 0
     for element in instructions
     when (arrayp element)
     do (setf (subseq result position) element)
       (incf position (length element))
     finally (return result)))

;;;
;;; main compiler entry point
;;;

(defun compile-method (class parsed-code method-class)
  (destructuring-bind
	(selector arguments primitive temporaries statements)
      parsed-code
    (declare (ignore selector))
    (let* ((instructions (copy-list (compile-statements statements :method)))
	   (block-args (loop
			  for args in (remove-if-not
				       (lambda (instruction)
					 (and (listp instruction)
					      (eql (car instruction)
						   'block-args)))
				       instructions)
			  appending (cdr args)))
	   (needs-header-extension (or primitive (> (length arguments) 4)))
	   (needs-method-class (or needs-header-extension
				   (some (lambda (instruction)
					   (and (listp instruction)
						(eql (car instruction)
						     'send-super)))
					 instructions)))
	   (flag-value (if needs-header-extension 7 (length arguments)))
	   (all-temporaries (append arguments temporaries block-args))

	   ;; HACK: method-class is only currently available on instance
	   ;; methods, and class methods aren't supposed to have access
	   ;; to instance variables (and if they are, they're instance
	   ;; methods on Class or its superclasses, not class methods).
	   (receiver-variables (and method-class
				    (all-class-instance-variables class)))
	   (pools (all-variable-pools-for-class class))

	   (literals (make-array 16 :fill-pointer 0))
	   header)

      ;(print instructions)
      (encode-non-jump-instructions instructions receiver-variables
				    all-temporaries literals pools)
      ;(print instructions)
      (encode-jump-instructions instructions)
      (setf instructions (coalesce-bytecodes instructions))

      (print instructions)
      (when needs-header-extension
	(vector-push-extend `(:number ,(dpb (length arguments)
					    (byte 5 8) (or primitive 0)))
			    literals))
      (when needs-method-class
	;; NOTE: May wish to have a name/class association for metaclass
	;; method classes.
	(if method-class
	    (vector-push-extend `(:oop ,method-class) literals)
	    (vector-push-extend `(:oop ,(make-association +nil-oop+ class))
				literals)))
      (print literals)

      ;; Build header, checking for special primitives as needed.
      (cond
	;; Return self.
	((and (zerop flag-value)
	      (equalp instructions #1A(#x78)))
	 (setf instructions #1A())
	 (setf header (dpb 5 (byte 3 13) 1)))

	;; Return instance var, first case.
	((and (zerop flag-value)
	      (= 2 (length instructions))
	      (< 16 (aref instructions 0))
	      (= 124 (aref instructions 1)))
	 (setf header (dpb 6 (byte 3 13)
			   (dpb (aref instructions 0)
				(byte 5 8) 1)))
	 (setf instructions #1A()))

	;; Return instance var, second case.
	((and (zerop flag-value)
	      (= 3 (length instructions))
	      (= #x80 (aref instructions 0))
	      (< 32 (aref instructions 1))
	      (= 124 (aref instructions 2)))
	 (setf header (dpb 6 (byte 3 13)
			   (dpb (aref instructions 1)
				(byte 5 8) 1)))
	 (setf instructions #1A()))

	;; Default case.
	(t (setf header
		 (dpb flag-value (byte 3 13)
		      (dpb (length all-temporaries) (byte 5 8)
			   ;; FIXME: Really compute large context flag.
			   (dpb 1 (byte 1 7)
				(dpb (length literals) (byte 6 1)
				     1)))))))
      (print header)

      (setf literals
	    (map 'list 'intern-literal literals))

      (values header literals instructions))))

;;; EOF
