anchor.diff:        (if (eql operand 'acc)
             0
             (error "Expected ACC, got ~S in" operand)))
  -     ((src dst)
  -      (sym-eval operand symtable)))))
  +     ((src)
  +      (dpb (ldb (byte 28 0) (sym-eval operand symtable))
  +           (byte 28 28) 0))
  +     ((dst)
  +      (ldb (byte 28 0) (sym-eval operand symtable))))))
  +
  +(defun text (items)
  +  (with-output-to-string (*standard-output*)
  +    (dolist (item items)
  +      (etypecase item
  +        (string  (princ item))
  +        (integer (princ (code-char item)))))))
  +
  +(defun encode-ascii (string)
  +  (loop
  +    :repeat +bytes-per-word+
  +    :with word = 0
  +    :for i :from 0
  +    :for byte = (if (< i (length string))
  +                    (char-code (aref string i))
  +                    0)
  +    :do (setf word (+ (* 256 word) byte))
  +    :finally (return word)))
   
   (defun assemble (address lap)
     "
  
positive.code: ;;;;AUTHORS
  ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
  ;;;;MODIFICATIONS
  ;;;;    2011-01-08 <PJB> Created.
  ;;;;BUGS
  ;;;;LEGAL
  ;;;;    AGPL3
  ;;;;    
  ;;;;    Copyright Pascal J. Bourguignon 2011 - 2012
  ;;;;    
  ;;;;    This program is free software: you can redistribute it and/or modify
  ;;;;    it under the terms of the GNU Affero General Public License as published by
  
negative.code: here, executed during the first phase for EQL, and the second phase
  for the other LAP forms.
  
  Return the code vector, the symbol table (an a-list of (symbol . values)),
  and a bit-vector indicating instructions (vs. dcl) in the code vector.
  "
    (loop
      :with bits = '()
      :with symtable ; a-list symbol -> address
        = (loop
            :named first-phase
            :with symtable = '()
            :with address = address
            :for statement :in lap
            :if (atom statement) :do (push (cons statement address) symtable)
              :else :do (case (first statement)
                          ((eql)
                           (unless (symbolp (second statement))
                             (error "EQL requires a symbol as first argument instead of ~S"
                                    (second statement)))
                           (push (cons (second statement)
                                       (sym-eval (third statement)
                                                 (acons '* address symtable)))
                                 symtable))
                          ((dcl)
                           (loop :repeat (length (rest statement)) :do (push 0 bits))
                           (incf address (length (rest statement))))
                          ((ascii)
                           (let* ((string (text (rest statement)))
                                  (size   (ceiling (length string) +bytes-per-word+)))
                             (loop :repeat size :do (push 0 bits))
                             (incf address size)))
                          (otherwise
                           (push 1 bits)
                           (incf address)))
            :finally (return-from first-phase symtable))
      :with address = address
      :with code = '()
      :for statement :in lap
      :do (when (listp statement)
            (let* ((op (first statement))
                   (instruction (find op *instructions* :key (function caadr))))
              (handler-case
                  (cond
                    ((eql op 'eql))
                    ((eql op 'dcl)
                     (let ((symtable  (acons '* address symtable)))
                       (dolist (expr (rest statement))
                         (push (sym-eval expr symtable) code))
                       (incf address (length (rest statement)))))
                    ((eql op 'ascii)
                     (let* ((string (text (rest statement)))
                            (size   (ceiling (length string) +bytes-per-word+)))
                       (loop
                         :repeat size
                         :for i :from 0 :by +bytes-per-word+
                         :do (push (encode-ascii (subseq string i (min (length string) (+ i +bytes-per-word+)))) code))
                       (incf address size)))
                    (instruction
                     (push
                      (encode-instruction
                       (first instruction)
                       (validate-operand (second (second instruction)) (second statement)
                                         (acons '* address symtable))
                       (validate-operand (third  (second instruction)) (third  statement)
                                         (acons '* address symtable)))
                      code)
                     (incf address))
                    (t
                     (error "Invalid opcode in lap statement")))
                (error (err)
                  (error "~A in ~A: ~S" err address statement)))))
      :finally (return (values (coerce (nreverse code) 'vector)
                               symtable
                               (make-array (length bits) :element-type 'bit :initial-contents (nreverse bits))))))
  
  (defun print-instruction (pc sexp &optional symtab)
    (format t "~4,'0X: " pc)
    (loop
      :initially (princ "(")
      :finally   (princ ")")
      :for sep = "" :then " "
      :for item :in sexp
      :do  (princ sep)
           (typecase item
             (symbol (princ item))
             (integer (let ((sym (rassoc item symtab)))
                        (if sym
                            (princ (car sym))
                            (format t "~X" item))))))
    (format t "~%"))
  
  (defun disassemble (address code symtab &optional bits)
    (format t "~%Symbol Table~%--------------------~2%")
    (loop :for (symbol . address) :in (sort (copy-list symtab) (function <) :key (function cdr))
          :do (format t "~32A ~16,'0X  ~:*~D~%" symbol address))
    (format t "~%")
    (format t "~%Program~%--------------------~2%")
    (loop
      :for pc :from address
      :for instruction :across code
      :for bit :across (or bits (make-array (length code) :element-type 'bit :initial-element 1))
      :do (let ((symbols (remove pc symtab :key (function cdr) :test (function /=))))
            (if symbols
                (format t "~{~32A~^~%~} " (mapcar (function car) symbols))
                (format t "~33<~>")))
      :do (if (plusp bit)
              (flet ()
                (let* ((opcode (opcode instruction))
                       (src    (src    instruction))
                       (dst    (dst    instruction))
                       (entry  (assoc opcode *instructions*)))
                  (if entry
                      (print-instruction pc (subst src 'src (subst dst 'dst (second entry))) symtab)
                      (print-instruction pc `(illegal-instruction ,instruction) symtab))))
              (print-instruction pc `(dcl ,instruction) symtab)))
    (format t "~%"))
  
  ;;; Finally, we can write a few missing instructions in assembler,
  ;;; load them in the machine, and write a program using them.
  