init500.lisp

(funcall #'(setf iref)
	 #'(lambda (object) (= (ldb (cons 2 0) (ival object)) 1))
	 'consp 5)
(funcall #'(setf iref)
	 #'(lambda (new-definition function-name)
	     (if (consp function-name)
		 (funcall #'(setf iref) new-definition
			  (car (cdr function-name)) 6)
		 (progn
		   (funcall #'(setf iref) new-definition function-name 5)
		   (funcall #'(setf iref)
			    (dpb 0 '(1 . 1) (iref function-name 8))
			    function-name 8)))
	     new-definition)
	 'fdefinition 6)
(funcall #'(setf iref)
	 #'(lambda (new-function symbol &optional environment)
	     (funcall #'(setf iref) new-function symbol 5)
	     (funcall #'(setf iref) (dpb 1 '(1 . 1) (iref symbol 8))
		      symbol 8)
	     new-function)
	 'macro-function 6)
(funcall #'(setf macro-function)
	 #'(lambda (name lambda-list &rest body)
	     (list 'progn
		   (list 'funcall '#'(setf macro-function)
			 (list 'function
			       (cons 'lambda (cons lambda-list body)))
			 (list 'quote name))
		   (list 'quote name)))
	 'defmacro)
(defmacro defun (name lambda-list &rest body)
  (list 'progn
	(list 'funcall '#'(setf fdefinition)
	      (list 'function
		    (list 'lambda lambda-list
			  (cons 'block (cons (if (consp name)
						 (car (cdr name))
						 name)
					     body))))
	      (list 'quote name))
	(list 'quote name)))
(defmacro setf (place new-value)
  (if (consp place)
      (cons 'funcall (cons (list 'function (list 'setf (car place)))
			   (cons new-value (cdr place))))
      (list 'setq place new-value)))
(defun append (&rest lists)
  (if (cdr lists)
      (let ((list (car lists))
	    (result nil)
	    (end nil))
	(if list
	    (tagbody
	     start
	       (if list
		   (progn
		     (setf end (if end
				   (setf (cdr end) (list (car list)))
				   (setf result (list (car list)))))
		     (setf list (cdr list))
		     (go start)))
	       (setf (cdr end) (apply #'append (cdr lists)))
	       (return-from append result))
	    (apply #'append (cdr lists))))
      (car lists)))
(defun backquote-expand (list level)
  (if (consp list)
      (if (eq 'backquote (car list))
	  (list 'list ''backquote
		(backquote-expand (car (cdr list)) (+ level 1)))
	  (if (eq 'unquote (car list))
	      (if (= level 0)
		  (car (cdr list))
		  (list 'list ''unquote
			(backquote-expand (car (cdr list)) (- level 1))))
	      (if (eq 'unquote-splicing (car list))
		  (if (= level 0)
		      (values (car (cdr list)) t)
		      (list 'list ''unquote-splicing
			    (backquote-expand (car (cdr list)) (- level 1))))
		  (labels ((collect (list)
			     (if (consp list)
				 (cons (multiple-value-call
					   #'(lambda (value
						      &optional splicingp)
					       (if splicingp
						   value
						   (list 'list value)))
				       (backquote-expand (car list) level))
				     (collect (cdr list)))
				 (list (list 'quote list)))))
		    (cons 'append (collect list))))))
      (list 'quote list)))
(defmacro backquote (form)
  (backquote-expand form 0))
(defun macro-function (symbol &optional environment)
  "(dolist (binding environment)
    (when (and (consp (car binding))
	       (= (floor (ival (cdar binding)) 16) 1)
	       (eq (caar binding) symbol))
      (return-from macro-function 
	(when (= (ldb '(1 . 4) (ival (cdr binding))) 1)
	  (cdr binding)))))"
  (if (= (ldb '(1 . 1) (iref symbol 8)) 1)
      (iref symbol 5)))
(defun macroexpand-1 (form &optional env)
  (if (consp form)
      (let ((definition (macro-function (car form) env)))
	(if definition
	    (values (apply definition (cdr form)) t)
	    (values form nil)))
      (if (and form (symbolp form) (= (ldb '(1 . 0) (iref form 8)) 1))
	  (values (iref form 4) t)
	  (values form nil))))
(defun macroexpand (form &optional env)
  (multiple-value-bind (form expanded-p)
      (macroexpand-1 form env)
    (if expanded-p
	(tagbody
	 start
	   (multiple-value-bind (expansion expanded-p)
	       (macroexpand-1 form env)
	     (if expanded-p
		 (progn
		   (setq form expansion)
		   (go start))
		 (return-from macroexpand (values expansion t)))))
	(values form nil))))
(defmacro define-symbol-macro (symbol expansion)
  `(progn
    (setf (iref ',symbol 4) ',expansion)
    (setf (iref ',symbol 8) (dpb 1 (cons 1 0) (iref ',symbol 8)))
    ',symbol))
(defun special-operator-p (symbol)
  (member symbol '(block catch eval-when flet function go if labels let let*
		   load-time-value locally macrolet multiple-value-call
		   multiple-value-prog1 progn progv quote return-from setq
		   symbol-macrolet tagbody the throw unwind-protect)))
(defun constantp (form &optional environment)
  (not (or (and (symbolp form)
		(zerop (ldb '(1 . 4) (iref form 8))))
	   (and (consp form)
		(not (eq (car form) 'quote))))))
(defun null (object) (if object nil t))
(defun not (object) (if object nil t))
(defun length (sequence)
  (let ((tag (ldb '(2 . 0) (ival sequence))))
    (if (= tag 0)
	0
	(if (= tag 1)
	    (let ((i 0)) (dolist (elem sequence i) (setf i (+ 1 i))))
	    (if (= tag 2)
		(let ((subtag (iref sequence 1)))
		  (if (= subtag 3)
		      (/ (ival (iref sequence 0)) 256)
		      (if (= subtag 4)
			  (let ((dimensions/fill (iref sequence 3)))
			    (if (consp dimensions/fill)
				(error "not a sequence")
				(or dimensions/fill
				    (length (iref sequence 4)))))
			  0)))
		(let ((subtag (jref sequence 1)))
		  (if (= subtag 20)
		      (- (/ (jref sequence 0) 64) 4)
		      (if (= subtag 116)
			  (- (/ (jref sequence 0) 8) 31)
			  (error "not a sequence")))))))))
(defun mod (x y) (multiple-value-call #'(lambda (q r) r) (floor x y)))
(defun functionp (object) (eq (type-of object) 'function))
(defun coerce (object result-type)
  (if (typep object result-type)
      object
      (case result-type
	((t) object)
	(character (character object))
	(function (if (and (consp object) (eq (car object) 'lambda))
		      (eval (list 'function object))
		      (if (fboundp object)
			  (fdefinition object))
			  (error 'type-error :datum object
				 :expected-type result-type)))
	(t (error 'type-error :datum object :expected-type result-type)))))
(defun ensure-type (name expander)
  (let ((cons (assoc name *type-expanders*)))
    (if cons
	(setf (cdr cons) expander)
	(push (cons name expander) *type-expanders*))
    name))
(defmacro deftype (name lambda-list &rest forms)
  `(ensure-type ',name #'(lambda ,lambda-list (block ,name ,@forms))))
(defun *= (cons number)
  (or (not cons) (eq (car cons) '*) (= (car cons) number)))
(defun typep (object type-specifier &optional environment)
  (let ((tag (ldb '(2 . 0) (ival object))))
    (case type-specifier
      ((nil extended-char) nil)
      ((t *) t)
      (null (not object))
      (list (or (not object) (= tag 1)))
      (fixnum (and (= tag 0) (= (ldb '(5 . 0) (ival object)) 16)))
      (package (and (= tag 2) (= (iref object 1) 5)))
      (symbol (or (not object) (and (= tag 2) (= (iref object 1) 0))))
      ((character base-char)
       (and (= tag 0) (= (ldb '(5 . 0) (ival object)) 24)))
      (standard-char (and (= tag 0)
			  (= (ldb '(5 . 0) (ival object)) 24)
			  (let ((code (char-code object)))
			    (or (= code 10)
				(< 31 code 127)))))
      (bit (member object '(0 1)))
      (t (setq type-specifier (designator-list type-specifier))
	 (case (car type-specifier)
	   (cons (and (= tag 1)
		      (or (not (cdr type-specifier))
			  (typep (car object) (cadr type-specifier)))
		      (or (not (cddr type-specifier))
			  (typep (car object) (caddr type-specifier)))))
	   ((string base-string) (and (stringp object)
				      (*= (cdr type-specifier)
					  (length object))))
	   (satisfies (funcall (cadr type-specifier) object))
	   (member (member object (cdr type-specifier)))
	   (not (not (typep object (cadr type-specifier))))
	   (and (every #'(lambda (spec) (typep object spec))
		       (cdr type-specifier)))
	   (or (some #'(lambda (spec) (typep object spec))
		     (cdr type-specifier)))
	   (eql (eql object (cadr type-specifier)))
	   (t (when (= tag 2)
		(let ((class (iref object 1)))
		  (when (= (ldb '(2 . 0) (ival class)) 2)
		    (member (car type-specifier)
			    (mapcar #'class-name
				    (class-precedence-list class))))))))))))
(defun fboundp (function-name)
  (if (consp function-name)
      (iboundp (cadr function-name) 6)
      (iboundp function-name 5)))
(defun fdefinition (function-name)
  (if (consp function-name)
      (if (iboundp (cadr function-name) 6)
	  (iref (cadr function-name) 6)
	  (error 'undefined-error :name function-name))
      (if (iboundp function-name 5)
	  (iref function-name 5)
	  (error 'undefined-error :name function-name))))
(defun function-lambda-expression (function)
  (values (list* 'lambda (iref function 4) (iref function 5))
	  (iref function 3)
	  (iref function 6)))
(defmacro defconstant (name initial-value &optional documentation)
  `(progn
    (setf (iref ',name 4) ,initial-value)
    (setf (iref ',name 8) (dpb 1 '(1 . 4) (iref ',name 8)))
    ',name))
(defmacro defparameter (name initial-value &optional documentation)
  `(progn
    (setf (iref ',name 4) ,initial-value)
    (setf (iref ',name 8) (dpb 1 (cons 1 2) (iref ',name 8)))
    ',name))
(defparameter *type-expanders* nil)
(defconstant call-arguments-limit 65536)
(defconstant lambda-parameters-limit 65536)
(defconstant multiple-values-limit 65536)
(defconstant lambda-list-keywords
  '(&allow-other-keys &aux &body &environment &key &optional &rest &whole))
(defmacro defvar (name &rest rest)
  `(progn
    (unless (or (iboundp ',name 4) ,(not rest))
      (setf (iref ',name 4) ,(car rest)))
    (setf (iref ',name 8) (dpb 1 (cons 1 2) (iref ',name 8)))
    ',name))
(defmacro psetq (&rest rest)
  (let ((inits nil)
	(sets nil)
	(list rest))
    (tagbody
     start
       (when (cddr list)
	 (push (list (gensym) (cadr list)) inits)
	 (setq list (cddr list))
	 (go start)))
    (setq list inits)
    (tagbody
     start
       (when (cddr rest)
	 (push (caar list) sets)
	 (push (car rest) sets)
	 (setq list (cdr list))
	 (setq rest (cddr rest))
	 (go start)))
    `(let ,(reverse inits)
      (setq ,@sets ,@rest))))
(defmacro return (&optional result)
  `(return-from nil ,result))
(defmacro when (test-form &rest forms)
  `(if ,test-form (progn ,@forms)))
(defmacro unless (test-form &rest forms)
  `(if (not ,test-form) (progn ,@forms)))
(defmacro and (&rest forms)
  (if forms
      (if (cdr forms)
	  `(when ,(car forms) (and ,@(cdr forms)))
	(car forms))
    `t))
(defmacro or (&rest forms)
  (if forms
      (if (cdr forms)
	  (let ((temp (gensym)))
	    `(let ((,temp ,(car forms)))
	      (if ,temp
		  ,temp
		(or ,@(cdr forms)))))
	(car forms))
    `nil))
(defmacro cond (&rest clauses)
  (when clauses
    (if (cdar clauses)
	`(if ,(caar clauses)
	     (progn ,@(cdar clauses))
	     (cond ,@(cdr clauses)))
	`(or ,(caar clauses)
	     (cond ,@(cdr clauses))))))
(defmacro case (keyform &rest clauses)
  (let ((temp (gensym)))
    (labels ((recur (clauses)
	       (when clauses
		 (if (member (caar clauses) '(otherwise t))
		     `(progn ,@(cdar clauses))
		     `(if ,(if (listp (caar clauses))
			       `(member ,temp ',(caar clauses))
			       `(eql ,temp ',(caar clauses)))
		          (progn ,@(cdar clauses))
		          ,(recur (cdr clauses)))))))
      `(let ((,temp ,keyform))
	,(recur clauses)))))
(defun type-of (object)
  (case (ldb (cons 2 0) (ival object))
    (0 (if (eq object nil)
	   'null
	   (if (= (ldb (cons 2 3) (ival object)) 2)
	       'fixnum
	       'character)))
    (1 'cons)
    (2 (case (iref object 1)
	 (0 'symbol)
	 (3 'simple-vector)
	 (4 'array)
	 (5 'package)
	 (6 'function)
	 (t (class-name (iref object 1)))))
    (3 (case (jref object 1)
	 (20 'simple-string)
	 (84 'double)
	 (116 'simple-bit-vector)
	 (t 'file-stream)))))
(defmacro ecase (keyform &rest clauses)
  (let ((temp (gensym)))
    `(let ((,temp ,keyform))
      (case ,temp ,@clauses
	    (error 'type-error :datum ,temp
		   :expected-type `(member ,@(mapcan #'(lambda (x)
							 (if (listp (car x))
							     (car x)
							     (list (car x))))
						     clauses)))))))
(defmacro multiple-value-bind (vars values-form &rest forms)
  `(multiple-value-call #'(lambda (&optional ,@vars &rest ,(gensym))
			    ,@forms)
                        ,values-form))
(defmacro multiple-value-list (form)
  `(multiple-value-call #'list ,form))
(defun values-list (list)
  (apply #'values list))
(defmacro nth-value (n form)
  `(nth ,n (multiple-value-list ,form)))
(defmacro prog (inits &rest forms)
  `(block nil
    (let ,inits
      (tagbody ,@forms))))
(defmacro prog* (inits &rest forms)
  `(block nil
    (let* ,inits
      (tagbody ,@forms))))
(defmacro prog1 (first-form &rest forms)
  (let ((temp (gensym)))
    `(let ((,temp ,first-form))
      ,@forms
      ,temp)))
(defmacro prog2 (first-form second-form &rest forms)
  (let ((temp (gensym)))
    `(progn
      ,first-form
      (let ((,temp ,second-form))
	,@forms
	,temp))))
(defun eql (a b)
  (or (eq a b)
      (and (= (ldb '(2 . 0) (ival a)) 3)
	   (= (ldb '(2 . 0) (ival b)) 3)
	   (= (jref a 1) 84)
	   (= (jref b 1) 84)
	   (= a b))))
(defun equal (a b)
  (or (eql a b)
      (cond
	((not a) nil)
	((consp a) (and (consp b)
			(equal (car a) (car b))
			(equal (cdr a) (cdr b))))
	((stringp a) (and (stringp b)
			  (string= a b)))
	((bit-vector-p a) (and (bit-vector-p b)
			       (= (length a) (length b))
			       (dotimes (i (length a) t)
				 (when (/= (aref a i) (aref b i))
				   (return))))))))
(defun equalp (a b)
  (or (eql a b)
      (cond
	((not a) nil)
	((characterp a) (and (characterp b)
			     (char-equal a b)))
	((consp a) (and (consp b)
			(equalp (car a) (car b))
			(equalp (cdr a) (cdr b))))
	((arrayp a) (and (arrayp b)
			 (equal (array-dimensions a) (array-dimensions b))
			 (dotimes (i (apply #'* (array-dimensions a)) t)
			   (unless (equalp (row-major-aref a i)
					   (row-major-aref b i))
			     (return)))))
	((= (ldb '(2 . 0) (ival a)) 2)
	 (and (= (ldb '(2 . 0) (ival b)) 2)
	      (eq (iref a 1) (iref b 1))
	      (= (ldb '(2 . 0) (ival (iref a 1))) 2)
	      (dotimes (i (iref a 0) t)
		(unless (equalp (iref a (+ 2 i)) (iref b (+ 2 i)))
		  (return))))))))
(defun identity (object) object)
(defun complement (function)
  #'(lambda (&rest rest) (not (apply function rest))))
(defun constantly (value) #'(lambda (&rest rest) value))
(defmacro do (vars (end-test-form &rest result-forms) &rest forms)
  (let ((start (gensym))
	(inits nil)
	(steps nil))
  `(block nil
    (let ,(dolist (var vars (reverse inits))
	    (push (if (consp var)
		      (list (car var) (cadr var))
		      (list var)) inits))
      (tagbody
	 ,start
	 (if ,end-test-form (return (progn ,@result-forms)))
	 ,@forms
	 ,@(dolist (var vars (when steps `((psetq ,@(reverse steps)))))
	     (when (and (consp var) (cddr var))
	       (push (car var) steps)
	       (push (caddr var) steps)))
	 (go ,start))))))
(defmacro do* (vars (end-test-form &rest result-forms) &rest forms)
  (let ((start (gensym))
	(inits nil)
	(steps nil))
  `(block nil
    (let* ,(dolist (var vars (reverse inits))
	     (push (if (consp var)
		       (list (car var) (cadr var))
		       (list var)) inits))
      (tagbody
	 ,start
	 (if ,end-test-form (return (progn ,@result-forms)))
	 ,@forms
	 ,@(dolist (var vars (when steps `((setq ,@(reverse steps)))))
	     (when (and (consp var) (cddr var))
	       (push (car var) steps)
	       (push (caddr var) steps)))
	 (go ,start))))))
(defmacro dotimes ((var count-form &optional result-form) &rest forms)
  (let ((start (gensym))
	(count (gensym)))
    `(block nil
      (let ((,var 0)
	    (,count ,count-form))
	(tagbody
	   ,start
	   (when (< ,var ,count)
	     ,@forms
	     (incf ,var)
	     (go ,start)))
	,result-form))))
(defmacro dolist ((var list-form &optional result-form) &rest forms)
  (let ((start (gensym))
	(list (gensym)))
    `(block nil
      (let ((,list ,list-form)
	    (,var nil))
	(tagbody
	   ,start
	   (unless ,list
	     (setf ,var nil)
	     (return-from nil ,result-form))
	   (setf ,var (car ,list))
	   (setf ,list (cdr ,list))
	   ,@forms
	   (go ,start))))))
(defmacro check-type (place typespec &optional string)
  `(tagbody
    start
    (unless (typep ,place ',typespec)
      (restart-case
	  (error 'type-error :datum ,place :expected-type ',typespec)
	(store-value (value)
	  (setf ,place value)))
      (go start))))
(defun designator-condition (default-type datum arguments)
  (if (symbolp datum)
      (apply #'make-condition datum arguments)
      (if (or (stringp datum) (functionp datum))
	  (make-condition default-type
			  :format-control datum
			  :format-arguments arguments)
	  datum)))
(defun error (datum &rest arguments)
  (let ((condition (designator-condition 'simple-error datum arguments)))
    (when (typep condition *break-on-signals*)
      (invoke-debugger condition))
    (invoke-handler condition)
    (invoke-debugger condition)))
(defun cerror (continue-format-control datum &rest arguments)
  `(with-simple-restart (continue continue-format-control)
    (apply #'error datum arguments)))
(defun signal (datum &rest arguments)
  (let ((condition (designator-condition 'simple-condition datum arguments)))
    (when (typep condition *break-on-signals*)
      (invoke-debugger condition))
    (invoke-handler condition)
    nil))
(defun warn (datum &rest arguments)
  (restart-case
      (let ((warning (if (symbolp datum)
			 (apply #'make-condition 'warning datum arguments)
			 datum)))
	(signal warning)
	(print-object warning *error-output*))
    (muffle-warning () nil))
  nil)
(defun show-frame (frame index)
  (let* ((length (fref (- frame 2)))
	 (fn (fref (- frame length 3))))
    (when (and (= (ldb '(2 . 0) (ival fn)) 2) (= (iref fn 1) 6))
      (format *debug-io* "~A: (~A" index (iref fn 6))
      (dotimes (i length)
	(format *debug-io* " ~A" (fref (+ i (- frame length 2)))))
      (format *debug-io* ")~%"))))
(defun next-frame (frame)
  (- frame (fref (- frame 2)) 3))
(defun next-function-frame (frame)
  (do* ((f (next-frame frame) (next-frame f)))
       ((or (< f 6)
	    (let ((fn (fref (- f (fref (- f 2)) 3))))
	      (and (= (ldb '(2 . 0) (ival fn)) 2) (= (iref fn 1) 6))))
	(and (> f 5) f))))
(defun invoke-debugger (condition)
  (let ((debugger-hook *debugger-hook*)
	(*debugger-hook* nil))
    (when debugger-hook
      (funcall debugger-hook condition debugger-hook))
    (format *debug-io* "Entering debugger.~%")
    (princ condition *debug-io*)
    (terpri *debug-io*)
    (let ((restarts (compute-restarts condition))
	  (stack (makef))
	  (frame-depth 0)
	  (active-frame nil))
      (let ((count 0))
	(dolist (restart restarts)
	  (format *debug-io* "~A: " count)
	  (princ restart *debug-io*)
	  (terpri *debug-io*)
	  (incf count)))
      (setq active-frame (next-function-frame (- stack 20)))
      (show-frame active-frame 0)
      (tagbody
       start
	 (format *debug-io* ";~A> " frame-depth)
	 (let ((form (read)))
	   (case form
	     (:help (format *debug-io* "Type :help to get help.~%")
		    (format *debug-io* "Type :continue <index> to invoke the indexed restart.~%"))
	     (:back (do ((frame (next-function-frame (- stack 20))
				(next-function-frame frame))
			 (index 0 (+ 1 index)))
			((not frame))
		      (show-frame frame index)))
	     (:up (if (plusp frame-depth)
		      (progn
			(decf frame-depth)
			(do ((frame (next-function-frame (- stack 20))
				    (next-function-frame frame))
			     (index 0 (+ 1 index)))
			    ((= index frame-depth) (setq active-frame frame)))
			(show-frame active-frame frame-depth))
		      (format *debug-io* "Top of stack.~%")))
	     (:down (let ((frame (next-function-frame active-frame)))
		      (if frame
			  (progn
			    (incf frame-depth)
			    (setq active-frame frame)
			    (show-frame active-frame frame-depth))
			  (format *debug-io* "Bottom of stack.~%"))))
	     (:locals (do ((env (fref (- active-frame 1)) (cdr env)))
			  ((not env))
			(when (symbolp (caar env))
			  (format *debug-io* "~A~%" (caar env)))))
	     (:continue (let ((index (read)))
			  (invoke-restart-interactively (nth index restarts))))
	     (t (let ((values (multiple-value-list
			       (eval form (fref (- active-frame 1)))))
		      (count 0))
		  (if values
		      (dolist (value values)
			(format *debug-io* ";~A: ~S~%" count value)
			(incf count))
		      (format *debug-io* ";No values.~%")))))
	   (go start))))))
(defun break (&optional format-control &rest format-arguments)
  (with-simple-restart (continue "Return from BREAK.")
    (let ((*debugger-hook* nil))
      (invoke-debugger (make-condition 'simple-condition
				       :format-control format-control
				       :format-arguments format-arguments))))
  nil)
(defparameter *debugger-hook* nil)
(defparameter *break-on-signals* nil)
(defparameter *handlers* nil)
(defun invoke-handler (condition)
  (dolist (handler *handlers*)
    (when (typep condition (car handler))
      (setq *handlers* (caddr handler))
      (funcall (cadr handler) condition))))
(defmacro handler-bind (bindings &rest forms)
  (let ((form '*handlers*)
	(handlers (gensym)))
    (dolist (binding (reverse bindings))
      (setq form
	    `(cons (list ',(car binding) ,(cadr binding) ',handlers) ,form)))
    `(let ((handlers *handlers*)
	   (*handlers* ,form))
      ,@forms)))
(defmacro handler-case (expression &rest clauses)
  (let ((tag (gensym))
	(bindings nil))
    `(handler-bind
      ,(dolist (clause clauses (reverse bindings))
	 (let ((typespec (car clause))
	       (var-list (cadr clause))
	       (forms (cddr clauses)))
	   (push `(typespec #'(lambda (,(if var-list (car var-list) (gensym)))
				(return-from tag (progn ,@forms))))
		 bindings)))
      ,expression)))
(defmacro ignore-errors (&rest forms)
  `(handler-case (progn ,@forms)
    (error (condition) (values nil condition))))
(defparameter *restarts* nil)
(defun compute-restarts (&optional condition)
  "FIXME restarts associated with conditions"
  (if condition
      *restarts*
      *restarts*))
(defun find-restart (identifier &optional condition)
  (dolist (restart *restarts*)
    (when (eq restart identifier)
      (return restart))
    (when (eq (restart-name restart) identifier)
      (return restart))))
(defun designator-restart (designator)
  (if (restartp designator)
      designator
      (dolist (restart *restarts* (error 'type-error :datum designator
					 :expected-type 'restart))
	(when (eq (restart-name restart) designator)
	  (return restart)))))
(defun invoke-restart (restart &rest arguments)
  (setq restart (designator-restart restart))
  (apply (restart-function restart) arguments))
(defun invoke-restart-interactively (restart)
  (setq restart (designator-restart restart))
  (apply (restart-function restart)
	 (funcall (restart-interactive-function restart))))
(defmacro restart-bind (restart-bindings &rest forms)
  (let ((form '*restarts*))
    (dolist (binding (reverse restart-bindings))
      (setq form
	    `(cons (make-restart ',(car binding) ,@(cdr binding)) ,form)))
    `(let ((*restarts* ,form))
      ,@forms)))
(defmacro restart-case (restartable-form &rest clauses)
  (let ((catch-tag (gensym))
	(bindings nil))
    `(catch ',catch-tag
      (restart-bind
	  ,(dolist (clause clauses (reverse bindings))
	     (let ((name (car clause))
		   (lambda-list (cadr clause))
		   (rest (cddr clause))
		   (interactive '#'(lambda () nil))
		   (report '#'(lambda (stream)
				(format stream "~A" (car clause))))
		   (test '#'(lambda (condition) t)))
	       (tagbody
		start
		  (when (member (car rest) '(:interactive :report :test))
		    (let ((value (cadr rest)))
		      (case (car rest)
			(:interactive (setq interactive `(function ,value)))
			(:report (setq report
				       (if (stringp value)
					   `#'(lambda (stream)
						(write-string ,value stream))
					   `(function ,value))))
			(:test (setq test `(function ,value)))))
		    (setq rest (cddr rest))
		    (go start)))
	       (push `(,(car clause)
		       #'(lambda ,(cadr clause)
			   (throw ',catch-tag (progn ,@rest)))
		       :interactive-function ,interactive
		       :report-function ,report
		       :test-function ,test)
		     bindings)))
	,restartable-form))))
(defmacro with-simple-restart ((name format-control &rest format-arguments)
			       &rest forms)
  (let ((tag (gensym)))
    `(block ,tag
      (restart-bind
	  ((,name
	    #'(lambda () (return-from ,tag (values nil t)))
	     :interactive-function #'(lambda () nil)
	     :report-function #'(lambda (stream)
				  (apply #'format stream ',format-control
					 ',format-arguments))
	     :test-function #'(lambda () t)))
	,@forms))))
(defun abort (&optional condition)
  (invoke-restart (find-restart 'abort condition))
  (error 'control-error))
(defun continue (&optional condition)
  (invoke-restart (find-restart 'continue condition)))
(defun muffle-warning (&optional condition)
  (invoke-restart (find-restart 'muffle-warning condition))
  (error 'control-error))
(defun store-value (value &optional condition)
  (invoke-restart (find-restart 'store-value condition) value))
(defun use-value (value &optional condition)
  (invoke-restart (find-restart 'use-value condition) value))
(defun integer-string (integer &optional (radix 10))
  (if (= integer 0)
      "0"
      (labels ((recur (i l)
		 (if (= i 0)
		     l
		     (multiple-value-bind (ni r)
			 (floor i radix)
		       (recur ni (cons (code-char (+ (if (< r 10) 48 55) r))
				       l))))))
	(apply #'string (if (< 0 integer)
			    (recur integer nil)
			    (cons (code-char 45) (recur (- integer) nil)))))))
(defun designator-symbol (designator)
  (if (symbolp designator)
      designator
      (find-symbol designator)))
(defun symbolp (object) (or (null object) (eq (type-of object) 'symbol)))
(defun keywordp (object)
  (and (symbolp object)
       (string= (package-name (symbol-package object)) "KEYwORD")))
(defun make-symbol (name)
  (let ((symbol (makei 9 0 name nil nil nil nil (- 1) 0)))
    (imakunbound symbol 4)
    (imakunbound symbol 5)
    (imakunbound symbol 6)
    symbol))
(defun copy-symbol (symbol &optional copy-properties)
  (let ((new-symbol (make-symbol (iref symbol 2))))
    (cond
      (copy-properties
       (setf (iref new-symbol 4) (iref symbol 4))
       (setf (iref new-symbol 5) (iref symbol 5))
       (setf (iref new-symbol 6) (iref symbol 6))
       (setf (iref new-symbol 10) (iref symbol 10)))
      (t
       (imakunbound new-symbol 4)
       (imakunbound new-symbol 5)
       (imakunbound new-symbol 6)))
    new-symbol))
(defun fixnump (object)
  (= (ldb '(5 . 0) (ival object)) 16))
(defvar *gensym-counter* 0)
(defun gen-sym (&optional x)
  (let ((prefix (if (stringp x) x "G"))
	(suffix (if (fixnump x)
		    x
		    (let ((x *gensym-counter*))
		      (setf *gensym-counter* (+ 1 *gensym-counter*))))))
    (make-symbol (conc-string prefix (integer-string suffix)))))
(let ((gentemp-counter 0))
  (defun gentemp (&optional (prefix "T") (package *package*))
    (setf gentemp-counter (+ 1 gentemp-counter))
    (intern (conc-string prefix (integer-string gentemp-counter))
	    package)))
(defun symbol-function (symbol)
  (if (iboundp symbol 5)
      (iref symbol 5)
      (error 'undefined-function :name symbol)))
(defun (setf symbol-function) (new-contents symbol)
  (setf (iref symbol 5) new-contents))
(defun symbol-name (symbol) (iref symbol 2))
(defun symbol-package (symbol) (iref symbol 9))
(defun symbol-plist (symbol) (iref symbol 10))
(defun (setf symbol-plist) (new-plist symbol)
  (setf (iref symbol 10) new-plist))
(defun symbol-value (symbol)
  (if (iboundp symbol 4)
      (iref symbol 4)
      (error 'unbound-variable :name symbol)))
(defun (setf symbol-value) (new-value symbol) (setf (iref symbol 4) new-value))
(defun get (symbol indicator &optional default)
  (getf (symbol-plist symbol) indicator default))
(defun (setf get) (new-value symbol indicator &optional default)
  (setf (getf (symbol-plist symbol) indicator default) new-value))
(defun remprop (symbol indicator) (remf (symbol-plist symbol) indicator))
(defun boundp (symbol) (iboundp symbol 4))
(defun makunbound (symbol) (imakunbound symbol 4))
(defun set (symbol value) (setf (symbol-value symbol) value))
(defun designator-string (designator)
  (if (stringp designator)
      designator
      (if (characterp designator)
	  (string designator)
	  (symbol-name designator))))
(defvar *package* (car (cdr *packages*)))
(defun find-package (name)
  (if (packagep name)
      name
      (let ((string (designator-string name)))
	(dolist (package *packages*)
	  (dolist (package-name (iref package 2))
	    (when (string= package-name string)
	      (return-from find-package package)))))))
(defun export (symbols &optional (package *package*))
  (setq package (find-package package))
  (dolist (symbol (designator-list symbols))
    (setf symbol (designator-symbol symbol))
    (dolist (using-package (iref package 7))
      (when (find-symbol (symbol-name symbol) using-package)
	(cerror 'package-error :package using-package)))
    (unless (atom (package-get (iref package 3) (symbol-name symbol)))
      (unless (atom (package-get (iref package 4) (symbol-name symbol)))
	(cerror 'package-error :package package))
      (package-rem (iref package 4) symbol)
      (package-put (iref package 3) symbol))))
(defun package-rehash (old-vector new-vector)
  (let ((old-length (length old-vector))
	(new-length (length new-vector))
	(i 0))
    (tagbody
     start
       (when (< i old-length)
	 (dolist (symbol (iref old-vector (+ 2 i)))
	   (push symbol (iref new-vector (+ 2 (mod (hash (symbol-name symbol))
						   new-length)))))
	 (incf i)
	 (go start)))
    new-vector))
(defun package-get (vector string)
  (dolist (symbol (iref vector (+ 2 (mod (hash string) (length vector))))
	   '(nil))
    (when (string= (symbol-name symbol) string)
      (return symbol))))
(defun package-put (vector symbol)
  (push symbol (iref vector (+ 2 (mod (hash (symbol-name symbol))
				      (length vector))))))
(defun package-rem (vector string)
  (let ((index (+ 2 (mod (hash string) (length vector)))))
    (setf (iref vector index)
	  (delete string (iref vector index) :key #'symbol-name))))
(defun find-symbol (string &optional (package *package*))
  (setq package (find-package package))
  (unless package
    (error "Package does not exist."))
  (if (and (string= "NIL" string) (eq (find-package "CL") package))
      (values nil :external)
      (let ((symbol (package-get (iref package 4) string)))
	(if (atom symbol)
	    (values symbol :internal)
	    (let ((symbol (package-get (iref package 3) string)))
	      (if (atom symbol)
		  (values symbol :external)
		(dolist (used-package (package-use-list package)
				      (values nil nil))
		  (let ((symbol (package-get (iref used-package 3) string)))
		    (when (atom symbol)
		      (values symbol :inherited))))))))))
(defun find-all-symbols (string)
  (let ((symbols nil))
    (dolist (package *packages*)
      (let ((symbol (package-get (iref package 4) string)))
	(when (atom symbol)
	  (push symbol symbols)))
      (let ((symbol (package-get (iref package 3) string)))
	(when (atom symbol)
	  (push symbol symbols))))
    symbols))
(defun import (symbols &optional (package *package*))
  (setq package (find-package package))
  (dolist (symbol (designator-list symbols))
    (multiple-value-bind (symbol status)
	(find-symbol (symbol-name symbol) package)
      (case status
	(:inherited
	 (cerror 'package-error :package package))
	((nil)
	 (package-put (iref package 4) symbol)
	 (unless (iref symbol 9)
	   (setf (iref symbol 9) package))))))
  t)
(defun list-all-packages ()
  (copy-list *packages*))
(defun rename-package (package new-name &optional new-nicknames)
  (setq package (find-package package))
  (when (packagep new-name) (setq new-name (package-name new-name)))
  (setf new-nicknames (mapcar #'designator-string new-nicknames))
  (setf (iref package 2) (cons new-name new-nicknames))
  package)
(defun shadow (symbol-names &optional (package *package*))
  (setq package (find-package package))
  (dolist (symbol-name symbol-names)
    (multiple-value-bind (symbol status)
	(find-symbol symbol-name package)
      (unless (member status '(:internal :external))
	(setq symbol (make-symbol string))
	(setf (iref symbol 9) package)
	(package-put (iref package 4) symbol))
      (pushnew symbol (iref package 5))))
  t)
(defun shadowing-import (symbols &optional package)
  (setq package (find-package package))
  (dolist (symbol (designator-list symbols))
    (package-rem (iref package 3) (symbol-name symbol))
    (package-rem (iref package 4) (symbol-name symbol))
    (package-put (iref package 4) symbol)
    (push symbol (iref package 5)))
  t)
(defun delete-package (package)
  (setq package (find-package package))
  (when (iref package 7)
    (cerror 'package-error package))
  (prog1
      (package-name package)
    (setf (iref package 2) nil)))
(defun make-package (package-name &key nicknames (use '("cl")))
  (let ((all-names (cons package-name nicknames)))
    (mapc #'(lambda (name)
	      (when (find-package name)
		(cerror 'package-error :package name)))
	  all-names)
    (let ((package (makei 6 5 all-names (make-array 1021) (make-array 1021) nil
			  (mapcar #'find-package use))))
      (mapc #'(lambda (used-package)
		(push package (iref (find-package used-package) 7)))
	    use)
      (push package *packages*)
      package)))
(defun make-package-iterator (package symbol-types)
  (setq package (find-package package))
  (list nil package symbol-types))
(defun package-iterate (iterator)
  (unless (first iterator)
    (setf (first iterator)
	  (case (pop (third iterator))
	    (:internal (iref (second iterator) 4))
	    (:external (iref (second iterator) 3))
	    (:inherited "FIXME")
	    ((nil) (return-from package-iterate nil)))))
  (pop (first iterator)))
(defmacro with-package-iterator ((name package-list-form &rest symbol-types)
				 &rest forms)
  (let ((package (gensym))
	(iterator (gensym)))
    `(dolist (,package (designator-list ,package-list-form))
      (let ((,iterator (make-package-iterator ,package ',symbol-types)))
	(macrolet ((,name () (package-iterate ,iterator)))
	  ,@forms)))))
(defun unexport (symbols &optional (package *package*))
  (setq package (find-package package))
  (dolist (symbol (designator-list symbols))
    (setq symbol (designator-symbol symbol))
    (when symbol
      (when (atom (package-get (iref package 3) (symbol-name symbol)))
	(package-rem (iref package 3) (symbol-name symbol))
	(package-put (iref package 4) symbol))))
  t)
(defun unintern (symbol &optional (package *package*))
  (setq package (find-package package))
  (when (eq package (iref symbol 9))
    (setf (iref symbol 9) nil))
  (let* ((name (symbol-name symbol))
	 (present (or (atom (package-get (iref package 3) name))
		      (atom (package-get (iref package 4) name)))))
    (package-rem (iref package 3) name)
    (package-rem (iref package 4) name)
    (setf (iref package 5) (delete symbol (iref package 5)))
    present))
(defmacro in-package (name)
  `(setf *package* (find-package ',name)))
(defun unuse-package (packages-to-unuse &optional (package *package*))
  (setq package (find-package package))
  (dolist (package-to-unuse (designator-list packages-to-unuse))
    (setq package-to-unuse (find-package package-to-unuse))
    (setf (iref package 6) (delete package-to-unuse (iref package 6)))
    (setf (iref package-to-unuse 7)
	  (delete package (iref package-to-unuse 7))))
  t)
(defun use-package (packages-to-use &optional (package *package*))
  (setq package (find-package package))
  (dolist (package-to-use (designator-list packages-to-use))
    (setq package-to-use (find-package package-to-use))
    (push package-to-use (iref package 6))
    (push package (iref package-to-use 7)))
  t)
(defun ensure-package (name nicknames shadow shadowing-import-from use
		       import-from intern export)
  (let ((package (find-package name)))
    (unless package
      (setq package (make-package name :nicknames nicknames)))
    (shadow shadow package)
    (mapc #'(lambda (list)
	      (let ((imported-package (find-package (car list)))
		    (symbol-names (cdr list)))
		(shadowing-import (mapcar #'(lambda (symbol-name)
					      (find-symbol symbol-name
							   imported-package))
					  symbol-names)
				  package)))
	  shadowing-import-from)
    (use-package use package)
    (mapc #'(lambda (list)
	      (let ((imported-package (find-package (car list)))
		    (symbol-names (cdr list)))
		(import (mapcar #'(lambda (symbol-name)
				    (find-symbol symbol-name imported-package))
				symbol-names)
			package)))
	  import-from)
    (mapc #'(lambda (symbol-name) (intern symbol-name package)) intern)
    (export export package)
    package))
(defmacro defpackage (defined-package-name &rest options)
  (flet ((option (option-name)
	   (mapcan #'(lambda (option)
		       (when (eq (car option) option-name)
			 (mapcar #'designator-string (cdr option))))
		   options))
	 (options (option-name)
	   (mapcan #'(lambda (option)
		       (when (eq (car option) option-name)
			 (list (mapcar #'designator-string (cdr option)))))
		   options)))
    `(ensure-package ,(designator-string defined-package-name)
      ,(option :nicknames)
      ,(option :shadow) ,(options :shadowing-import-from) ,(option :use)
      ,(options :import-from) ,(option :intern) ,(option :export))))
(defmacro do-symbols ((var &optional (package *package*) result-form)
		      &rest forms)
  (let ((package-sym (gensym)))
    `(block nil
      (let ((,package-sym (find-package package))
	    (,var nil))
	(dolist (,var (iref ,package-sym 3))
	  ,@forms)
	(dolist (,var (iref ,pakcage-sym 4))
	  ,@forms)
	,result-form))))
(defmacro do-external-symbols ((var &optional (package *package*) result-form)
			       &rest forms)
  (let ((package-sym (gensym)))
    `(let ((,package-sym (find-package ,package)))
      (dolist (,var (iref ,package-sym 3) ,result-form)
	,@forms))))
(defmacro do-all-symbols ((var &optional result-form) &rest forms)
  (let ((package (gensym))
	(symbols (gensym))
	(first (gensym))
	(start-out (gensym))
	(start (gensym)))
    `(let ((,symbols nil)
	   (,first t))
      (dolist (,package *packages* ,result-form)
	,start-out
	(setq ,symbols (iref ,package (if ,first 3 4)))
	(setq ,first (not ,first))
	,start
	(when ,symbols
	  ,@forms
	  (go ,start))
	(when ,first
	  (go ,start-out))))))
(defun intern (string &optional (package *package*))
  (setq package (find-package package))
  (multiple-value-bind (symbol status)
      (find-symbol string package)
    (unless status
      (setq symbol (make-symbol string))
      (setf (iref symbol 9) package)
      (cond
	((string= (package-name package) "KEYWORD")
	 (package-put (iref package 3) symbol)
	 (setf (symbol-value symbol) symbol))
	(t
	 (package-put (iref package 4) symbol))))
    (values symbol status)))
(defun package-name (package) (car (iref (find-package package) 2)))
(defun package-nicknames (package) (cdr (iref (find-package package) 2)))
(defun package-shadowing-symbols (package) (iref (find-package package) 5))
(defun package-use-list (package) (iref (find-package package) 6))
(defun package-used-by-list (package) (iref (find-package package) 7))
(defun packagep (object) (eq (type-of object) 'package))
(defun /= (number &rest numbers)
  (tagbody
   start
     (when numbers
       (dolist (n numbers)
	 (when (= number n)
	   (return-from /=)))
       (setq number (pop numbers))
       (go start)))
  t)
(defun > (&rest numbers)
  (apply #'< (reverse numbers)))
(defun <= (number &rest numbers)
  (dolist (n numbers t)
    (when (< n number)
      (return-from <=))
    (setq number n)))
(defun >= (number &rest numbers)
  (dolist (n numbers t)
    (when (< number n)
      (return-from >=))
    (setq number n)))
(defun max (real &rest reals)
  (dolist (r reals real)
    (when (< real r)
      (setq real r))))
(defun min (real &rest reals)
  (dolist (r reals real)
    (when (< r real)
      (setq real r))))
(defun oddp (integer)
  (= (mod integer 2) 1))
(defun evenp (integer)
  (= (mod integer 2) 0))
(defun minusp (real)
  (< real 0))
(defun plusp (real)
  (< 0 real))
(defun zerop (real)
  (= real 0))
(defun abs (number)
  (if (< number 0)
      (- number)
      number))
(defmacro incf (place &optional (delta-form 1))
  `(setf ,place (+ ,place ,delta-form)))
(defmacro decf (place &optional (delta-form 1))
  `(setf ,place (- ,place ,delta-form)))
(defun byte (size position)
  (cons size position))
(defun byte-size (bytespec)
  (car bytespec))
(defun byte-position (bytespec)
  (cdr bytespec))
(defun char= (&rest characters)
  (apply #'= (mapcar #'char-code characters)))
(defun char/= (&rest characters)
  (apply #'/= (mapcar #'char-code characters)))
(defun char< (&rest characters)
  (apply #'< (mapcar #'char-code characters)))
(defun char> (&rest characters)
  (apply #'> (mapcar #'char-code characters)))
(defun char<= (&rest characters)
  (apply #'<= (mapcar #'char-code characters)))
(defun char>= (&rest characters)
  (apply #'>= (mapcar #'char-code characters)))
(defun char-equal (&rest characters)
  (apply #'char= (mapcar #'char-upcase characters)))
(defun char-not-equal (&rest characters)
  (apply #'char/= (mapcar #'char-upcase characters)))
(defun char-lessp (&rest characters)
  (apply #'char< (mapcar #'char-upcase characters)))
(defun char-greaterp (&rest characters)
  (apply #'char> (mapcar #'char-upcase characters)))
(defun char-not-greaterp (&rest characters)
  (apply #'char<= (mapcar #'char-upcase characters)))
(defun char-not-lessp (&rest characters)
  (apply #'char>= (mapcar #'char-upcase characters)))
(defun character (character)
  (if (characterp character)
      character
      (let ((string (designator-string character)))
	(if (= (length string) 1)
	    (aref string 0)
	    (error 'type-error :datum string :expected-type '(string 1))))))
(defun characterp (object) (= (ldb '(5 . 0) (ival object)) 24))
(defun alpha-char-p (character)
  (let ((code (char-code character)))
    (or (< 64 code 91)
	(< 96 code 123)
	(< 159 code))))
(defun alphanumericp (character)
  (let ((code (char-code character)))
    (or (< 47 code 58)
	(< 64 code 91)
	(< 96 code 123)
	(< 159 code))))
(defun digit-char (weight &optional (radix 10))
  (when (< weight radix)
    (if (< weight 10)
	(code-char (+ 48 weight))
	(code-char (+ 55 weight)))))
(defun digit-char-p (char &optional (radix 10))
  (let* ((code (char-code char))
	 (weight (if (< 47 code 58)
		     (- code 48)
		     (if (< 64 code 91)
			 (- code 55)
			 (when (< 96 code 123)
			   (- code 87))))))
    (and weight (< weight radix) weight)))
(defun standard-char-p (character)
  (let ((code (char-code character)))
    (or (= code 10)
	(< 31 code 127))))
(defun char-upcase (character)
  (let ((code (char-code character)))
    (if (< 96 code 123)
	(code-char (- code 32))
	character)))
(defun char-downcase (character)
  (let ((code (char-code character)))
    (if (< 64 code 91)
	(code-char (+ code 32))
	character)))
(defun upper-case-p (character)
  (< 64 (char-code character) 91))
(defun lower-case-p (character)
  (< 96 (char-code character) 123))
(defun both-case-p (character)
  (or (upper-case-p character) (lower-case-p character)))
(defun char-int (character)
  (char-code character))
(defconstant char-code-limit 256)
(let ((char-names '((0 . "Null")
		    (8 . "Backspace")
		    (9 . "Tab")
		    (10 . "Newline")
		    (12 . "Page")
		    (13 . "Return")
		    (32 . "Space")
		    (127 . "Rubout"))))
  (defun char-name (character)
    (let* ((code (char-code character))
	   (name (cdr (assoc code char-names))))
      (or name (when (< code 32)
		 (conc-string "U+" (integer-string code))))))
  (defun name-char (name)
    (setq name (designator-string name))
    (if (< (length name) 2)
	(aref name 0)
	(if (= (char-code (aref name 0)) 85)
	    (code-char (parse-integer name :start 2))
	    (let ((code (car (rassoc name char-names :test #'string-equal))))
	      (when code (code-char code)))))))
(defun atom (object) (not (consp object)))
(defun rplaca (cons object) (setf (car cons) object) cons)
(defun rplacd (cons object) (setf (cdr cons) object) cons)
(defun caar (x) (car (car x)))
(defun (setf caar) (new-object x) (setf (car (car x)) new-object))
(defun cadr (x) (car (cdr x)))
(defun (setf cadr) (new-object x) (setf (car (cdr x)) new-object))
(defun cdar (x) (cdr (car x)))
(defun (setf cdar) (new-object x) (setf (cdr (car x)) new-object))
(defun cddr (x) (cdr (cdr x)))
(defun (setf cddr) (new-object x) (setf (cdr (cdr x)) new-object))
(defun caaar (x) (car (car (car x))))
(defun (setf caaar) (new-object x) (setf (car (caar x)) new-object))
(defun caadr (x) (car (car (cdr x))))
(defun (setf caadr) (new-object x) (setf (car (cadr x)) new-object))
(defun cadar (x) (car (cdr (car x))))
(defun (setf cadar) (new-object x) (setf (car (cdar x)) new-object))
(defun caddr (x) (car (cdr (cdr x))))
(defun (setf caddr) (new-object x) (setf (car (cddr x)) new-object))
(defun cdaar (x) (cdr (car (car x))))
(defun (setf cdaar) (new-object x) (setf (cdr (caar x)) new-object))
(defun cdadr (x) (cdr (car (cdr x))))
(defun (setf cdadr) (new-object x) (setf (cdr (cadr x)) new-object))
(defun cddar (x) (cdr (cdr (car x))))
(defun (setf cddar) (new-object x) (setf (cdr (cdar x)) new-object))
(defun cdddr (x) (cdr (cdr (cdr x))))
(defun (setf cdddr) (new-object x) (setf (cdr (cddr x)) new-object))
(defun caaaar (x) (car (car (car (car x)))))
(defun (setf caaaar) (new-object x) (setf (car (caaar x)) new-object))
(defun caaadr (x) (car (car (car (cdr x)))))
(defun (setf caaadr) (new-object x) (setf (car (caadr x)) new-object))
(defun caadar (x) (car (car (cdr (car x)))))
(defun (setf caadar) (new-object x) (setf (car (cadar x)) new-object))
(defun caaddr (x) (car (car (cdr (cdr x)))))
(defun (setf caaddr) (new-object x) (setf (car (caddr x)) new-object))
(defun cadaar (x) (car (cdr (car (car x)))))
(defun (setf cadaar) (new-object x) (setf (car (cdaar x)) new-object))
(defun cadadr (x) (car (cdr (car (cdr x)))))
(defun (setf cadadr) (new-object x) (setf (car (cdadr x)) new-object))
(defun caddar (x) (car (cdr (cdr (car x)))))
(defun (setf caddar) (new-object x) (setf (car (cddar x)) new-object))
(defun cadddr (x) (car (cdr (cdr (cdr x)))))
(defun (setf cadddr) (new-object x) (setf (car (cdddr x)) new-object))
(defun cdaaar (x) (cdr (car (car (car x)))))
(defun (setf cdaaar) (new-object x) (setf (cdr (caaar x)) new-object))
(defun cdaadr (x) (cdr (car (car (cdr x)))))
(defun (setf cdaadr) (new-object x) (setf (cdr (caadr x)) new-object))
(defun cdadar (x) (cdr (car (cdr (car x)))))
(defun (setf cdadar) (new-object x) (setf (cdr (cadar x)) new-object))
(defun cdaddr (x) (cdr (car (cdr (cdr x)))))
(defun (setf cdaddr) (new-object x) (setf (cdr (caddr x)) new-object))
(defun cddaar (x) (cdr (cdr (car (car x)))))
(defun (setf cddaar) (new-object x) (setf (cdr (cdaar x)) new-object))
(defun cddadr (x) (cdr (cdr (car (cdr x)))))
(defun (setf cddadr) (new-object x) (setf (cdr (cdadr x)) new-object))
(defun cdddar (x) (cdr (cdr (cdr (car x)))))
(defun (setf cdddar) (new-object x) (setf (cdr (cddar x)) new-object))
(defun cddddr (x) (cdr (cdr (cdr (cdr x)))))
(defun (setf cddddr) (new-object x) (setf (cdr (cdddr x)) new-object))
(defun copy-tree (tree)
  (if (consp tree) (cons (copy-tree (car tree)) (copy-tree (cdr tree))) tree))
(defun sublis (alist tree &rest rest)
  (if (consp tree)
      (let ((a (apply #'sublis alist (car tree) rest))
	    (d (apply #'sublis alist (cdr tree) rest)))
	(if (and (eq a (car tree)) (eq d (cdr tree)))
	    tree
	    (cons a d)))
      (let ((a (apply #'assoc tree alist rest)))
	(if a (cdr a) tree))))
(defun nsublis (alist tree &rest rest)
  (if (consp tree)
      (progn
	(setf (car tree) (apply #'nsublis alist (car tree) rest))
	(setf (cdr tree) (apply #'nsublis alist (cdr tree) rest))
	tree)
      (let ((a (apply #'assoc tree alist rest)))
	(if a (cdr a) tree))))
(defun copy-list (list)
  (if (consp list) (cons (car list) (copy-list (cdr list))) list))
(defun make-list (size &key initial-element)
  (if (= size 0) nil
      (cons initial-element
	    (make-list (- size 1) :initial-element initial-element))))
(defun list* (&rest objects)
  (if (cdr objects)
      (cons (car objects) (apply #'list* (cdr objects)))
      (car objects)))
(defun list-length (list)
  (let ((slow list)
	(fast list)
	(odd nil)
	(len 0))
    (tagbody
     start
       (when (atom fast) (return-from list-length len))
       (setf fast (cdr fast))
       (setf len (+ 1 len))
       (when odd (setf slow (cdr slow)))
       (setf odd (not odd))
       (unless (eq slow fast) (go start)))))
(defun listp (object) (or (consp object) (eq object nil)))
(defmacro push (item place)
  `(setf ,place (cons ,item ,place)))
(defmacro pop (place)
  `(prog1 (car ,place) (setf ,place (cdr ,place))))
(defun first (list) (car list))
(defun (setf first) (new-object list) (setf (car list) new-object))
(defun second (list) (nth 1 list))
(defun (setf second) (new-object list) (setf (nth 1 list) new-object))
(defun third (list) (nth 2 list))
(defun (setf third) (new-object list) (setf (nth 2 list) new-object))
(defun fourth (list) (nth 3 list))
(defun (setf fourth) (new-object list) (setf (nth 3 list) new-object))
(defun fifth (list) (nth 4 list))
(defun (setf fifth) (new-object list) (setf (nth 4 list) new-object))
(defun sixth (list) (nth 5 list))
(defun (setf sixth) (new-object list) (setf (nth 5 list) new-object))
(defun seventh (list) (nth 6 list))
(defun (setf seventh) (new-object list) (setf (nth 6 list) new-object))
(defun eighth (list) (nth 7 list))
(defun (setf eighth) (new-object list) (setf (nth 7 list) new-object))
(defun ninth (list) (nth 8 list))
(defun (setf ninth) (new-object list) (setf (nth 8 list) new-object))
(defun tenth (list) (nth 9 list))
(defun (setf tenth) (new-object list) (setf (nth 9 list) new-object))
(defun nth (n list) (if (< n 1) (car list) (nth (- n 1) (cdr list))))
(defun (setf nth) (new-object n list)
  (if (< n 1)
      (setf (car list) new-object)
      (setf (nth (- n 1) (cdr list)) new-object)))
(defun endp (list) (not list))
(defun nconc (&rest lists)
  (if (cdr lists)
      (if (car lists)
	  (progn (setf (cdr (last (car lists))) (apply #'nconc (cdr lists)))
		 (car lists))
	  (apply #'nconc (cdr lists)))
      (car lists)))
(defun revappend (list tail)
  (if list
      (revappend (cdr list) (cons (car list) tail))
      tail))
(defun nreconc (list tail)
  (if list
      (let ((new-list (cdr list)))
	(setf (cdr list) tail)
	(nreconc new-list list))
      tail))
(defun butlast (list &optional (n 1))
  (let* ((r (cons nil nil))
	 (e list)
	 (m 0))
    (tagbody
     start
       (when (consp e)
	 (setf m (+ m 1))
	 (setf e (cdr e))
	 (go start)))
    (setf n (- m n))
    (setf e r)
    (tagbody
     start
       (unless (consp list) (return-from butlast nil))
       (unless (< n 1)
	 (setf e (setf (cdr e) (cons (car list) nil)))
	 (setf list (cdr list))
	 (setf n (- n 1))
	 (go start)))
    (cdr r)))
(defun nbutlast (list &optional (n 1))
  (let* ((e list)
	 (m 0))
    (tagbody
     start
       (when (consp e)
	 (setf m (+ m 1))
	 (setf e (cdr e))
	 (go start)))
    (setf n (- m n))
    (setf e list)
    (tagbody
     start
       (unless (consp list) (return-from nbutlast nil))
       (unless (< n 2)
	 (setf e (cdr e))
	 (setf n (- n 1))
	 (go start)))
    (setf (cdr e) nil)
    list))
(defun last (list &optional (n 1))
  (let* ((e list)
	 (m 0))
    (tagbody
     start
       (when (consp e)
	 (setf m (+ m 1))
	 (setf e (cdr e))
	 (go start)))
    (setf n (- m n))
    (setf e list)
    (tagbody
     start
       (when (< n 1) (return-from last e))
       (setf e (cdr e))
       (setf n (- n 1))
       (go start))))
(defun ldiff (list object)
  (let* ((r (cons nil nil))
	 (e r))
    (tagbody
     start
       (unless (or (eq object list) (atom list))
	 (setf e (setf (cdr e) (cons (car list) nil)))
	 (setf list (cdr list))
	 (go start)))
    (cdr r)))
(defun tailp (object list)
  (tagbody
   start
     (when (eq object list) (return-from tailp t))
     (unless (consp list) (return-from tailp nil))
     (setf list (cdr list))
     (go start)))
(defun nthcdr (n list) (if (< n 1) list (nthcdr (- n 1) (cdr list))))
(defun rest (list) (cdr list))
(defun (setf rest) (new-tail list) (setf (cdr list) new-tail))
(labels ((all-end (lists)
	   (dolist (elem lists nil)
	     (unless elem (return-from all-end t))))
	 (all-car (lists)
	   (when lists (cons (caar lists) (all-car (cdr lists)))))
	 (all-cdr (lists)
	   (when lists (cons (cdar lists) (all-cdr (cdr lists))))))
  (defun mapc (function &rest lists)
    (let ((list-1 (car lists)))
      (tagbody
       start
	 (when (all-end lists) (return-from mapc list-1))
	 (apply function (all-car lists))
	 (setf lists (all-cdr lists))
	 (go start))))
  (defun mapcar (function &rest lists)
    (let ((result nil)
	  (end nil))
      (tagbody
       start
	 (when (all-end lists) (return-from mapcar result))
	 (let ((cons (cons (apply function (all-car lists)) nil)))
	   (setf end (if end (setf (cdr end) cons) (setf result cons))))
	 (setf lists (all-cdr lists))
	 (go start))))
  (defun mapl (function &rest lists)
    (let ((list-1 (car lists)))
      (tagbody
       start
	 (when (all-end lists) (return-from mapl list-1))
	 (apply function lists)
	 (setf lists (all-cdr lists))
	 (go start))))
  (defun maplist (function &rest lists)
    (let ((result nil)
	  (end nil))
      (tagbody
       start
	 (when (all-end lists) (return-from maplist result))
	 (let ((cons (cons (apply function lists) nil)))
	   (setf end (if end (setf (cdr end) cons) (setf result cons))))
	 (setf lists (all-cdr lists))
	 (go start)))))
(defun mapcan (function &rest lists)
  (apply #'nconc (apply #'mapcar function lists)))
(defun mapcon (function &rest lists)
  (apply #'nconc (apply #'maplist function lists)))
(defun acons (key datum alist) (cons (cons key datum) alist))
(defun copy-alist (alist)
  (when alist (cons (if (consp (car alist))
			(cons (caar alist) (cdar alist))
			(car alist))
		    (copy-alist (cdr alist)))))
(defun pairlis (keys data &optional alist)
  (tagbody
   start
     (when (and keys data)
       (setf alist (acons (car keys) (car data) alist))
       (setf keys (cdr keys))
       (setf data (cdr data))
       (go start)))
  alist)
(defun some-list-2 (predicate list1 list2)
  (tagbody
   start
     (when (and list1 list2)
       (when (funcall predicate (car list1) (car list2))
	 (return-from some-list-2 t))
       (pop list1)
       (pop list2)
       (go start))))
(flet ((satisfies (object elem &key key test test-not)
	 (let* ((zi (if key (funcall key elem) elem))
		(r (funcall (or test test-not #'eql) object zi)))
	   (if test-not (not r) r)))
       (satisfies-if (predicate elem &key key)
	 (funcall predicate (if key (funcall key elem) elem)))
       (satisfies-if-not (predicate elem &key key)
	 (not (funcall predicate (if key (funcall key elem) elem))))
       (seq-start (sequence &key (start 0) end from-end)
	 (if (listp sequence)
	     (if from-end
		 (let ((acc nil)
		       (sequence (nthcdr start sequence)))
		   (tagbody
		    start
		      (when (and sequence (or (not end) (< start end)))
			(push sequence acc)
			(setf sequence (cdr sequence))
			(setf start (+ 1 start))
			(go start)))
		   (list 3 acc start))
		 (list 2 (nthcdr start sequence) start))
	     (if from-end (cons 1 (- end 1)) (cons 0 start))))
       (seq-position (iter)
	 (case (car iter)
	   ((0 1) (cdr iter))
	   (t (caddr iter))))
       (seq-next (iter)
	 (case (car iter)
	   (0 (setf (cdr iter) (+ 1 (cdr iter))))
	   (1 (setf (cdr iter) (- (cdr iter) 1)))
	   (2 (setf (cadr iter) (cdadr iter))
	      (setf (caddr iter) (+ 1 (caddr iter))))
	   (t (setf (cadr iter) (cdadr iter))
	      (setf (caddr iter) (- (caddr iter) 1)))))
       (seq-ref (sequence iter)
	 (case (car iter)
	   ((0 1) (aref sequence (cdr iter)))
	   (2 (caadr iter))
	   (t (caaadr iter))))
       (seq-set (sequence iter value)
	 (case (car iter)
	   ((0 1) (setf (aref sequence (cdr iter)) value))
	   (2 (setf (caadr iter) value))
	   (t (setf (caaadr iter) value))))
       (seq-end-p (sequence iter &key start end from-end)
	 (case (car iter)
	   (0 (or (= (cdr iter) (length sequence))
		  (and end (= end (cdr iter)))))
	   (1 (< (cdr iter) start))
	   (2 (or (null (cadr iter)) (and end (= end (caddr iter)))))
	   (t (or (null (cadr iter)) (< (caddr iter) start)))))
       (seq-result (sequence iter result)
	 (case (car iter)
	   (0 (make-array (length result)
			  :element-type (array-element-type sequence)
			  :initial-contents (reverse result)))
	   (1 (make-array (length result)
			  :element-type (array-element-type sequence)
			  :initial-contents result))
	   (2 (reverse result))
	   (3 result))))
  (defun member (item list &rest rest)
    (tagbody
       start
       (when list
	 (when (apply #'satisfies item (car list) rest)
	   (return-from member list))
	 (setf list (cdr list))
	 (go start))))
  (defun member-if (predicate list &rest rest)
    (tagbody
       start
       (when list
	 (when (apply #'satisfies-if predicate (car list) rest)
	   (return-from member-if list))
	 (setf list (cdr list))
	 (go start))))
  (defun member-if-not (predicate list &rest rest)
    (tagbody
       start
       (when list
	 (when (apply #'satisfies-if-not predicate (car list) rest)
	   (return-from member-if list))
	 (setf list (cdr list))
	 (go start))))
  (defun subst (new old tree &rest rest)
    (if (consp tree)
	(let ((a (apply #'subst new old (car tree) rest))
	      (d (apply #'subst new old (cdr tree) rest)))
	  (if (and (eq a (car tree)) (eq d (cdr tree)))
	      tree
	      (cons a d)))
	(if (apply #'satisfies old tree rest) new tree)))
  (defun subst-if (new predicate tree &rest rest)
    (if (consp tree)
	(let ((a (apply #'subst new predicate (car tree) rest))
	      (d (apply #'subst new predicate (cdr tree) rest)))
	  (if (and (eq a (car tree)) (eq d (cdr tree)))
	      tree
	      (cons a d)))
	(if (apply #'satisfies-if predicate tree rest) new tree)))
  (defun subst-if-not (new predicate tree &rest rest)
    (if (consp tree)
	(let ((a (apply #'subst new predicate (car tree) rest))
	      (d (apply #'subst new predicate (cdr tree) rest)))
	  (if (and (eq a (car tree)) (eq d (cdr tree)))
	      tree
	      (cons a d)))
	(if (apply #'satisfies-if-not predicate tree rest) new tree)))
  (defun nsubst (new old tree &rest rest)
    (if (consp tree)
	(progn
	  (setf (car tree) (apply #'subst new old (car tree) rest))
	  (setf (cdr tree) (apply #'subst new old (cdr tree) rest))
	  tree)
	(if (apply #'satisfies old tree rest) new tree)))
  (defun nsubst-if (new predicate tree &rest rest)
    (if (consp tree)
	(progn
	  (setf (car tree) (apply #'subst new predicate (car tree) rest))
	  (setf (cdr tree) (apply #'subst new predicate (cdr tree) rest))
	  tree)
	(if (apply #'satisfies-if predicate tree rest) new tree)))
  (defun nsubst-if-not (new predicate tree &rest rest)
    (if (consp tree)
	(progn
	  (setf (car tree) (apply #'subst new predicate (car tree) rest))
	  (setf (cdr tree) (apply #'subst new predicate (cdr tree) rest))
	  tree)
	(if (apply #'satisfies-if-not predicate tree rest) new tree)))
  (defun assoc (item alist &rest rest)
    (dolist (elem alist)
      (when (apply #'satisfies item (car elem) rest)
	(return-from assoc elem))))
  (defun assoc-if (predicate alist &rest rest)
    (dolist (elem alist)
      (when (apply #'satisfies-if predicate (car elem) rest)
	(return-from assoc-if elem))))
  (defun assoc-if-not (predicate alist &rest rest)
    (dolist (elem alist)
      (when (apply #'satisfies-if-not predicate (car elem) rest)
	(return-from assoc-if-not elem))))
  (defun rassoc (item alist &rest rest)
    (dolist (elem alist)
      (when (apply #'satisfies item (cdr elem) rest)
	(return-from rassoc elem))))
  (defun rassoc-if (predicate alist &rest rest)
    (dolist (elem alist)
      (when (apply #'satisfies-if predicate (cdr elem) rest)
	(return-from rassoc-if elem))))
  (defun rassoc-if-not (predicate alist &rest rest)
    (dolist (elem alist)
      (when (apply #'satisfies-if-not predicate (cdr elem) rest)
	(return-from rassoc-if-not elem))))
  (defun adjoin (item list &rest rest)
    (dolist (elem list (cons item list))
      (when (apply #'satisfies item elem rest)
	(return-from adjoin list))))
  (defun set-exclusive-or (list-1 list-2 &rest rest &key key)
    (let ((result nil))
      (dolist (item list-1)
	(unless (apply #'member (if key (funcall key item) item) list-2 rest)
	  (push item result)))
      (dolist (item list-2)
	(block matches
	  (dolist (elem list-1)
	    (when (apply #'satisfies
			 (if key (funcall key elem) elem) item rest)
	      (return-from matches)))
	  (push item result)))
      result))
  (defun nset-exclusive-or (list-1 list-2 &rest rest &key key)
    (let ((result nil)
	  (list nil)
	  (item nil))
      (tagbody
       start-1
	 (unless list-1 (go start-2))
	 (setf item (car list-1))
	 (setf list list-2)
	 (setf prev nil)
       start-1-in
	 (unless list (go end-1-in))
	 (let ((elem (if key (funcall key (car list)) (car list))))
	   (when (apply #'satisfies item (if key (funcall key elem) elem) rest)
	     (if prev
		 (setf (cdr prev) (cdr list))
		 (setf list-2 (cdr list)))
	     (setf list-1 (cdr list-1))
	     (go start-1)))
	 (setf prev list)
	 (setf list (cdr list))
	 (go start-1-in)
       end-1-in
	 (setf item (cdr list-1))
	 (setf (cdr list-1) result)
	 (unless result (setf end list-1))
	 (setf result list-1)
	 (setf list-1 item)
	 (go start-1)
       start-2
	 (return-from nset-exclusive-or
	   (if end (progn (setf (cdr end) list-2) result) list-2)))))
  (defun fill (sequence item &rest rest)
    (let ((iter (apply #'seq-start sequence rest)))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (seq-set sequence iter item)
	   (seq-next iter)
	   (go start))))
    sequence)
  (defun every (predicate &rest sequences)
    (let ((iters (mapcar #'seq-start sequences)))
      (tagbody
       start
	 (unless (some-list-2 #'seq-end-p sequences iters)
	   (unless (apply predicate (mapcar #'seq-ref sequences iters))
	     (return-from every nil))
	   (mapc #'seq-next iters)
	   (go start))))
    t)
  (defun some (predicate &rest sequences)
    (let ((iters (mapcar #'seq-start sequences)))
      (tagbody
       start
	 (unless (some-list-2 #'seq-end-p sequences iters)
	   (let ((result (apply predicate (mapcar #'seq-ref sequences iters))))
	     (when result (return-from some result)))
	   (mapc #'seq-next iters)
	   (go start)))))
  (defun notevery (predicate &rest sequences)
    (let ((iters (mapcar #'seq-start sequences)))
      (tagbody
       start
	 (unless (some-list-2 #'seq-end-p sequences iters)
	   (unless (apply predicate (mapcar #'seq-ref sequences iters))
	     (return-from every t))
	   (mapc #'seq-next iters)
	   (go start)))))
  (defun notany (predicate &rest sequences)
    (let ((iters (mapcar #'seq-start sequences)))
      (tagbody
       start
	 (unless (some-list-2 #'seq-end-p sequences iters)
	   (when (apply predicate (mapcar #'seq-ref sequences iters))
	     (return-from every nil))
	   (mapc #'seq-next iters)
	   (go start))))
    t)
  (defun map-into (result-sequence function &rest sequences)
    (let ((result-iter (seq-start result-sequence))
	  (iters (mapcar #'seq-start sequences)))
      (tagbody
       start
	 (unless (some-list-2 #'seq-end-p sequences iters)
	   (seq-set result-sequence result-iter
		    (apply function (mapcar #'seq-ref sequences iters)))
	   (seq-next result-iter)
	   (mapc #'seq-next iters)
	   (go start))))
    result-sequence)
  (defun reduce (function sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest)))
      (if (apply #'seq-end-p sequence iter rest)
	  (funcall function)
	  (let ((elem (seq-ref sequence iter)))
	    (seq-next iter)
	    (unless (apply #'seq-end-p sequence iter rest)
	      (tagbody
	       start
		 (setq elem (funcall function elem (seq-ref sequence iter)))
		 (seq-next iter)
		 (unless (apply #'seq-end-p sequence iter rest)
		   (go start))))
	    elem))))
  (defun count (item sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest))
	  (count 0))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (when (apply #'satisfies item (seq-ref sequence iter) rest)
	     (setf count (+ 1 count)))
	   (seq-next iter)
	   (go start)))
      count))
  (defun count-if (predicate sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest))
	  (count 0))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (when (apply #'satisfies-if predicate (seq-ref sequence iter) rest)
	     (setf count (+ 1 count)))
	   (seq-next iter)
	   (go start)))
      count))
  (defun count-if-not (predicate sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest))
	  (count 0))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (when (apply #'satisfies-if-not predicate (seq-ref sequence iter)
			rest)
	     (setf count (+ 1 count)))
	   (seq-next iter)
	   (go start)))
      count))
  (defun find (item sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest)))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (let ((elem (seq-ref sequence iter)))
	     (when (apply #'satisfies item elem rest)
	       (return-from find elem)))
	   (seq-next iter)
	   (go start)))))
  (defun find-if (predicate sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest)))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (let ((elem (seq-ref sequence iter)))
	     (when (apply #'satisfies-if predicate elem rest)
	       (return-from find-if elem)))
	   (seq-next iter)
	   (go start)))))
  (defun find-if-not (predicate sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest)))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (let ((elem (seq-ref sequence iter)))
	     (when (apply #'satisfies-if-not predicate elem rest)
	       (return-from find-if-not elem)))
	   (seq-next iter)
	   (go start)))))
  (defun position (item sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest)))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (when (apply #'satisfies item (seq-ref sequence iter) rest)
	     (return-from position (seq-position iter)))
	   (seq-next iter)
	   (go start)))))
  (defun position-if (predicate sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest)))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (when (apply #'satisfies-if predicate (seq-ref sequence iter) rest)
	     (return-from position-if (seq-position iter)))
	   (seq-next iter)
	   (go start)))))
  (defun position-if-not (predicate sequence &rest rest)
    (let ((iter (apply #'seq-start sequence rest)))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (when (apply #'satisfies-if-not predicate (seq-ref sequence iter)
			rest)
	     (return-from position-if-not (seq-position iter)))
	   (seq-next iter)
	   (go start)))))
  (defun remove (item sequence &rest rest &key count)
    (let ((iter (apply #'seq-start sequence rest))
	  (result nil))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (let ((elem (seq-ref sequence iter)))
	     (unless (and (apply #'satisfies item elem rest)
			  (or (not count) (not (minusp (decf count)))))
	       (push elem result)))
	   (seq-next iter)
	   (go start)))
      (seq-result sequence iter result)))
  (defun remove-if (predicate sequence &rest rest &key count)
    (let ((iter (apply #'seq-start sequence rest))
	  (result nil))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (let ((elem (seq-ref sequence iter)))
	     (unless (and (apply #'satisfies-if predicate elem rest)
			  (or (not count) (not (minusp (decf count)))))
	       (push elem result)))
	   (seq-next iter)
	   (go start)))
      (seq-result sequence iter result)))
  (defun remove-if-not (predicate sequence &rest rest &key count)
    (let ((iter (apply #'seq-start sequence rest))
	  (result nil))
      (tagbody
       start
	 (unless (apply #'seq-end-p sequence iter rest)
	   (let ((elem (seq-ref sequence iter)))
	     (unless (and (apply #'satisfies-if-not predicate elem rest)
			  (or (not count) (not (minusp (decf count)))))
	       (push elem result)))
	   (seq-next iter)
	   (go start)))
      (seq-result sequence iter result))))
(defun array-type (array)
  (case (ldb '(2 . 0) (ival array))
    (2 (case (iref array 1)
	 (3 2)
	 (4 3)
	 (7 4)
	 (t (error "not an array"))))
    (3 (case (jref array 1)
	 (20 0)
	 (116 1)
	 (t (error "not an array"))))
    (t (error "not an array"))))
(defun initial-contents (array subscripts initial-contents)
  (if (= (length subscripts) (array-rank array))
      (apply #'(setf aref) initial-contents array subscripts)
      (let ((i 0))
	(dolist (elem initial-contents)
	  (initial-contents array (append subscripts (list i)) elem)
	  (setf i (+ 1 i))))))
(defun make-array (dimensions &key (element-type t) initial-element
		   initial-contents adjustable fill-pointer displaced-to
		   (displaced-index-offset 0))
  (setf dimensions (designator-list dimensions))
  (setf element-type (upgraded-array-element-type element-type))
  (let* ((simple-vector-p (and (= (length dimensions) 1)
			       (not adjustable)
			       (not fill-pointer)
			       (not displaced-to)))
	 (total-size (apply #'* dimensions))
	 (content (or displaced-to
		      (case element-type
			(bit (makej total-size 116))
			(character (makej (+ 1 (* 8 total-size)) 20))
			(t (makei total-size 3)))))
	 (array (if simple-vector-p
		    content
		    (makei 4 4 total-size
			   (if (= (length dimensions) 1)
			       fill-pointer
			       dimensions)
			   content
			   (when displaced-to displaced-index-offset)))))
    (unless displaced-to
      (if initial-contents
	  (initial-contents array nil initial-contents)
	  (let ((i 0))
	    (tagbody
	     start
	       (when (< i total-size)
		 (setf (aref content i) initial-element)
		 (incf i)
		 (go start))))))
    array))
(defun adjust-array (array dimensions &key element-type initial-element
		     initial-contents fill-pointer displaced-to
		     (displaced-index-offset 0))
  (setq dimensions (designator-list dimensions))
  (case (array-type array)
    ((0 1 2 4) nil)
    (3 (let ((offset (iref array 5)))
	 (if offset
	     nil
	     (if displaced-to
		 nil
		 (let* ((total-size (apply #'* dimensions))
			(content (makei total-size 3)))
		   (dotimes (i (min (iref array 2) total-size))
		     (setf (iref content (+ 2 i))
			   (iref (iref array 4) (+ 2 i))))
		   (when (> total-size (iref array 2))
		     (dotimes (i (- total-size (iref array 2)))
		       (setf (iref content (+ 2 i (iref array 2)))
			     initial-element)))
		   (setf (iref array 2) total-size)
		   (setf (iref array 3)
			 (if (= (length dimensions) 1)
			     (case fill-pointer
			       ((nil) (iref array 3))
			       ((t) total-size)
			       (t fill-pointer))
			     dimensions))
		   (setf (iref array 4) content)))))
       array)))
(defun adjustable-array-p (array)
  (case (array-type array)
    ((0 1 2) nil)
    ((3 4) t)
    (t (error "not an array"))))
(defun aref (array &rest subscripts)
  (row-major-aref array (apply #'array-row-major-index array subscripts)))
(defun (setf aref) (new-element array &rest subscripts)
  (setf (row-major-aref array (apply #'array-row-major-index array subscripts))
	new-element))
(defun array-dimension (array axis-number)
  (nth axis-number (array-dimensions array)))
(defun array-dimensions (array)
  (case (array-type array)
    (0 (list (- (/ (jref array 0) 64) 4)))
    (1 (list (- (/ (jref array 0) 8) 31)))
    (2 (list (/ (iref array 0) 8)))
    ((3 4) (let ((dims/fill (iref array 3)))
	     (if (consp dims/fill) dims/fill (list (iref array 2)))))))
(defun array-has-fill-pointer-p (array)
  (case (array-type array)
    ((3 4) (atom (iref array 3)))
    ((0 1 2) nil)
    (t (error "not an array"))))
(defun array-displacement (array)
  (case (array-type array)
    ((3 4) (let ((offset (iref array 5)))
	     (if offset
		 (values (iref array 4) offset)
		 (values nil 0))))
    ((0 1 2) (values nil 0))
    (t (error "not an array"))))
(defun array-in-bounds-p (array &rest subscripts)
  (dolist (dim (array-dimensions array) t)
    (let ((subscript (pop subscripts)))
      (unless (< subscript dim)
	(return)))))
(defun array-rank (array)
  (length (array-dimensions array)))
(defun array-row-major-index (array &rest subscripts)
  (let ((index 0)
	(last-dim 1))
    (dolist (dim (array-dimensions array))
      (let ((subscript (pop subscripts)))
	(unless (< subscript dim)
	  (error "index out of bounds"))
	(setf index (+ (* last-dim index) subscript))
	(setf last-dim dim)))
    index))
(defun array-total-size (array)
  (case (array-type array)
    ((0 1 2) (length array))
    ((3 4) (iref array 2))
    (t (error "not an array"))))
(defun arrayp (object)
  (case (ldb '(2 . 0) (ival object))
    (2 (case (iref object 1)
	 ((3 4 7) t)))
    (3 (case (jref object 1)
	 ((20 116) t)))))
(defun fill-pointer (vector)
  (case (array-type vector)
    ((3 4) (let ((dims/fill (iref vector 3)))
	     (when (consp dims/fill)
	       (error "not a vector"))
	     (unless dims/fill
	       (error "no fill pointer"))
	     dims/fill))
    (t (error "not a vector with fill pointer"))))
(defun (setf fill-pointer) (new-fill-pointer vector)
  (case (array-type vector)
    ((3 4) (let ((dims/fill (iref vector 3)))
	     (when (consp dims/fill)
	       (error "not a vector"))
	     (unless dims/fill
	       (error "no fill pointer"))
	     (setf (iref vector 3) new-fill-pointer)))
    (t (error "not a vector with fill pointer"))))
(defparameter *big-endian* (= (ldb '(8 . 0) (jref "ABCD" 2)) 68))
(if *big-endian*
    (defun row-major-aref (array index)
      (case (array-type array)
	(0 (code-char (ldb (cons 8 (* 8 (- 3 (ldb '(2 . 0) index))))
			   (jref array (+ 2 (/ index 4))))))
	(1 (ldb (cons 1 (ldb '(5 . 0) index)) (jref array (+ 2 (/ index 32)))))
	(2 (iref array (+ 2 index)))
	(3 (row-major-aref (iref array 4) index))
	(4 (error "accessing nil array"))
	(t (error "not an array"))))
    (defun row-major-aref (array index)
      (case (array-type array)
	(0 (code-char (ldb (cons 8 (* 8 (ldb '(2 . 0) index)))
			   (jref array (+ 2 (/ index 4))))))
	(1 (ldb (cons 1 (ldb '(5 . 0) index)) (jref array (+ 2 (/ index 32)))))
	(2 (iref array (+ 2 index)))
	(3 (row-major-aref (iref array 4) index))
	(4 (error "accessing nil array"))
	(t (error "not an array")))))
(if *big-endian*
    (defun (setf row-major-aref) (new-element array index)
      (case (array-type array)
	(0 (multiple-value-bind (index-major index-minor)
	       (floor index 4)
	     (setf (jref array (+ 2 index-major))
		   (dpb (char-code new-element)
			(cons 8 (* 8 (- 3 index-minor)))
			(jref array (+ 2 index-major))))))
	(1 (multiple-value-bind (index-major index-minor)
	       (floor index 32)
	     (setf (jref array (+ 2 index-major))
		   (dpb new-element
			(cons 1 index-minor)
			(jref array (+ 2 index-major))))))
	(2 (setf (iref array (+ 2 index)) new-element))
	(3 (setf (row-major-aref (iref array 4) index) new-element))
	(4 (error "accessing nil array"))
	(t (error "not an array")))
      new-element)
    (defun (setf row-major-aref) (new-element array index)
      (case (array-type array)
	(0 (multiple-value-bind (index-major index-minor)
	       (floor index 4)
	     (setf (jref array (+ 2 index-major))
		   (dpb (char-code new-element)
			(cons 8 (* 8 index-minor))
			(jref array (+ 2 index-major))))))
	(1 (multiple-value-bind (index-major index-minor)
	       (floor index 32)
	     (setf (jref array (+ 2 index-major))
		   (dpb new-element
			(cons 1 index-minor)
			(jref array (+ 2 index-major))))))
	(2 (setf (iref array (+ 2 index)) new-element))
	(3 (setf (row-major-aref (iref array 4) index) new-element))
	(4 (error "accessing nil array"))
	(t (error "not an array")))
      new-element))
(defun upgraded-array-element-type (typespec &optional environment)
  (setf typespec (designator-list typespec))
  (case (car typespec)
    ((base-char character) 'character)
    ((bit) 'bit)
    ((unsigned-byte) (if (and (= (length typespec) 2)
			      (= (second typespec) 1))
			 'bit
			 't))
    ((integer) (if (and (= (length typespec) 3)
			(= (second typespec) 0)
			(= (third typespec) 1))
		   'bit
		   't))
    (t 't)))
(defun simple-vector-p (object)
  (case (ldb '(2 . 0) (ival object))
    (2 (= (iref object 1) 3))
    (3 (member (jref object 1) '(20 116)))))
(defun svref (simple-vector index)
  (aref simple-vector index))
(defun (setf svref) (new-element simple-vector index)
  (setf (aref simple-vector index) new-element))
(defun vector (&rest objects)
  (let ((vector (makei (length objects) 3))
	(i 2))
    (dolist (object objects)
      (setf (iref vector i) object)
      (setf i (+ 1 i)))
    vector))
(defun vector-pop (vector)
  (aref vector (setf (fill-pointer vector) (- (fill-pointer vector) 1))))
(defun vector-push (new-element vector)
  (let ((fill-pointer (fill-pointer vector)))
    (when (< fill-pointer (array-dimension vector 0))
      (setf (aref vector fill-pointer) new-element)
      (setf (fill-pointer vector) (+ 1 fill-pointer))
      fill-pointer)))
(defun vector-push-extend (new-element vector
			   &optional (extension (array-dimension vector 0)))
  (let ((fill-pointer (fill-pointer vector)))
    (unless (< fill-pointer (array-dimension vector 0))
      (adjust-array vector (+ fill-pointer extension)))
    (setf (aref vector fill-pointer) new-element)
    (setf (fill-pointer vector) (+ 1 fill-pointer))
    fill-pointer))
(defun vectorp (object)
  (case (ldb '(2 . 0) (ival object))
    (2 (case (iref object 1)
	 (3 t)
	 ((4 7) (atom (iref object 3)))))
    (3 (member (jref object 1) '(20 116)))))
(defun simple-bit-vector-p (object)
  (and (= (ldb '(2 . 0) (ival object)) 3) (= (jref object 1) 116)))
(defun bit-vector-p (object)
  (let ((tag (ldb '(2 . 0) (ival object))))
    (or (and (= tag 3) (= (jref object 1) 116))
	(and (= tag 2) (= (iref object 1) 4) (bit-vector-p (iref object 4))))))
(defun simple-string-p (object)
  (and (= (ldb '(2 . 0) (ival object)) 3) (= (jref object 1) 20)))
(defun char (string index)
  (aref string index))
(defun (setf char) (new-character string index)
  (setf (aref string index) new-character))
(defun schar (string index)
  (aref string index))
(defun (setf schar) (new-character string index)
  (setf (aref string index) new-character))
(defun string-upcase (string &key (start 0) end)
  (nstring-upcase (copy-seq string) :start start :end end))
(defun string-downcase (string &key (start 0) end)
  (nstring-downcase (copy-seq string) :start start :end end))
(defun string-capitalize (string &key (start 0) end)
  (nstring-capitalize (copy-seq string) :start start :end end))
(defun nstring-upcase (string &key (start 0) end)
  (setq string (designator-string string))
  (unless end (setq end (length string)))
  (tagbody
   start
     (when (< start end)
       (setf (aref string start) (char-upcase (aref string start)))
       (incf start)
       (go start)))
  string)
(defun nstring-downcase (string &key (start 0) end)
  (setq string (designator-string string))
  (unless end (setq end (length string)))
  (tagbody
   start
     (when (< start end)
       (setf (aref string start) (char-downcase (aref string start)))
       (incf start)
       (go start)))
  string)
(defun nstring-capitalize (string &key (start 0) end)
  (setq string (designator-string string))
  (unless end (setq end (length string)))
  (let ((word-start t))
    (tagbody
     start
       (when (< start end)
	 (setf (aref string start)
	       (let ((c (aref string start)))
		 (prog1
		     (if word-start
			 (char-upcase c)
			 (char-downcase c))
		   (setq word-start (not (alphanumericp c))))))
	 (incf start)
	 (go start))))
  string)
(defun string-trim (character-bag string)
  (let ((i 0)
	(j (length string)))
    (tagbody
     start
       (when (and (< i j) (position (aref string i) character-bag))
	 (incf i)
	 (go start)))
    (tagbody
     start
       (when (and (plusp j) (position (aref string (- j 1)) character-bag))
	 (decf j)
	 (go start)))
    (if (< i j)
	(subseq string i j)
	"")))
(defun string-left-trim (character-bag string)
  (let ((i 0))
    (tagbody
     start
       (when (and (< i (length string))
		  (position (aref string i) character-bag))
	 (incf i)
	 (go start)))
    (subseq string i)))
(defun string-right-trim (character-bag string)
  (let ((i (length string)))
    (tagbody
     start
       (when (and (plusp i) (position (aref string (- i 1)) character-bag))
	 (decf j)
	 (go start)))
    (subseq string 0 i)))
(flet ((string-mismatch (comparator string1 string2
				    &key (start1 0) end1 (start2 0) end2)
	 (setq string1 (designator-string string1))
	 (setq string2 (designator-string string2))
	 (unless end1 (setq end1 (length string1)))
	 (unless end2 (setq end2 (length string2)))
	 (tagbody
	  start
	    (when (and (< start1 end1) (< start2 end2))
	      (unless (funcall comparator
			       (aref string1 start1) (aref string2 start2))
		(return-from string-mismatch start1))
	      (incf start1)
	      (incf start2)
	      (go start)))
	 (if (or (< start1 end1) (< start2 end2))
	     start1
	     nil)))
  (defun string/= (&rest rest)
    (apply #'string-mismatch #'char= rest))
  (defun string-not-equal (&rest rest)
    (apply #'string-mismatch #'char-equal rest)))
(defun *string= (&rest rest)
  (not (apply #'string/= rest)))
(defun string-equal (&rest rest)
  (not (apply #'string-not-equal rest)))
(flet ((string-mismatch (exit continue default1 default2 default3
			 string1 string2 &key (start1 0) end1 (start2 0) end2)
	 (setq string1 (designator-string string1))
	 (setq string2 (designator-string string2))
	 (unless end1 (setq end1 (length string1)))
	 (unless end2 (setq end2 (length string2)))
	 (tagbody
	  start
	    (when (and (< start1 end1) (< start2 end2))
	      (let ((c1 (aref string1 start1))
		    (c2 (aref string2 start2)))
		(when (funcall exit c1 c2)
		  (return-from string-mismatch start1))
		(unless (funcall continue c1 c2)
		  (return-from string-mismatch)))
	      (incf start1)
	      (incf start2)
	      (go start)))
	 (when (cond
		 ((< start1 end1) default1)
		 ((< start2 end2) default2)
		 (t default3))
	   start1)))
  (defun string< (&rest rest)
    (apply #'string-mismatch #'char< #'char= nil t nil rest))
  (defun string<= (&rest rest)
    (apply #'string-mismatch #'char< #'char= nil t t rest))
  (defun string> (&rest rest)
    (apply #'string-mismatch #'char> #'char= t nil nil rest))
  (defun string>= (&rest rest)
    (apply #'string-mismatch #'char> #'char= t nil t rest))
  (defun string-lessp (&rest rest)
    (apply #'string-mismatch #'char-lessp #'char-equal nil t nil rest))
  (defun string-not-greaterp (&rest rest)
    (apply #'string-mismatch #'char-lessp #'char-equal nil t t rest))
  (defun string-greaterp (&rest rest)
    (apply #'string-mismatch #'char-greaterp #'char-equal t nil nil rest))
  (defun string-not-lessp (&rest rest)
    (apply #'string-not-lessp #'char-greaterp #'char-equal t nil t rest)))
(defun stringp (object)
  (case (ldb '(2 . 0) (ival object))
    (2 (and (member (iref object 1) '(4 7))
	    (atom (iref object 3))))
    (3 (= (jref object 1) 20))))
(defun make-string (size &key (initial-element (code-char 0))
		    (element-type 'character))
  (let* ((string (makej (+ 1 (* size 8)) 20))
	 (i 0)
	 (init-code (char-code initial-element))
	 (init (* 16843009 init-code)))
    (tagbody
     start
       (when (< i (/ size 4))
	 (setf (jref string (+ 2 i)) init)
	 (setf i (+ 1 i))
	 (go start)))
    (setf (jref string (+ 2 (/ size 4)))
	  (dpb init (cons (* 8 (ldb '(2 . 0) size)) 0) 0))
    string))
(defun reverse (sequence)
  (if (listp sequence)
      (let ((acc nil))
	(dolist (elem sequence)
	  (push elem acc))
	acc)
      "FIXME"))
(defun nreverse (sequence)
  (if (listp sequence)
      (let ((prev nil))
	(tagbody
	 start
	   (when sequence
	     (let ((next (cdr sequence)))
	       (setf (cdr sequence) prev)
	       (setf prev sequence)
	       (setf sequence next))
	     (go start)))
	prev)
      "FIXME"))
(defun get-properties (plist indicator-list)
  (tagbody
   start
     (when plist
       (when (member (car plist) indicator-list :test #'eq)
	 (return-from get-properties
	   (values (car plist) (cadr plist) (cddr plist))))
       (setf plist (cddr plist))
       (go start))))
(defun getf (plist indicator &optional default)
  (tagbody
   start
     (when plist
       (when (eq (car plist) indicator)
	 (return-from plist (cadr plist)))
       (setf plist (cddr plist))
       (go start)))
  default)
(defmacro define-setf-expander (access-fn lambda-list &rest forms)
  `',access-fn)
(define-setf-expander getf (place indicator &optional default &environment env)
  (multiple-value-bind (dummies vals newval setter getter)
      (get-setf-expansion place env)
    (let ((t-indicator (gensym))
	  (t-default (gensym))
	  (t-place (gensym))
	  (t-plist (gensym))
	  (store (gensym)))
      (values (list* t-indicator t-default dummies)
	      (list* indicator default vals)
	      (list store)
	      `(let ((,t-place ,getter))
		(do ((,t-plist ,t-place (cddr ,t-plist)))
		    ((not ,t-plist)
		     (let ((,(car newval) (list* ,t-indicator ,store t-place)))
		       ,setter))
		  (when (eq (car ,t-plist) ,t-indicator)
		    (setf (cadr ,t-plist) ,store)
		    (return)))
		,store)
	      `(getf ,getter ,ind ,def)))))
(defmacro remf (place indicator)
  (let ((t-plist (gensym))
	(t-indicator (gensym)))
    `(let ((,t-plist ,place)
	   (,t-indicator ,indicator))
      (if (eq (car ,t-plist) ,t-indicator)
	  (progn (setf ,place (cddr ,t-plist)) t)
	  (tagbody
	     (setf ,t-plist (cdr ,t-plist))
	   start
	     (when (cdr ,t-plist)
	       (when (eq (cadr ,t-plist) ,t-indicator)
		 (setf (cdr ,t-plist) (cddr ,t-plist))
		 (return-from nil t))
	       (setf ,t-plist (cddr ,t-plist))
	       (go start)))))))
(defun intersection (list-1 list-2 &rest rest &key key)
  (let ((result nil))
    (dolist (item list-1)
      (when (apply #'member (if key (funcall key item) item) list-2 rest)
	(push item result)))
    result))
(defun nintersection (list-1 list-2 &rest rest &key key)
  (let ((result nil))
    (tagbody
     start
       (unless list-1 (return-from nintersection result))
       (let ((item (car list-1)))
	 (if (apply #'member (if key (funcall key item) item) list-2 rest)
	     (progn
	       (setf item (cdr list-1))
	       (setf (cdr list-1) result)
	       (setf result list-1)
	       (setf list-1 item))
	     (setf list-1 (cdr list-1))))
       (go start))))
(defun set-difference (list-1 list-2 &rest rest &key key)
  (let ((result nil))
    (dolist (item list-1)
      (unless (apply #'member (if key (funcall key item) item) list-2 rest)
	(push item result)))
    result))
(defun nset-difference (list-1 list-2 &rest rest &key key)
  (let ((result nil))
    (tagbody
     start
       (unless list-1 (return-from nset-difference result))
       (let ((item (car list-1)))
	 (if (apply #'member (if key (funcall key item) item) list-2 rest)
	     (setf list-1 (cdr list-1))
	     (progn
	       (setf item (cdr list-1))
	       (setf (cdr list-1) result)
	       (setf result list-1)
	       (setf list-1 item))))
       (go start))))
(defmacro pushnew (item place &rest rest)
  `(unless (member ,item ,place ,@rest)
    (push ,item ,place)))
(defun union (list-1 list-2 &rest rest &key key)
  (let ((result list-2))
    (dolist (item list-1)
      (unless (apply #'member (if key (funcall key item) item) list-2 rest)
	(push item result)))
    result))
(defun nunion (list-1 list-2 &rest rest &key key)
  (let ((result list-2))
    (tagbody
     start
       (unless list-1 (return-from nunion result))
       (let ((item (car list-1)))
	 (if (apply #'member (if key (funcall key item) item) list-2 rest)
	     (setf list-1 (cdr list-1))
	     (progn
	       (setf item (cdr list-1))
	       (setf (cdr list-1) result)
	       (setf result list-1)
	       (setf list-1 item))))
       (go start))))
(defun array-element-type (sequence)
  (if (stringp sequence) 'character 't))
(defun copy-seq (sequence)
  (if (listp sequence)
      (copy-list sequence)
      (let ((new-sequence (make-sequence (type-of sequence)
					 (length sequence)))
	    (index 0))
	(tagbody
	 start
	   (when (< index (length sequence))
	     (setf (aref new-sequence index) (aref sequence index))
	     (setf index (+ 1 index))
	     (go start)))
	new-sequence)))
(defun elt (sequence index)
  (if (listp sequence)
      (nth index sequence)
      (aref sequence index)))
(defun (setf elt) (new-object sequence index)
  (if (listp sequence)
      (setf (nth index sequence) new-object)
      (setf (aref sequence index) new-object)))
(defun make-sequence (result-type size &key initial-element)
  (let ((type-head (car (designator-list result-type))))
    (case type-head
      ((list cons null)	(make-list size :initial-element initial-element))
      (string (make-string size :initial-element initial-element))
      (vector (make-array size :initial-element initial-element))
      (t (error 'type-error :datum result-type :expected-type 'sequence)))))
(defun subseq (sequence start &optional end)
  (if (listp sequence)
      (let ((tail (nthcdr start sequence)))
	(if end
	    (let ((result nil))
	      (tagbody
	       start
		 (when (< start end)
		   (push (pop tail) result)
		   (incf start)
		   (go start)))
	      (reverse result))
	    (copy-list tail)))
      (let ((tag (ldb '(2 . 0) (ival sequence))))
	(unless end (setq end (length sequence)))
	(let ((new-sequence (if (= tag 2)
				(if (= (iref sequence 1) 3)
				    (makei (- end start) 3)
				    (return-from subseq
				      (let ((offset (iref sequence 5)))
					(if offset
					    (subseq (iref sequence 4)
						     (+ start offset)
						     (min (length sequence)
							  (+ end offset)))
					    (subseq (iref sequence 4)
						     start end)))))
				(if (= (jref sequence 1) 20)
				    (makej (+ 1 (* 8 (- end start))) 20)
				    (makej (- end start) 116))))
	      (index 0))
	  (tagbody
	   start
	     (when (< start end)
	       (setf (aref new-sequence index) (aref sequence start))
	       (incf index)
	       (incf start)
	       (go start)))
	  new-sequence))))
(defun (setf subseq) (new-subsequence sequence start &optional end)
  (let ((result new-subsequence))
    (if (listp sequence)
	(let ((tail (nthcdr start sequence)))
	  (tagbody
	   start
	     (when (and tail (or (not end) (< start end)))
	       (setf (car tail) (pop new-subsequence))
	       (incf start)
	       (go start))))
	(let ((index 0))
	  (unless end (setq end (length sequence)))
	  (tagbody
	   start
	     (when (< start end)
	       (setf (aref sequence start) (aref new-subsequence index))
	       (incf index)
	       (incf start)
	       (go start)))))
    result))
(defun conc-string (&rest seq)
  (setq seq (mapcar #'designator-string seq))
  (let ((length 0))
    (mapc #'(lambda (string) (setq length (+ length (length string)))) seq)
    (let ((result-string (make-string length)))
      (setq length 0)
      (mapc #'(lambda (string)
		(let ((new-length (+ length (length string))))
		  (setf (subseq result-string length new-length) string)
		  (setq length new-length)))
	    seq)
      result-string)))
(defun designator-list (designator)
  (if (listp designator) designator (list designator)))
(defparameter *standard-class* (makei 1 0))
(setf (iref *standard-class* 1) *standard-class*)
(defparameter *structure-class* (makei 1 *standard-class*))
(defparameter *hash-table* (makei 1 *structure-class*))
(defun hash-eql (object)
  (if (and (= (ldb '(2 . 0) (ival object)) 3) (= (jref object 1) 84))
      (floor (abs object))
      (ival object)))
(defun sxhash (object &optional (level 4))
  (if (zerop level)
      0
      (let ((lvl (- level 1)))
	(case (ldb '(2 . 0) (ival object))
	  (0 (ival object))
	  (1 (+ (sxhash (car object) lvl) (sxhash (cdr object) lvl)))
	  (2 (case (iref object 1)
	       (t (ival object))))
	  (3 (case (jref object 1)
	       (20 (hash object))
	       (84 (floor (abs object)))
	       (t (ival object))))))))
(defun make-hash-table (&key (test 'eql) (size 61) (rehash-size 1.999)
			(rehash-threshold 1))
  (when (functionp test)
    (setq test (iref test 6)))
  (makei 6 *hash-table* 0 rehash-size rehash-threshold test
	 (case test
	   (eq #'ival)
	   (eql #'hash-eql)
	   (equal #'sxhash)
	   (equalp #'hash-equalp)
	   (t (error "Unknown test function ~A." test)))
	 (makei size 3)))
(defun gethash (key hash-table &optional default)
  (let* ((table (hash-table-table hash-table))
	 (test (hash-table-test hash-table))
	 (index (mod (funcall (hash-table-hash hash-table) key)
		     (length table))))
    (dolist (cons (iref table (+ 2 index)) (values default nil))
      (when (funcall test (car cons) key)
	(return (values (cdr cons) t))))))
(defun (setf gethash) (new-value key hash-table &optional default)
  (let* ((table (hash-table-table hash-table))
	 (test (hash-table-test hash-table))
	 (index (mod (funcall (hash-table-hash hash-table) key)
		     (length table))))
    (dolist (cons (iref table (+ 2 index))
	     (progn
	       (push (cons key new-value) (iref table (+ 2 index)))
	       (unless (< (incf (hash-table-count hash-table))
			  (* (hash-table-rehash-threshold hash-table)
			     (length table)))
		 (setf (hash-table-table hash-table)
		       (makei (floor (* (hash-table-rehash-size hash-table)
					(length table)))
			      3))
		 (setf (hash-table-count hash-table) 0)
		 (dotimes (index (length table))
		   (dolist (cons (iref table (+ 2 index)))
		     (setf (gethash (car cons) hash-table) (cdr cons)))))))
      (when (funcall test (car cons) key)
	(setf (cdr cons) new-value)
	(return (values (cdr cons) t)))))
  new-value)
(defun remhash (key hash-table)
  (let* ((table (hash-table-table hash-table))
	 (test (hash-table-test hash-table))
	 (index (mod (funcall (hash-table-hash hash-table) key)
		     (length table)))
	 (cons (iref table (+ 2 index)))
	 (prev-cons nil))
    (tagbody
     start
       (unless cons (return-from remhash))
       (unless (funcall test (caar cons) key)
	 (setq prev-cons cons)
	 (setq cons (cdr cons))
	 (go start)))
    (if prev-cons
	(setf (cdr prev-cons) (cdr cons))
	(setf (iref table (+ 2 index)) (cdr cons)))
    (decf (hash-table-count hash-table))
    t))
(defun maphash (function hash-table)
  (let ((table (hash-table-table hash-table)))
    (dotimes (index (length table))
      (dolist (cons (iref table (+ 2 index)))
	(funcall function (car cons) (cdr cons))))))
(defun hash-table-iterator (hash-table)
  (let ((table (hash-table-table hash-table))
	(index 0)
	(cons nil))
    #'(lambda ()
	(block nil
	  (tagbody
	   start
	     (unless cons
	       (unless (< index (length table))
		 (return))
	       (setq cons (iref table (+ 2 index)))
	       (incf index)
	       (go start)))
	  (let ((pair (pop cons)))
	    (values t (car pair) (cdr pair)))))))
(defmacro with-hash-table-iterator ((name hash-table) &rest forms)
  (let ((iterator (gensym)))
    `(let ((,iterator (hash-table-iterator ,hash-table)))
      (macrolet ((,name ()
		   `(funcall ,,iterator)))
	,@forms))))
(defun clrhash (hash-table)
  (let ((table (hash-table-table hash-table)))
    (dotimes (index (length table))
      (setf (iref table (+ 2 index)) nil)))
  (setf (hash-table-count hash-table) 0)
  hash-table)
(defun hash-table-count (hash-table) (iref hash-table 2))
(defun (setf hash-table-count) (new-value hash-table)
  (setf (iref hash-table 2) new-value))
(defun hash-table-rehash-size (hash-table) (iref hash-table 3))
(defun hash-table-rehash-threshold (hash-table) (iref hash-table 4))
(defun hash-table-test (hash-table) (iref hash-table 5))
(defun hash-table-hash (hash-table) (iref hash-table 6))
(defun hash-table-table (hash-table) (iref hash-table 7))
(defun (setf hash-table-table) (new-value hash-table)
  (setf (iref hash-table 7) new-value))
(defparameter *class-hash* (make-hash-table))
(defun find-class (symbol &optional (errorp t) environment)
  (multiple-value-bind (class foundp)
      (gethash symbol *class-hash*)
    (when (and errorp (not foundp))
      (error "Class ~A not found." symbol))
    class))
(defun (setf find-class) (new-class symbol &optional (errorp t) environment)
  (setf (gethash symbol *class-hash*) new-class)
  new-class)
(setf (find-class 'hash-table) *hash-table*)
(defparameter *structure-object* (makei 1 *standard-class*))
(setf (find-class 'structure-object) *structure-object*)
(defparameter *built-in-class* (makei 1 *standard-class*))
(setf (find-class 't)
      (let ((class (makei 1 *built-in-class* (makei 7 3 't))))
	(setf (iref (iref class 2) 5) (list class))
	(setf (iref (iref class 2) 7) (list *structure-object*))
	class))
(setf (iref *structure-object* 2)
      (makei 7 3 'structure-object (list (find-class 't)) nil
	     (list *structure-object* (find-class 't))))
(defun make-boa-constructor (length struct-class slots lambda-list)
  (eval `#'(lambda ,lambda-list
	     (let ((s (makei ,length ',struct-class
			     ,@(mapcar #'(lambda (arg)
					   (cadr arg))
				       slots))))
	       ,@(mapcar #'(lambda (argument)
			     (unless (member argument lambda-list-keywords)
			       (let ((arg (if (consp argument)
					      (car argument)
					      argument)))
				 `(setf (iref s ,(+ 2 (position arg slots
								:key #'car)))
				   ,arg))))
			 lambda-list)
	       s))))
(defun ensure-struct (name options documentation slots)
  (flet ((option (option-name default)
	   (let ((pair (assoc option-name options)))
	     (if pair (cdr pair) default)))
	 (make-getter (i)
	   #'(lambda (x) (iref x i)))
	 (make-setter (i)
	   #'(lambda (v x) (setf (iref x i) v))))
    (let* ((struct-class (makei 1 *structure-class* (makei 7 3)))
	   (conc-name (option :conc-name (conc-string name "-")))
	   (constructor (option :constructor nil))
	   (predicate (option :predicate t))
	   (include (option :include nil))
	   (super (if (car include)
		      (find-class (car include))
		      *structure-object*))
	   (effective-slots
	    (append (unless (eq super *structure-object*)
		      (mapcar #'(lambda (slot)
				  (let ((m (member (car slot) (cdr include)
						   :key #'car)))
				    (if m (car m) slot)))
			      (iref (iref super 2) 6)))
		    slots)))
      (when (eq predicate t)
	(setq predicate (list (intern (conc-string name "-P")))))
      (when predicate
	(setf (fdefinition (car predicate))
	      #'(lambda (object) (and (= (ldb '(2 . 0) (ival object)) 2)
				      (eq struct-class (iref object 1))))))
      (unless constructor
	(setq constructor (list (intern (conc-string "MAKE-" name)))))
      (dolist (slot-description (cdr include))
	(let ((slot (assoc (car slot-description) effective-slots)))
	  (setf (cdr slot) (cdr slot-description))))
      (setf (iref (iref struct-class 2) 2) name)
      (setf (iref (iref struct-class 2) 3) (list super))
      (setf (iref (iref struct-class 2) 4) (length effective-slots))
      (setf (iref (iref struct-class 2) 5)
	    (cons struct-class (iref (iref super 2) 5)))
      (setf (iref (iref struct-class 2) 6) effective-slots)
      (when (car constructor)
	(setf (fdefinition (car constructor))
	      (make-boa-constructor (length effective-slots)
				    struct-class effective-slots
				    (cadr constructor))))
      (let ((i 2))
	(dolist (slot effective-slots)
	  (let ((accessor (intern (conc-string conc-name (car slot)))))
	    (setf (fdefinition accessor) (make-getter i))
	    (setf (fdefinition `(setf ,accessor)) (make-setter i))
	    (setf i (+ 1 i)))))
      (setf (find-class name) struct-class)))
  name)
(defmacro defstruct (name-and-options &rest slot-descriptions)
  (let ((options nil)
	(documentation nil)
	(slots nil))
    (when (consp name-and-options)
      (setf options (cdr name-and-options))
      (setf name-and-options (car name-and-options)))
    (when (stringp (car slot-descriptions))
      (setf documentation (pop slot-descriptions)))
  `(ensure-struct ',name-and-options ',(mapcar #'designator-list options)
    ,documentation ',(mapcar #'designator-list slot-descriptions))))
(defun copy-structure (structure)
  (let* ((length (iref structure 0))
	 (i 0)
	 (copy (makei length (iref structure 1))))
    (tagbody
     start
       (when (< i length)
	 (setf (iref copy (+ 2 i)) (iref structure (+ 2 i)))
	 (incf i)
	 (go start)))
    copy))
'restart-report-function
(defstruct (restart
	     (:constructor make-restart (name function
					      &key interactive-function
					      report-function test-function))
	     (:predicate restartp))
  name
  function
  interactive-function
  report-function
  test-function)
(defun ansi-stream-read-bytes (stream string start)
  (funcall (stream-class-read-bytes (ansi-stream-stream-class stream))
	   stream string start))
(defun ansi-stream-write-bytes (stream string start end)
  (funcall (stream-class-write-bytes (ansi-stream-stream-class stream))
	   stream string start end))
(defun ansi-stream-listen (stream)
  (funcall (stream-class-listen (ansi-stream-stream-class stream))
	   stream))
(defun ansi-stream-finish (stream flag)
  (funcall (stream-class-finish (ansi-stream-stream-class stream))
	   stream flag))
(defun ansi-stream-close (stream)
  (funcall (stream-class-close (ansi-stream-stream-class stream))
	   stream))
(defun fd-stream-read-bytes (stream string start)
  (read-file-stream (fd-stream-file-stream stream) string start))
(defun fd-stream-write-bytes (stream string start end)
  (write-file-stream (fd-stream-file-stream stream) string start end))
(defun fd-stream-listen (stream)
  (listen-file-stream (fd-stream-file-stream stream)))
(defun fd-stream-finish (stream flag)
  (finish-file-stream (fd-stream-file-stream stream)))
(defun fd-stream-close (stream)
  (close-file-stream (fd-stream-file-stream stream)))
(defun string-stream-read-bytes (stream string start)
  (let* ((length (min (- (length string) start)
		      (- (string-stream-end stream)
			 (string-stream-start stream))))
	 (end (+ (string-stream-start stream) length)))
    (setf (subseq string start)
	  (subseq (string-stream-string stream)
		  (string-stream-start stream) end))
    (setf (string-stream-start stream) end)
    length))
(defun string-stream-write-bytes (stream string start end)
  (let ((write-length (- end start))
	(stream-length (length (string-stream-string stream))))
    (when (< (- stream-length (string-stream-end stream)) write-length)
      (let* ((new-length (max (* 2 stream-length)
			     (+ stream-length write-length)))
	     (new-string (make-string new-length)))
	(setf (subseq new-string 0 (string-stream-end stream))
	      (string-stream-string stream))
	(setf (string-stream-string stream) new-string)))
    (let ((new-end (+ (string-stream-end stream) write-length)))
      (setf (subseq (string-stream-string stream)
		    (string-stream-end stream) new-end)
	    (subseq string start end))
      (setf (string-stream-end stream) new-end))
    write-length))
(defun string-stream-listen (stream) t)
(defun string-stream-finish (stream flag) nil)
(defun string-stream-close (stream) nil)
(defun concatenated-stream-read-bytes (stream string start)
  (let ((streams (concatenated-stream-streams stream)))
    (if streams
	(ansi-stream-read-bytes (car streams) string start)
	0)))
(defun concatenated-stream-write-bytes (stream string start end)
  (let ((streams (concatenated-stream-streams stream)))
    (if streams
	(ansi-stream-write-bytes (car streams) string start end)
	0)))
(defun concatenated-stream-listen (stream)
  (let ((streams (concatenated-stream-streams stream)))
    (if streams
	(ansi-stream-listen (car streams))
	t)))
(defun concatenated-stream-finish (stream flag)
  (let ((streams (concatenated-stream-streams stream)))
    (if streams
	(ansi-stream-finish (car streams) flag)
	nil)))
(defun concatenated-stream-close (stream) nil)
(defun echo-stream-read-bytes (stream string start)
  (let ((length (ansi-stream-read-bytes (echo-stream-input-stream stream)
					string start)))
    (ansi-stream-write-bytes (echo-stream-output-stream stream)
			     string start (+ start length))
    length))
(defun echo-stream-write-bytes (stream string start end)
  (ansi-stream-write-bytes (echo-stream-output-stream stream)
			   string start end))
(defun echo-stream-listen (stream)
  (ansi-stream-listen (echo-stream-input-stream stream)))
(defun echo-stream-finish (stream flag)
  (ansi-stream-finish (echo-stream-output-stream stream) flag))
(defun echo-stream-close (stream) nil)
(defun two-way-stream-read-bytes (stream string start)
  (ansi-stream-read-bytes (two-way-stream-input-stream stream) string start))
(defun two-way-stream-write-bytes (stream string start end)
  (ansi-stream-write-bytes (two-way-stream-output-stream stream)
			   string start end))
(defun two-way-stream-listen (stream)
  (ansi-stream-listen (two-way-stream-input-stream stream)))
(defun two-way-stream-finish (stream flag)
  (ansi-stream-finish (two-way-stream-output-stream stream) flag))
(defun two-way-stream-close (stream) nil)
(defun broadcast-stream-read-bytes (stream string start)
  (error "cannot read from a broadcast stream"))
(defun broadcast-stream-write-bytes (stream string start end)
  (dolist (s (broadcast-stream-streams stream))
    (ansi-stream-write-bytes s string start end)))
(defun broadcast-stream-listen (stream)
  (error "cannot listen a broadcast stream"))
(defun broadcast-stream-finish (stream flag)
  (dolist (s (broadcast-stream-streams stream))
    (ansi-stream-finish s flag)))
(defun broadcast-stream-close (stream) nil)
(defun synonym-stream-read-bytes (stream string start)
  (ansi-stream-read-bytes (symbol-value (synonym-stream-symbol stream))
			  string start))
(defun synonym-stream-write-bytes (stream string start end)
  (ansi-stream-write-bytes (symbol-value (synonym-stream-symbol stream))
			   string start end))
(defun synonym-stream-listen (stream)
  (ansi-stream-listen (symbol-value (synonym-stream-symbol stream))))
(defun synonym-stream-finish (stream flag)
  (ansi-stream-finish (symbol-value (synonym-stream-symbol stream)) flag))
(defun synonym-stream-close (stream) nil)
(defun init-known-streams ()
  (setq *fd-stream-class* (make-stream-class #'fd-stream-read-bytes
					     #'fd-stream-write-bytes
					     #'fd-stream-listen
					     #'fd-stream-finish
					     #'fd-stream-close))
  (setq *string-stream-class* (make-stream-class #'string-stream-read-bytes
						 #'string-stream-write-bytes
						 #'string-stream-listen
						 #'string-stream-finish
						 #'string-stream-close))
  (setq *concatenated-stream-class*
	(make-stream-class #'concatenated-stream-read-bytes
			   #'concatenated-stream-write-bytes
			   #'concatenated-stream-listen
			   #'concatenated-stream-finish
			   #'concatenated-stream-close))
  (setq *echo-stream-class* (make-stream-class #'echo-stream-read-bytes
					       #'echo-stream-write-bytes
					       #'echo-stream-listen
					       #'echo-stream-finish
					       #'echo-stream-close))
  (setq *two-way-stream-class* (make-stream-class #'two-way-stream-read-bytes
						  #'two-way-stream-write-bytes
						  #'two-way-stream-listen
						  #'two-way-stream-finish
						  #'two-way-stream-close))
  (setq *broadcast-stream-class*
	(make-stream-class #'broadcast-stream-read-bytes
			   #'broadcast-stream-write-bytes
			   #'broadcast-stream-listen
			   #'broadcast-stream-finish
			   #'broadcast-stream-close))
  (setq *synonym-stream-class* (make-stream-class #'synonym-stream-read-bytes
						  #'synonym-stream-write-bytes
						  #'synonym-stream-listen
						  #'synonym-stream-finish
						  #'synonym-stream-close))
  (setq *standard-input* (make-fd-stream :input *standard-input*))
  (setq *standard-output* (make-fd-stream :output *standard-output*))
  (setq *error-output* (make-fd-stream :output *error-output*))
  (setq *debug-io* (make-two-way-stream *standard-input* *standard-output*))
  nil)
(defstruct (stream-class
	     (:constructor make-stream-class (read-bytes write-bytes listen
							 finish close)))
  read-bytes
  write-bytes
  listen
  finish
  close)
(defun input-stream-p (stream)
  (member (ansi-stream-direction stream) '(:input :io)))
(defun output-stream-p (stream)
  (member (ansi-stream-direction stream) '(:output :io)))
(defun interactive-stream-p (stream) "FIXME" t)
(defun open-stream-p (stream) (not (null (iref stream 3))))
(defun stream-element-type (stream) 'character)
(defun streamp (object)
  (member (find-class 'ansi-stream)
	  (class-precedence-list (class-of object))))
(defun read-byte (stream &optional (eof-error-p t) eof-value)
  (let ((c (prim-read-char stream)))
    (if c
	(char-code c)
	(if eof-error-p (error 'end-of-file :stream stream) eof-value))))
(defun write-byte (byte stream)
  (ansi-stream-write-bytes stream
			   (make-string 1 :initial-element (code-char byte))
			   0 1)
  (setf (ansi-stream-line-start stream) (= byte 10))
  byte)
(defun prim-read-char (stream)
  (if (ansi-stream-unread stream)
      (prog1 (ansi-stream-unread stream)
	(setf (ansi-stream-unread stream) nil))
      (let ((string (make-string 1)))
	(when (= (ansi-stream-read-bytes stream string 0) 1)
	  (aref string 0)))))
(defun make-fd-stream (direction file-stream)
  (construct-fd-stream *fd-stream-class* direction file-stream))
(defstruct ansi-stream
  stream-class
  direction
  unread
  (line-start t))
(defstruct (fd-stream
	     (:constructor construct-fd-stream
			   (stream-class direction file-stream))
	     (:include ansi-stream))
  file-stream)
(defstruct (string-stream
	     (:constructor construct-string-stream
			   (stream-class direction string start end))
	     (:include ansi-stream))
  string
  start
  end)
(defstruct (concatenated-stream
	     (:constructor construct-concatenated-stream (stream-class streams))
	     (:include ansi-stream (direction :input)))
  streams)
(defstruct (echo-stream
	     (:constructor make-echo-stream (input-stream output-stream))
	     (:include ansi-stream
		       (stream-class *echo-stream-class*)
		       (direction :io)))
  input-stream
  output-stream)
(defstruct (two-way-stream
	     (:constructor make-two-way-stream (input-stream output-stream))
	     (:include ansi-stream
		       (stream-class *two-way-stream-class*)
		       (direction :io)))
  input-stream
  output-stream)
(defstruct (broadcast-stream
	     (:constructor construct-broadcast-stream (streams))
	     (:include ansi-stream
		       (stream-class *broadcast-stream-class*)
		       (direction :output)))
  streams)
(defstruct (synonym-stream
	     (:constructor make-synonym-stream (symbol))
	     (:include ansi-stream (stream-class *synonym-stream-class*)))
  symbol)
(defun designator-input-stream (input-stream)
  (if (streamp input-stream)
      input-stream
      *standard-input*))
(defun designator-output-stream (output-stream)
  (if (streamp output-stream)
      output-stream
      *standard-output*))
(defun peek-char (&optional peek-type (input-stream *standard-input*)
		  (eof-error-p t) eof-value recursive-p)
  (setq input-stream (designator-input-stream input-stream))
  (tagbody
   start
     (let ((c (prim-read-char input-stream)))
       (unless c (if eof-error-p
		     (error 'end-of-file :stream input-stream)
		     (return-from peek-char eof-value)))
       (when (or (not peek-type)
		 (and (characterp peek-type) (char= c peek-type))
		 (not (eq (aref (readtable-function *readtable*) (char-code c))
			  :whitespace)))
	 (unread-char c input-stream)
	 (return-from peek-char c)))
     (go start)))
(defun read-char (&optional (input-stream *standard-input*) (eof-error-p t)
		  eof-value recursive-p)
  (setq input-stream (designator-input-stream input-stream))
  (or (prim-read-char input-stream)
      (if eof-error-p (error 'end-of-file :stream input-stream) eof-value)))
(defun read-char-no-hang (&optional (input-stream *standard-input*)
			  (eof-error-p t) eof-value recursive-p)
  (setq input-stream (designator-input-stream input-stream))
  (if (ansi-stream-unread input-stream)
      (prog1 (ansi-stream-unread input-stream)
	(setf (ansi-stream-unread input-stream) nil))
      (and (listen-file-stream input-stream)
	   (read-char input-stream eof-error-p eof-value recursive-p))))
(defun terpri (&optional (output-stream *standard-output*))
  (setq output-stream (designator-output-stream output-stream))
  (write-byte 10 output-stream)
  nil)
(defun fresh-line (&optional (output-stream *standard-output*))
  (setq output-stream (designator-output-stream output-stream))
  (and (not (ansi-stream-line-start output-stream))
       (write-byte 10 output-stream)))
(defun unread-char (character &optional (input-stream *standard-input*))
  (setq input-stream (designator-input-stream input-stream))
  (setf (ansi-stream-unread input-stream) character))
(defun write-char (character &optional (output-stream *standard-output*))
  (setq output-stream (designator-output-stream output-stream))
  (write-file-stream (make-string 1 :initial-character character) 0 1)
  (setf (ansi-stream-line-start output-stream) (= (char-code character) 10))
  character)
(defun read-line (&optional (input-stream *standard-input*) (eof-error-p t)
		  eof-value recursive-p)
  (setq input-stream (designator-input-stream input-stream))
  (let ((result nil)
	(end nil))
    (tagbody
     start
       (let ((c (read-char input-stream eof-error-p eof-value recursive-p)))
	 (unless c
	   (if eof-error-p
	       (error 'end-of-file :stream input-stream)
	       (return-from read-line
		 (values (when result (apply #'string result)) t))))
	 (unless (= (char-code c) 10)
	   (setf end (if end
			 (setf (cdr end) (list c))
			 (setf result (list c))))
	   (go start))))
    (apply #'string result)))
(defun write-string (string &optional (output-stream *standard-output*)
		     &key (start 0) (end nil))
  (setq output-stream (designator-output-stream output-stream))
  (unless end (setf end (length string)))
  (when (< start end)
    (ansi-stream-write-bytes output-stream string start end)
    (setf (ansi-stream-line-start output-stream)
	  (= (char-code (aref string (- end 1))) 10)))
  string)
(defun write-line (string &optional (output-stream *standard-output*)
		   &key (start 0) (end nil))
  (setq output-stream (designator-output-stream output-stream))
  (unless end (setf end (length string)))
  (ansi-stream-write-bytes output-stream string start end)
  (ansi-stream-write-bytes output-stream
			   (make-string 1 :initial-element (code-char 10))
			   0 1)
  (setf (ansi-stream-line-start output-stream) t)
  string)
(defun read-sequence (sequence stream &key (start 0) end)
  (if (eq (type-of sequence) 'string)
      (+ start (ansi-stream-read-bytes stream sequence start))
      (let ((index start))
	(tagbody
	 start
	   (when (< index end)
	     (let ((byte (read-byte stream nil nil)))
	       (when byte
		 (setf (aref sequence index) byte)
		 (setf index (+ 1 index))
		 (go start)))))
	index)))
(defun write-sequence (sequence stream &key (start 0) end)
  (if (eq (type-of sequence) 'string)
      (write-string sequence stream start end)
      (let ((index start))
	(unless end (setf end (length sequence)))
	(tagbody
	 start
	   (when (< index end)
	     (write-byte (aref sequence index) stream)
	     (setf index (+ 1 index))
	     (go start)))
	sequence)))
(defun file-length (stream)
  "FIXME"
  nil)
(defun file-position (stream &optional position-spec)
  "FIXME"
  nil)
(defun file-string-length (stream object)
  (if (stringp object)
      (length object)
      1))
(defun open (filespec &key (direction :input) (element-type 'character)
	     (if-exists :new-version) (if-does-not-exist "FIXME")
	     (external-format :default))
  (make-fd-stream direction
		  (make-file-stream filespec (eq direction :output))))
(defun stream-external-format (stream)
  :default)
(defmacro with-open-file ((stream filespec &rest options) &rest body)
  `(let ((,stream (open ,filespec ,@options)))
    (unwind-protect
	 (progn ,@body)
      (close ,stream))))
(defun close (stream &key abort)
  (ansi-stream-close stream)
  t)
(defmacro with-open-stream ((var stream) &rest body)
  `(let ((,var ,stream))
    (unwind-protect
	 (progn ,@body)
      (close ,var))))
(defun listen (&optional (input-stream *standard-input*))
  (setq input-stream (designator-input-stream input-stream))
  (ansi-stream-listen input-stream))
(defun clear-input (&optional (input-stream *standard-input*))
  (setq input-stream (designator-input-stream input-stream))
  (tagbody
   start
     (when (peek-char nil input-stream)
       (read-char input-stream)
       (go start))))
(defun finish-output (&optional (output-stream *standard-output*))
  (setq output-stream (designator-output-stream output-stream))
  (ansi-stream-finish output-stream :finish))
(defun force-output (&optional (output-stream *standard-output*))
  (setq output-stream (designator-output-stream output-stream))
  (ansi-stream-finish output-stream :force))
(defun clear-output (&optional (output-stream *standard-output*))
  (setq output-stream (designator-output-stream output-stream))
  (ansi-stream-finish output-stream :clear))
(defun y-or-n-p (&optional control &rest arguments)
  (when control
    (fresh-line *query-io*)
    (apply #'format *query-io* control arguments))
  (write-string " (Y or N) " *query-io*)
  (member (read-byte *query-io*) '(89 121)))
(defun yes-or-no-p (&optional control &rest arguments)
  (when control
    (fresh-line *query-io*)
    (apply #'format *query-io* control arguments))
  (write-string " (Yes or No) " *query-io*)
  (string= (read-line *query-io*) "yes"))
(defun make-broadcast-stream (&rest streams)
  (construct-broadcast-stream streams))
(defun make-concatenated-stream (&rest input-streams)
  (construct-concatenated-stream *concatenated-stream-class* input-streams))
(defun make-string-input-stream (string &optional (start 0) end)
  (unless end (setq end (length string)))
  (construct-string-stream *string-stream-class* :input string start end))
(defmacro with-input-from-string ((var string &key index (start 0) end)
				  &rest forms)
  `(let ((,var (make-string-input-stream ,string ,start ,end)))
    (unwind-protect
	 (progn ,@forms)
      ,@(when index `(setf ,place (string-stream-start ,var)))
      (close ,var))))
(defun make-string-output-stream (&key (element-type 'character))
  (let ((string (make-string 256)))
    (construct-string-stream *string-stream-class* :output string 0 0)))
(defun get-output-stream-string (string-output-stream)
  (prog1
      (subseq (string-stream-string string-output-stream)
	      0 (string-stream-end string-output-stream))
    (setf (string-stream-end string-output-stream) 0)))
(defmacro with-output-to-string ((var &optional string-form
				      &key (element-type 'character))
				 &rest forms)
  `(let ((,var (make-string-output-stream :element-type ',element-type)))
    (unwind-protect
	 (progn ,@forms)
      (close ,var))
    (get-output-stream-string ,var)))
(defun make-standard-pprint-dispatch ()
  nil)
(defparameter *standard-pprint-dispatch* (make-standard-pprint-dispatch))
(defparameter *print-array* t)
(defparameter *print-base* 10)
(defparameter *print-radix* nil)
(defparameter *print-case* :upcase)
(defparameter *print-circle* nil)
(defparameter *print-escape* t)
(defparameter *print-gensym* t)
(defparameter *print-level* nil)
(defparameter *print-length* nil)
(defparameter *print-lines* nil)
(defparameter *print-miser-width* 40)
(defparameter *print-pprint-dispatch* *standard-pprint-dispatch*)
(defparameter *print-pretty* nil)
(defparameter *print-readably* nil)
(defparameter *print-right-margin* nil)
(defun write (object &key (array *print-array*) (base *print-base*)
	      (case *print-case*) (circle *print-circle*)
	      (escape *print-escape*) (gensym *print-gensym*)
	      (length *print-length*) (level *print-level*)
	      (lines *print-lines*) (miser-width *print-miser-width*)
	      (pprint-dispatch *print-pprint-dispatch*) (pretty *print-pretty*)
	      (radix *print-radix*) (readably *print-readably*)
	      (right-margin *print-right-margin*) (stream *standard-output*))
  (let ((*print-array* array)
	(*print-base* base)
	(*print-case* case)
	(*print-circle* circle)
	(*print-escape* escape)
	(*print-gensym* gensym)
	(*print-length* length)
	(*print-level* level)
	(*print-lines* lines)
	(*print-miser-width* miser-width)
	(*print-pprint-dispatch* pprint-dispatch)
	(*print-pretty* pretty)
	(*print-radix* radix)
	(*print-readably* readably)
	(*print-right-margin* right-margin))
    (if *print-pretty*
	(error "pretty printer not implemented")
	(print-object object stream)))
  object)
(defun prin1 (object &optional (output-stream *standard-output*))
  (write object :stream output-stream :escape t))
(defun princ (object &optional (output-stream *standard-output*))
  (write object :stream output-stream :escape nil :readably nil))
(defun write-to-string (object &rest rest)
  (with-output-to-string (stream)
    (apply #'write object :stream stream rest)))
(defun prin1-to-string (object)
  (with-output-to-string (*standard-output*)
    (prin1 object)))
(defun princ-to-string (object)
  (with-output-to-string (*standard-output*)
    (princ object)))
(defun parse-control-string (control-string)
  (let ((result nil)
	(i 0)
	(j nil))
    (tagbody
     start
       (when (< i (length control-string))
	 (when (= (char-code (aref control-string i)) 126)
	   (when j (push (subseq control-string j i) result))
	   (setf i (+ 1 i))
	   (let ((code (char-code (char-upcase (aref control-string i))))
		 (colonp nil)
		 (atp nil)
		 (args nil))
	     (tagbody
	      next
		(case code
		  (39 (push (aref control-string (incf i)) args)
		      (incf i))
		  (44 (incf i))
		  (58 (setq colonp t)
		      (incf i))
		  (64 (setq atp t)
		      (incf i))
		  ((43 45 48 49 50 51 52 53 54 55 56 57)
		   (multiple-value-bind (integer pos)
		       (parse-integer control-string :start i :junk-allowed t)
		     (setq i pos)
		     (push integer args)))
		  (t
		   (push (list* code colonp atp (reverse args)) result)
		   (go end)))
		(setq code (char-code (char-upcase (aref control-string i))))
		(go next)
	      end))
	   (setf j (+ 1 i)))
	 (unless j (setf j i))
	 (setf i (+ 1 i))
	 (go start))
       (when (< j i)
	 (push (subseq control-string j i) result)))
    (reverse result)))
(defun format-function (control-string)
  #'(lambda (output-stream &rest arguments)
      (let ((program (parse-control-string control-string)))
	(dolist (elem program)
	  (if (stringp elem)
	      (write-string elem output-stream)
	      (let ((colonp (cadr elem))
		    (atp (caddr elem))
		    (params (cdddr elem)))
		(case (car elem)
		  (37 (dotimes (n (or (car params) 1))
			(terpri output-stream)))
		  (38 (fresh-line output-stream)
		      (dotimes (n (- (or (car params) 1) 1))
			(terpri output-stream)))
		  (65 (princ (pop arguments) output-stream))
		  (66 (let ((*print-radix* nil)
			    (*print-base* 2))
			(princ (pop arguments) output-stream)))
		  (67 (write-char (pop arguments) output-stream))
		  (68 (let ((*print-radix* nil)
			    (*print-base* 10))
			(princ (pop arguments) output-stream)))
		  (79 (let ((*print-radix* nil)
			    (*print-base* 8))
			(princ (pop arguments) output-stream)))
		  (82 (let ((*print-radix* nil)
			    (*print-base* (car params)))
			(princ (pop arguments) output-stream)))
		  (83 (prin1 (pop arguments) output-stream))
		  (87 (write (pop arguments) :stream output-stream))
		  (88 (let ((*print-radix* nil)
			    (*print-base* 16))
			(princ (pop arguments) output-stream)))
		  (124 (dotimes (n (or (car params) 1))
			 (write-byte 12 output-stream)))
		  (126 (dotimes (n (or (car params) 1))
			 (write-byte 126 output-stream)))
		  (t (error "unimplemented format character")))))))))
(defmacro formatter (control-string)
  `(format-function ,control-string))
(defmacro print-unreadable-object ((object stream &key type identity)
				   &rest forms)
  (let ((object-var (gensym))
	(stream-var (gensym))
	(typep (gensym))
	(identityp (gensym)))
    `(if *print-readably*
      (error 'print-not-readable :object object)
      (let ((,object-var ,object)
	    (,stream-var ,stream)
	    (,typep ,type)
	    (,identityp ,identity))
	(write-string "#<" ,stream-var)
	(when ,typep
	  (princ (type-of ,object-var) ,stream-var)
	  (write-byte 32 ,stream-var))
	,@forms
	(when ,identityp
	  (unless (and ,(not forms) ,typep)
	    (write-byte 32 ,stream-var))
	  (princ (ival ,object-var) ,stream-var))
	(write-string ">" ,stream-var)
	nil))))
(defun format (destination control-string &rest args)
  (if destination
      (progn (apply (formatter control-string) destination args) nil)
      (with-output-to-string (destination)
	(apply (formatter control-string) destination args))))
(defmacro with-standard-io-syntax (&rest forms)
  `(let ((*package* (find-package "CL-USER"))
	 (*print-array* t)
	 (*print-base* 10)
	 (*print-case* :upcase)
	 (*print-circle* nil)
	 (*print-escape* t)
	 (*print-gensym* t)
	 (*print-length* nil)
	 (*print-level* nil)
	 (*print-lines* nil)
	 (*print-miser-width* nil)
	 (*print-pprint-dispatch* *standard-pprint-dispatch*)
	 (*print-pretty* nil)
	 (*print-radix* nil)
	 (*print-readably* t)
	 (*print-right-margin* nil)
	 (*read-base* 10)
	 (*read-default-float-format* 'single-float)
	 (*read-eval* t)
	 (*read-suppress* nil)
	 (*readtable* *standard-readtable*))
    ,@forms))
(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable)
  (unless to-readtable
    (setq to-readtable (make-readtable)))
  (setf (readtable-case to-readtable) (readtable-case from-readtable))
  (setf (readtable-function to-readtable)
	(copy-sequence (readtable-function from-readtable)))
  (let ((i 0))
    (tagbody
     start
       (when (< i 256)
	 (when (arrayp (aref (readtable-function to-readtable) i))
	   (setf (aref (readtable-function to-readtable) i)
		 (copy-sequence (aref (readtable-function to-readtable) i))))
	 (incf i)
	 (go start))))
  (setf (readtable-non-terminating-p to-readtable)
	(copy-sequence (readtable-non-terminating-p from-readtable)))
  to-readtable)
(defun make-dispatch-macro-character (char &optional non-terminating-p
				      (readtable *readtable*))
  (let ((code (char-code char)))
    (setf (aref (readtable-function readtable) code) (make-array 256))
    (setf (aref (readtable-non-terminating-p readtable) code)
	  non-terminating-p))
  t)
(defun parse-integer (string &key (start 0) end (radix 10) junk-allowed)
  (unless end (setq end (length string)))
  (let ((state :sign)
	(minusp nil)
	(digits nil))
    (flet ((finish ()
	     (return-from parse-integer
	       (values (let ((n 0))
			 (dolist (digit (reverse digits) (if minusp (- n) n))
			   (setq n (+ digit (* radix n)))))
		       start))))
      (tagbody
       start
	 (when (< start end)
	   (let* ((char (aref string start))
		  (c (char-code char)))
	     (case state
	       (:sign (setq state :integer-start)
		      (case c
			(45 (setq minusp t))
			(43)
			(t (go start))))
	       ((:integer-start :integer)
		(setq state :integer)
		(let ((w (digit-char-p char radix)))
		  (if w
		      (push w digits)
		      (if junk-allowed
			  (finish)
			  (error 'parse-error)))))))
	 (incf start)
	 (go start)))
      (when (member state '(:sign :integer-start))
	(error 'parse-error))
      (finish))))
(defun parse-number (string &key (start 0) end)
  (unless end (setq end (length string)))
  (let ((state :sign)
	(minusp nil)
	(digits nil)
	(exponent nil)
	(exponent-minusp nil)
	(exponent-digits nil)
	(fraction-digits nil))
    (tagbody
     start
       (when (< start end)
	 (let* ((char (aref string start))
		(c (char-code char)))
	   (case state
	     (:sign (setq state :integer-start)
		    (case c
		      (45 (setq minusp t))
		      (43)
		      (t (go start))))
	     (:integer-start (if (= c 46)
				 (setq state :after-point)
				 (progn
				   (setq state :integer)
				   (push (digit-char-p char *read-base*)
					 digits))))
	     (:integer (case c
			 (46 (setq state :after-point))
			 (47 (setq state :denominator))
			 ((68 100)
			  (setq exponent :double)
			  (setq state :exponent-sign))
			 ((69 101)
			  (setq exponent :float)
			  (setq state :exponent-sign))
			 ((70 102)
			  (setq exponent :single-float)
			  (setq state :exponent-sign))
			 ((76 108)
			  (setq exponent :long-float)
			  (setq state :exponent-sign))
			 ((83 115)
			  (setq exponent :short-float)
			  (setq state :exponent-sign))
			 (t (push (digit-char-p char *read-base*) digits))))
	     ((:after-point :fraction)
	      (setq state :fraction)
	      (case c
		((68 100)
		 (setq exponent :double)
		 (setq state :exponent-sign))
		((69 101)
		 (setq exponent :float)
		 (setq state :exponent-sign))
		((70 102)
		 (setq exponent :single-float)
		 (setq state :exponent-sign))
		((76 108)
		 (setq exponent :long-float)
		 (setq state :exponent-sign))
		((83 115)
		 (setq exponent :short-float)
		 (setq state :exponent-sign))
		(t (push (digit-char-p char *read-base*) fraction-digits))))
	     (:denominator (push (digit-char-p char *read-base*)
				 fraction-digits))
	     (:exponent-sign (setq state :exponent)
			     (case c
			       (45 (setq exponent-minusp t))
			       (43)
			       (t (go start))))
	     (:exponent (push (digit-char-p char *read-base*)
			      exponent-digits))))
	 (incf start)
	 (go start)))
    (case state
      ((:integer :after-point)
       (let ((n 0))
	 (dolist (digit (reverse digits) (if minusp (- n) n))
	   (setq n (+ digit (* *read-base* n))))))
      (:denominator (list :ratio (reverse digits) (reverse fraction-digits)))
      ((:fraction :exponent)
       (list exponent (reverse digits) (reverse fraction-digits)
	     (reverse exponent-digits)))
      (t (error 'reader-error)))))
(defun read (&optional input-stream (eof-error-p t) eof-value recursive-p)
  (let ((value (read-internal input-stream eof-error-p eof-value recursive-p
			      nil nil t)))
    (if *read-suppress* nil value)))
(defun read-internal (input-stream eof-error-p eof-value recursive-p
		      preserving-whitespace token-chars convertp)
  (let* ((function (readtable-function *readtable*))
	 (non-terminating-p (readtable-non-terminating-p *readtable*))
	 (case (readtable-case *readtable*))
	 (symbol nil)
	 (c nil)
	 (f nil))
    (tagbody
       (when token-chars (go even))
     start
       (setq c (read-char input-stream eof-error-p eof-value recursive-p))
       (setq f (aref function (char-code c)))
       (when (eq f :whitespace)
	 (go start))
       (when (or (arrayp f) (functionp f))
	 (let ((values (multiple-value-list
			(if (arrayp f)
			    (let ((infix nil))
			      (tagbody
			       start
				 (setq c (read-char input-stream t nil t))
				 (let ((w (digit-char-p c)))
				   (when w
				     (setq infix (+ (* 10 (or infix 0)) w))
				     (go start))))
			      (funcall (aref f (char-code c))
				       input-stream c infix))
			    (funcall f input-stream c)))))
	   (if values
	       (return-from read-internal (car values))
	       (go start))))
       (when (eq f :single-escape)
	 (push (read-char input-stream t nil recursive-p) token-chars)
	 (go even))
       (when (eq f :multiple-escape)
	 (go odd))
     push
       (push (case case
	       (:upcase (char-upcase c))
	       (:downcase (char-downcase c))
	       (t c))
	     token-chars)
     even
       (setq c (read-char input-stream nil nil recursive-p))
       (unless c
	 (go token))
       (setq f (aref function (char-code c)))
       (when (or (not f) (aref non-terminating-p (char-code c)))
	 (go push))
       (when (eq f :single-escape)
	 (setq symbol t)
	 (push (read-char input-stream t nil recursive-p) token-chars)
	 (go even))
       (when (eq f :multiple-escape)
	 (setq symbol t)
	 (go odd))
       (when (or preserving-whitespace (functionp f))
	 (unread-char c input-stream))
       (go token)
     odd
       (setq c (read-char input-stream t nil recursive-p))
       (setq f (aref function (char-code c)))
       (when (eq f :single-escape)
	 (push (read-char input-stream t nil recursive-p) token-chars)
	 (go odd))
       (when (eq f :multiple-escape)
	 (go even))
       (push c token-chars)
       (go odd)
     token
       (when (member (char-code (car token-chars)) '(43 45))
	 (setq symbol t))
       (let ((point nil)
	     (low-digit nil)
	     (high-digit nil)
	     (previous-alphabetic nil))
	 (dolist (char token-chars)
	   (when (= (char-code char) 46)
	     (setq point t))
	   (let ((weight (digit-char-p char *read-base*)))
	     (when weight
	       (if (< weight 10)
		   (setq low-digit t)
		   (setq high-digit t))))
	   (let ((alphabetic (alpha-char-p char)))
	     (when (and previous-alphabetic alphabetic)
	       (setq symbol t))
	     (setq previous-alphabetic alphabetic)))
	 (unless (or low-digit (and high-digit (not point)))
	   (setq symbol t)))
       (let ((string (apply #'string (reverse token-chars))))
	 (return-from read-internal
	   (if convertp
	       (if symbol
		   (let ((colon-position (position (code-char 58) string)))
		     (if colon-position
			 (multiple-value-bind (symbol status)
			     (find-symbol (subseq string (+ 1 colon-position))
					  (subseq string 0 colon-position))
			   (if (eq status :external)
			       symbol
			       (error 'reader-error)))
			 (intern string)))
		   (parse-number string))
	       string))))))
(defun read-preserving-whitespace (&optional input-stream (eof-error-p t)
				   eof-value recursive-p)
  (let ((value (read-internal input-stream eof-error-p eof-value recursive-p
			      t nil t)))
    (if *read-suppress* nil value)))
(defun read-delimited-list (char &optional input-stream recursive-p)
  (let ((result nil))
    (tagbody
     start
       (let ((c (peek-char t input-stream t nil t)))
	 (when (char= c char)
	   (read-char input-stream)
	   (return-from read-delimited-list (reverse result))))
       (push (read input-stream t nil t) result)
       (go start))))
(defun read-from-string (string &optional (eof-error-p t) eof-value
			 &key (start 0) end preserve-whitespace)
  (let ((index nil))
    (values (with-input-from-string (stream string :index index
					    :start start :end end)
	      (if preserve-whitespace
		  (read-preserving-whitespace stream eof-error-p eof-value)
		  (read stream eof-error-p eof-value)))
	    index)))
(defun get-dispatch-macro-character (disp-char sub-char
				     &optional (readtable *readtable*))
  (aref (aref (readtable-function readtable) (char-code disp-char))
	(char-code sub-char)))
(defun set-dispatch-macro-character (disp-char sub-char new-function
				     &optional (readtable *readtable*))
  (setf (aref (aref (readtable-function readtable) (char-code disp-char))
	      (char-code sub-char))
	new-function)
  t)
(defun get-macro-character (char &optional (readtable *readtable*))
  (let* ((code (char-code char))
	 (value (aref (readtable-function readtable) code)))
    (if (functionp value)
	(values value (aref (readtable-non-terminating-p readtable) code))
	(values nil nil))))
(defun set-macro-character (char new-function &optional non-terminating-p
			    (readtable *readtable*))
  (let ((code (char-code char)))
    (setf (aref (readtable-function readtable) code) new-function)
    (setf (aref (readtable-non-terminating-p readtable) code)
	  non-terminating-p))
  t)
(defun set-syntax-from-char (to-char from-char
			     &optional (to-readtable *readtable*)
			     (from-readtable *standard-readtable*))
  (let* ((to-code (char-code to-char))
	 (from-code (char-code from-char))
	 (value (aref (readtable-function from-readtable) from-code)))
    (setf (aref (readtable-function to-readtable) to-code)
	  (if (arrayp value)
	      (copy-sequence value)
	      value))
    (setf (aref (readtable-non-terminating-p to-readtable) to-code)
	  (aref (readtable-non-terminating-p from-readtable) from-code)))
  t)
(defparameter *features*
  '(:ieee-floating-point :ansi-cl :common-lisp :lisp500))
(defun featurep (test)
  (when (consp test)
    (case (car test)
      (:not (return-from featurep (not (featurep (cadr test)))))
      (:and (return-from featurep (every #'featurep (cdr test))))
      (:or (return-from featurep (some #'featurep (cdr test))))))
  (member test *features*))
(defparameter *uname* (uname))
(let ((sysname (car *uname*)))
  (cond
    ((fixnump sysname) (push :windows *features*))
    ((string= sysname "Linux") (push :linux *features*))
    ((and (>= (length sysname) 6) (string= (subseq sysname 0 6) "CYGWIN"))
     (push :cygwin *features*))))
(defun make-standard-readtable ()
  (let ((readtable (make-readtable))
	(function (make-array 256))
	(non-terminating-p (make-array 256))
	(i 0))
    (setf (readtable-function readtable) function)
    (setf (readtable-non-terminating-p readtable) non-terminating-p)
    (tagbody
     start
       (when (< i 33)
	 (setf (aref function i) :whitespace)
	 (incf i)
	 (go start)))
    (setq i 128)
    (tagbody
     start
       (when (< i 160)
	 (setf (aref function i) :whitespace)
	 (incf i)
	 (go start)))
    (setf (aref function 8) nil)
    (setf (aref function 92) :single-escape)
    (setf (aref function 124) :multiple-escape)
    (set-macro-character (code-char 34)
			 #'(lambda (stream char)
			     (let ((result nil)
				   (function (readtable-function *readtable*)))
			       (tagbody
				start
				  (let ((c (read-char stream)))
				    (unless (char= c char)
				      (if (eq (aref function (char-code c))
					      :single-escape)
					  (push (read-char stream) result)
					  (push c result))
				      (go start))))
			       (apply #'string (reverse result))))
			 nil readtable)
    (set-macro-character (code-char 39)
			 #'(lambda (stream char)
			     (list 'quote (read stream t nil t)))
			 nil readtable)
    (set-macro-character (code-char 40)
			 #'(lambda (stream char)
			     (read-delimited-list (code-char 41) stream t))
			 nil readtable)
    (set-macro-character (code-char 41)
			 #'(lambda (stream char)
			     (error 'read-error))
			 nil readtable)
    (set-macro-character (code-char 59)
			 #'(lambda (stream char)
			     (when (peek-char (code-char 10) stream nil nil t)
			       (read-char stream))
			     (values))
			 nil readtable)
    (set-macro-character (code-char 96)
			 #'(lambda (stream char)
			     (list 'backquote (read stream t nil t)))
			 nil readtable)
    (set-macro-character (code-char 44)
			 #'(lambda (stream char)
			     (if (= (char-code (peek-char nil stream t nil t))
				    64)
				 (progn
				   (read-char stream)
				   (list 'unquote-splicing
					 (read stream t nil t)))
				 (list 'unquote (read stream t nil t))))
			 nil readtable)
    (make-dispatch-macro-character (code-char 35) t readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 39)
				  #'(lambda (stream sub-char infix)
				      (list 'function (read stream t nil t)))
				  readtable)
    (set-dispatch-macro-character
     (code-char 35) (code-char 40)
     #'(lambda (stream sub-char infix)
	 (let* ((elements (read-delimited-list (code-char 41) stream t))
		(length (length elements))
		(vector (make-array (or infix length)
				    :initial-contents elements)))
	   (when (and infix (< length infix))
	     (fill vector (aref vector (- length 1)) :start length))
	   vector))
     readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 41)
				  #'(lambda (stream sub-char infix)
				      (error 'reader-error))
				  readtable)
    (set-dispatch-macro-character
     (code-char 35) (code-char 42)
     #'(lambda (stream sub-char infix)
	 (let* ((char (read-char stream t nil t))
		(token (unless (eq :whitespace
				   (aref (readtable-function *readtable*)
					 (char-code char)))
			 (read-internal stream t nil t nil (list char) nil)))
		(length (length token))
		(vector (make-array (or infix length) :element-type 'bit
				    :initial-contents token)))
	   (when (and infix (< length infix))
	     (fill vector (aref vector (- length 1)) :start length))
	   vector))
     readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 43)
				  #'(lambda (stream sub-char infix)
				      (if (featurep (read stream t nil t))
					  (read stream t nil t)
					  (let ((*read-suppress* t))
					    (read stream t nil t)
					    (values))))
				  readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 45)
				  #'(lambda (stream sub-char infix)
				      (if (featurep (read stream t nil t))
					  (let ((*read-suppress* t))
					    (read stream t nil t)
					    (values))
					  (read stream t nil t)))
				  readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 46)
				  #'(lambda (stream sub-char infix)
				      (if *read-eval*
					  (eval (read stream t nil t))
					  (error 'reader-error)))
				  readtable)
    (set-dispatch-macro-character
     (code-char 35) (code-char 58)
     #'(lambda (stream sub-char infix)
	 (make-symbol (read-internal stream t nil t nil nil nil)))
     readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 60)
				  #'(lambda (stream sub-char infix)
				      (error 'reader-error))
				  readtable)
    (set-dispatch-macro-character
     (code-char 35) (code-char 65)
     #'(lambda (stream sub-char infix)
	 (let* ((initial-contents (read stream t nil t))
		(sequence initial-contents)
		(dimensions nil)
		(i 0))
	   (tagbody
	    start
	      (when (< i infix)
		(push (length sequence) dimensions)
		(setq sequence (elt sequence 0))
		(incf i)
		(go start)))
	   (make-array (reverse dimensions)
		       :initial-contents initial-contents)))
     readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 66)
				  #'(lambda (stream sub-char infix)
				      (let ((*read-base* 2))
					(read stream t nil t)))
				  readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 79)
				  #'(lambda (stream sub-char infix)
				      (let ((*read-base* 8))
					(read stream t nil t)))
				  readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 80)
				  #'(lambda (stream sub-char infix)
				      (parse-namestring (read stream t nil t)))
				  readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 82)
				  #'(lambda (stream sub-char infix)
				      (let ((*read-base* infix))
					(read stream t nil t)))
				  readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 83)
				  #'(lambda (stream sub-char infix)
				      (let ((list (read stream t nil t)))
					(apply (conc-string "make-" (car list))
					       (cdr list))))
				  readtable)
    (set-dispatch-macro-character (code-char 35) (code-char 88)
				  #'(lambda (stream sub-char infix)
				      (let ((*read-base* 16))
					(read stream t nil t)))
				  readtable)
    (set-dispatch-macro-character
     (code-char 35) (code-char 92)
     #'(lambda (stream sub-char infix)
	 (let* ((c0 (read-char stream t nil t))
		(c1 (read-char stream t nil t)))
	   (if (eq (aref (readtable-function *readtable*) (char-code c1))
		   :whitespace)
	       c0
	       (progn
		 (unread-char c1 stream)
		 (name-char (read-internal stream t nil t nil
					   (list c0) nil))))))
     readtable)
    (set-dispatch-macro-character
     (code-char 35) (code-char 124)
     #'(lambda (stream sub-char infix)
	 (let* ((c0 (read-char stream t nil t))
		(c1 (read-char stream t nil t))
		(level 1))
	   (tagbody
	    start
	      (when (and (= (char-code c0) 35) (= (char-code c1) 124))
		(incf level))
	      (when (and (= (char-code c0) 124) (= (char-code c1) 35))
		(decf level))
	      (when (plusp level)
		(setq c0 c1)
		(setq c1 (read-char stream t nil t))
		(go start))))
	 (values))
     readtable)
    readtable))
(defstruct (readtable
	     (:predicate readtablep))
  (case :upcase)
  function
  non-terminating-p)
(defparameter *standard-readtable* (make-standard-readtable))
(defparameter *read-base* 10)
(defparameter *read-default-float-format* 'single-float)
(defparameter *read-eval* t)
(defparameter *read-suppress* nil)
(defparameter *readtable* *standard-readtable*)
(defun lisp-implementation-type () "lisp500")
(defun lisp-implementation-version () "0.2004.05.11.0")
(defun ensure-method-combination-long (name lambda-list method-group-specifiers
				       args-lambda-list generic-function-symbol
				       forms)
  (values name lambda-list method-group-specifiers args-lambda-list
	  generic-function-symbol forms))
(defmacro define-method-combination (name &rest options)
  (if (and options (listp (car options)))
      (do ((forms (cddr options) (cdr forms))
	   (args-lambda-list nil)
	   (generic-function-symbol nil))
	  ((not (member (caar forms) '(:arguments :generic-function)))
	   `(ensure-method-combination-long ',name ',(car options)
	     ',(cadr options) ',args-lambda-list ',generic-function-symbol
	     ',forms))
	(case (caar forms)
	  (:arguments (setq args-lambda-list (cdar forms)))
	  (:generic-function (setq generic-function-symbol (cdar forms)))))
      `(ensure-method-combination-short ',name ',options)))
(defmacro defclass (class-name superclass-names slot-specifiers
		    &rest class-options)
  `(ensure-class ',class-name :direct-superclasses ',superclass-names
    :direct-slots
    (list ,@(mapcar #'(lambda (slot)
			(setq slot (designator-list slot))
			(let* ((unbound (gensym))
			       (readers nil)
			       (writers nil)
			       (initargs nil)
			       (initform unbound)
			       (rest nil))
			  (do ((options (cdr slot) (cddr options)))
			      ((not options))
			    (case (car options)
			      (:reader (push (cadr options) readers))
			      (:writer (push (cadr options) writers))
			      (:accessor
			       (push (cadr options) readers)
			       (push `(setf ,(cadr options)) writers))
			      (:initarg (push (cadr options) initargs))
			      (:initform (setq initform (cadr options)))
			      (t (push `',(cadr options) rest)
				 (push `',(car options) rest))))
			  `(list :name ',(car slot)
			    ,@(when readers `(:readers ',readers))
			    ,@(when writers `(:writers ',writers))
			    ,@(when initargs `(:initargs ',initargs))
			    ,@(unless (eq initform unbound)
				      `(:initform ',initform
					:initfunction #'(lambda () ,initform)))
			    ,@rest)))
		    slot-specifiers))
    ,@(let* ((unbound (gensym))
	     (default-initargs unbound)
	     (rest nil))
	(dolist (option class-options)
	  (case (car option)
	    (:default-initargs (setq default-initargs (cdr option)))
	    (:metaclass (push `',(cadr option) rest)
			(push :metaclass rest))
	    (t (push `',(cdr option) rest)
	       (push `',(car option) rest))))
	`(,@(unless (eq default-initargs unbound)
	      `(:direct-default-initargs
		(list ,@(do ((initargs default-initargs (cddr initargs))
			     (result nil))
			    ((not initargs) (reverse result))
			  (push `(list ',(car initargs) ',(cadr initargs)
				  #'(lambda () ,(cadr initargs)))
				result)))))
	  ,@rest))))
(defmacro defmethod (&environment environment function-name &rest rest)
  (let* ((method-qualifiers (do ((qualifiers nil))
				((listp (car rest)) (reverse qualifiers))
			      (push (pop rest) qualifiers)))
	 (lambda-list (car rest))
	 (gf (gensym)))
    (let ((gfn (ensure-generic-function function-name)))
      (multiple-value-bind (lambda initargs)
	  (if (eq (iref gfn 1) *standard-generic-function*)
	      (make-standard-method-lambda
	       gfn `(lambda ,(extract-lambda-list lambda-list) ,@(cdr rest))
	       environment)
	      (make-method-lambda
	       gfn (class-prototype (generic-function-method-class gfn))
	       `(lambda ,(extract-lambda-list lambda-list) ,@(cdr rest))
	       environment))
	`(let ((,gf (ensure-generic-function ',function-name)))
	  (funcall (if (eq (iref ,gf 1) *standard-generic-function*)
		       #'add-standard-method
		       #'add-method)
	   ,gf (ensure-method ,gf
		:qualifiers ',method-qualifiers
		:lambda-list ',(extract-lambda-list lambda-list)
		:specializers
		(list ,@(mapcar #'(lambda (specializer)
				    `(find-class ',specializer))
				(extract-specializer-names lambda-list)))
		:function (function ,lambda)
		,@initargs)))))))
(defun class-of (object)
  (case (ldb '(2 . 0) (ival object))
    (2 (let ((class-candidate (iref object 1)))
	 (if (= (ldb '(2 . 0) (ival class-candidate)) 2)
	     class-candidate
	     (case class-candidate
	       (0 (find-class 'symbol))
	       (3 (find-class 'vector))
	       (4 (find-class 'array))
	       (5 (find-class 'package))
	       (6 (find-class 'function))
	       (t (find-class 't))))))
    (0 (if (eq object nil)
	   (find-class 'null)
	   (if (= (ldb '(2 . 3) (ival object)) 2)
	       (find-class 'integer)
	       (find-class 'character))))
    (1 (find-class 'cons))
    (3 (case (jref object 1)
	 (20 (find-class 'string))
	 (84 (find-class 'real))
	 (116 (find-class 'bit-vector))
	 (t (find-class 't))))))
(defparameter *funcallable-standard-class* (makei 1 *standard-class*))
(defparameter *standard-direct-slot-definition* (makei 1 *standard-class*))
(defparameter *standard-effective-slot-definition*
  (makei 1 *standard-class*))
(defparameter *standard-method-combination* (makei 1 *standard-class*))
(defparameter *standard-method* (makei 1 *standard-class*))
(defparameter *standard-generic-function*
  (makei 1 *funcallable-standard-class*))
(defparameter *standard-reader-method* (makei 1 *standard-class*))
(defparameter *standard-writer-method* (makei 1 *standard-class*))
(setf (find-class 'standard-class) *standard-class*)
(setf (find-class 'built-in-class) *built-in-class*)
(setf (find-class 'funcallable-standard-class) *funcallable-standard-class*)
(setf (find-class 'structure-class) *structure-class*)
(setf (find-class 'standard-direct-slot-definition)
      *standard-direct-slot-definition*)
(setf (find-class 'standard-effective-slot-definition)
      *standard-effective-slot-definition*)
(setf (find-class 'standard-method-combination) *standard-method-combination*)
(setf (find-class 'standard-method) *standard-method*)
(setf (find-class 'standard-generic-function) *standard-generic-function*)
(defun extract-lambda-list (specialized-lambda-list)
  (do ((result nil))
      ((or (not specialized-lambda-list)
	   (member (car specialized-lambda-list) lambda-list-keywords))
       (revappend result specialized-lambda-list))
    (let ((arg (pop specialized-lambda-list)))
      (push (if (consp arg) (car arg) arg) result))))
(defun extract-specializer-names (specialized-lambda-list)
  (do ((result nil))
      ((or (not specialized-lambda-list)
	   (member (car specialized-lambda-list) lambda-list-keywords))
       (reverse result))
    (let ((arg (pop specialized-lambda-list)))
      (push (if (consp arg) (cadr arg) 't) result))))
(defun ensure-class (name &rest rest &key metaclass)
  (apply (if (member metaclass `(nil standard-class ,*standard-class*))
	     #'ensure-standard-class
	     #'ensure-class-using-class)
	 (find-class name nil) name rest))
(defun ensure-standard-class (class name &key direct-default-initargs
			      direct-slots direct-superclasses)
  (unless class (setq class (makei 1 *standard-class*)))
  (unless direct-superclasses (setq direct-superclasses '(standard-object)))
  (setq direct-superclasses (mapcar #'(lambda (super)
					(if (symbolp super)
					    (find-class super)
					    super))
				    direct-superclasses))
  (setf (iref class 2)
	(makei 9 3 name direct-superclasses
	       (mapcar #'(lambda (slot)
			   (apply #'make-standard-direct-slot slot))
		       direct-slots)
	       nil nil nil nil
	       direct-default-initargs))
  (setf (find-class name) class)
  (dolist (super direct-superclasses)
    (push class (iref (iref super 2) 7)))
  (dolist (slot (iref (iref class 2) 4))
    (dolist (reader (iref (iref slot 2) 8))
      (add-reader-method class reader slot))
    (dolist (writer (iref (iref slot 2) 9))
      (add-writer-method class writer slot)))
  (standard-finalize-inheritance class)
  class)
(defun standard-finalize-inheritance (class)
  (unless (iref (iref class 2) 5)
    (mapc #'standard-finalize-inheritance (iref (iref class 2) 3))
    (setf (iref (iref class 2) 5)
	  (standard-compute-class-precedence-list class))
    (setf (iref (iref class 2) 6)
	  (standard-compute-slots class)))
  (values))
(defun standard-compute-class-precedence-list (class)
  (let ((superclasses (cons class (reduce #'union
					  (mapcar #'(lambda (super)
						      (iref (iref super 2) 5))
						  (iref (iref class 2) 3)))))
	(dependencies (make-hash-table)))
    (dolist (super superclasses)
      (dolist (direct-super (iref (iref super 2) 3))
	(incf (gethash direct-super dependencies 0))))
    (do ((minimal (list class))
	 (result nil))
	((not minimal) (if (zerop (hash-table-count dependencies))
			   (reverse result)
			   (error "Incorrect dependency graph.")))
      (let ((next (if (cdr minimal)
		      (dolist (constituent result)
			(let ((common (intersection minimal
						    (iref (iref constituent 2) 3))))
			  (when common (return (car common)))))
		      (car minimal))))
	(setq minimal (remove next minimal))
	(push next result)
	(dolist (direct-super (iref (iref next 2) 3))
	  (when (zerop (decf (gethash direct-super dependencies)))
	    (remhash direct-super dependencies)
	    (push direct-super minimal)))))))
(defun standard-compute-slots (class)
  (let ((defs nil))
    (dolist (super (reverse (iref (iref class 2) 5)))
      (dolist (slot (iref (iref super 2) 4))
	(let* ((name (iref (iref slot 2) 2))
	       (cons (assoc name defs)))
	  (unless cons
	    (setq cons (list name))
	    (push cons defs))
	  (push slot (cdr cons)))))
    (mapcar #'(lambda (cons)
		(standard-compute-effective-slot-definition class (car cons)
							    (cdr cons)))
	    (reverse defs))))
(defun standard-compute-effective-slot-definition (class name
						   direct-slot-definitions)
  (let* ((init-slot (find-if #'(lambda (slot)
				 (iref (iref slot 2) 4))
			     direct-slot-definitions))
	 (init (and init-slot (iref init-slot 2)))
	 (allocation (iref (iref (car direct-slot-definitions) 2) 6)))
    (makei 1 *standard-effective-slot-definition*
	   (makei 7 3 name (and init (iref init 3)) (and init (iref init 4)) 't
		  allocation
		  (mapcan #'(lambda (slot)
			      (iref (iref slot 2) 7))
			  direct-slot-definitions)
		  (when (eq allocation :class)
		    (car direct-slot-definitions))))))
(defun make-standard-direct-slot (&key name initform initfunction (type t)
				  (allocation :instance) initargs readers
				  writers documentation)
  (makei 1 *standard-direct-slot-definition*
	 (makei 9 3 name initform initfunction type allocation initargs readers
		writers)))
(defun add-reader-method (class fn-name slot)
  (let ((slot-name (iref (iref slot 2) 2))
	(gf (ensure-generic-function fn-name :lambda-list '(object))))
    (add-standard-method gf (ensure-method
			     gf
			     :method-class *standard-reader-method*
			     :slot-definition slot
			     :lambda-list '(object)
			     :qualifiers nil
			     :specializers (list class)
			     :function
			     #'(lambda (args next)
				 (slot-value (car args) slot-name))))))
(defun add-writer-method (class fn-name slot)
  (let ((slot-name (iref (iref slot 2) 2))
	(gf (ensure-generic-function fn-name
				     :lambda-list '(new-value object))))
    (add-standard-method gf (ensure-method
			     gf
			     :method-class *standard-writer-method*
			     :slot-definition slot
			     :lambda-list '(new-value object)
			     :qualifiers nil
			     :specializers (list (find-class 't) class)
			     :function
			     #'(lambda (args next)
				 (setf (slot-value (cadr args) slot-name)
				       (car args)))))))
(defun slot-value (object slot-name)
  (let ((class (iref object 1)))
    (if (or (eq (iref class 1) *standard-class*)
	    (eq (iref class 1) *funcallable-standard-class*))
	(standard-slot-value class object slot-name)
	(slot-value-using-class class object
				(find slot-name (class-slots class)
				      :key #'slot-definition-name)))))
(defun standard-slot-value (class object slot-name)
  (let ((index 2))
    (dolist (slot (iref (iref class 2) 6))
      (cond
	((eq :instance (iref (iref slot 2) 6))
	 (when (eq slot-name (iref (iref slot 2) 2))
	   (unless (iboundp (iref object 2) index)
	     (write-line "unbound slot")
	     (write-line (symbol-name slot-name)))
	   (return (iref (iref object 2) index)))
	 (incf index))
	(t
	 (when (eq slot-name (iref (iref slot 2) 2))
	   (return (iref (iref (iref (iref slot 2) 8) 2) 10))))))))
(defun (setf slot-value) (new-value object slot-name)
  (let ((class (iref object 1)))
    (if (eq (iref class 1) *standard-class*)
	(setf (standard-slot-value class object slot-name) new-value)
	(setf (slot-value-using-class class object
				      (find slot-name (class-slots class)
					    :key #'slot-definition-name))))))
(defun (setf standard-slot-value) (new-value class object slot-name)
  (let ((index 2))
    (dolist (slot (iref (iref class 2) 6))
      (cond
	((eq :instance (iref (iref slot 2) 6))
	 (when (eq slot-name (iref (iref slot 2) 2))
	   (return (setf (iref (iref object 2) index) new-value)))
	 (incf index))
	(t
	 (when (eq slot-name (iref (iref slot 2) 2))
	   (return (setf (iref (iref (iref (iref slot 2) 8) 2) 10)
			 new-value))))))))
(defun ensure-generic-function (function-name &rest rest
				&key (generic-function-class
				      *standard-generic-function*))
  (apply (if (or (eq generic-function-class *standard-generic-function*)
		 (eq generic-function-class 'standard-generic-function))
	     #'ensure-standard-generic-function
	     #'ensure-generic-function-using-class)
	 (and (fboundp function-name) (fdefinition function-name))
	 function-name rest))
(defun ensure-standard-generic-function
    (generic-function function-name &key declarations documentation
     (method-combination *standard-method-combination*)
     (method-class *standard-method*) lambda-list argument-precedence-order)
  (or generic-function
      (let ((gf (makei 2 *standard-generic-function*
		       (makei 9 3 function-name lambda-list nil method-class
			      argument-precedence-order declarations
			      method-combination
			      (make-hash-table :test #'equal))
		       #'(lambda (&rest rest) (error "No methods defined.")))))
	(setf (iref gf 0) 16)
	(setf (fdefinition function-name) gf))))
(defun ensure-method (generic-function &key (method-class *standard-method*)
		      lambda-list qualifiers specializers function
		      slot-definition)
  (makei 2 method-class
	 (if (eq method-class *standard-method*)
	     (makei 5 3 function generic-function lambda-list specializers
		    qualifiers)
	     (makei 6 3 function generic-function lambda-list specializers
		    qualifiers slot-definition))))
(defun add-standard-method (generic-function method)
  (push method (iref (iref generic-function 2) 4))
  (setf (iref (iref method 2) 3) generic-function)
  (setf (iref (iref generic-function 2) 10)
	(length (iref (iref method 2) 5)))
  (let ((df (compute-standard-discriminating-function generic-function)))
    (set-funcallable-instance-function generic-function df)))
(defparameter *emf-args* (gensym))
(defun compute-standard-discriminating-function (generic-function)
  #'(lambda (&rest arguments)
      (let* ((classes (mapcar #'class-of
			      (subseq arguments
				      0 (iref (iref generic-function 2) 10))))
	     (emf (gethash classes (iref (iref generic-function 2) 9))))
	(if emf
	    (apply emf arguments)
	    (multiple-value-bind (methods memoizablep)
		(compute-standard-applicable-methods-using-classes
		 generic-function classes)
	      (unless memoizablep
		(setq methods (compute-standard-applicable-methods
			       generic-function arguments)))
	      (unless methods
		(apply #'no-applicable-method generic-function arguments))
	      (multiple-value-bind (effective-method effective-method-options)
		  (compute-standard-effective-method
		   generic-function (iref (iref generic-function 2) 8) methods)
		(let ((emf (coerce `(lambda (&rest ,*emf-args*)
				     ,effective-method)
				   'function)))
		  (when memoizablep
		    (setf (gethash classes (iref (iref generic-function 2) 9))
			  emf))
		  (apply emf arguments))))))))
(defun compute-standard-applicable-methods-using-classes
    (generic-function classes)
  (let ((applicable nil)
	(depths nil))
    (dolist (method (iref (iref generic-function 2) 4))
      (block method
	(do ((specializers (iref (iref method 2) 5) (cdr specializers))
	     (clss classes (cdr clss)))
	    ((not clss))
	  (let ((depth 0))
	    (dolist (class (iref (iref (car clss) 2) 5) (return-from method))
	      (when (eq (car specializers) class)
		(push depth depths)
		(return))
	      (incf depth))))
	(let ((prev nil)
	      (point applicable)
	      (depths (reverse depths)))
	  (do () ((or (not point)
		      (do ((dl depths (cdr dl))
			   (dr (cdr point) (cdr dr)))
			  ((not dl))
			(when (< (car dl) (car dr))
			  (return t))
			(when (> (car dl) (car dr))
			  (return)))))
	    (setq prev point)
	    (setq point (cdr point)))
	  (let ((new (cons (cons method depths) point)))
	    (if prev
		(setf (cdr prev) new)
		(setq applicable new))))))
    (values (mapcar #'car applicable) t)))
(defun compute-standard-effective-method (generic-function method-combination
					  methods)
  (let ((primary nil)
	(before nil)
	(after nil)
	(around nil))
    (dolist (method methods)
      (let ((qualifiers (iref (iref method 2) 6)))
	(cond
	  ((not qualifiers) (push method primary))
	  ((equal qualifiers '(:before)) (push method before))
	  ((equal qualifiers '(:after)) (push method after))
	  ((equal qualifiers '(:around)) (push method around))
	  (t (error "unknown qualifiers for standard-method-combination ~A"
		    qualifiers)))))
    (setq primary (reverse primary))
    (setq before (reverse before))
    (setq around (reverse around))
    (flet ((call-methods (methods)
	     (mapcar #'(lambda (method)
			 `(call-standard-method ,method))
		     methods)))
      (let ((form (if (or before after (rest primary))
		      `(multiple-value-prog1
			(progn ,@(call-methods before)
			       (call-standard-method ,(car primary)
						     ,(cdr primary)))
			,@(call-methods after))
		      `(call-standard-method ,(car primary)))))
	(if around
	    `(call-method ,(car around) (,@(cdr around) (make-method ,form)))
	    form)))))
(defmacro call-standard-method (method &optional next-method-list)
  `(funcall (if (consp ',method)
		(make-method-function (cadr ',method))
		(iref (iref ',method 2) 2))
    ,*emf-args* ',next-method-list))
(defmacro call-method (method &optional next-method-list)
  `(funcall (method-function ,method) ,*emf-args* ',next-method-list))
(defun set-funcallable-instance-function (funcallable-instance function)
  (setf (iref funcallable-instance 3) function))
(defun make-standard-method-lambda
    (generic-function lambda-expression environment)
  `(lambda (args next)
    (flet ((next-method-p ()
	     next)
	   (call-next-method (&rest next-args)
	     (if next
		 (funcall (if (consp (car next))
			      (make-method-function (cadar next))
			      (iref (iref (car next) 2) 2))
			  (or next-args args)
			  (cdr next))
		 (apply #'no-next-method ',generic-function nil next-args))))
      (apply (function ,lambda-expression) args))))
(defun make-method-function (form)
  (coerce (make-standard-method-lambda nil `(lambda (&rest ,*emf-args*) ,form) nil)
	  'function))
(defclass standard-object (t) ())
(defclass funcallable-standard-object (standard-object) ())
(defclass metaobject (standard-object) ())
(defclass generic-function (metaobject funcallable-standard-object) ())
(defclass standard-generic-function (generic-function)
  ((name :accessor generic-function-name)
   (lambda-list :accessor generic-function-lambda-list)
   (methods :accessor generic-function-methods)
   (method-class :accessor generic-function-method-class)
   (argument-precedence-order
    :accessor generic-function-argument-precedence-order)
   (declarations :accessor generic-function-declarations)
   (method-combination :accessor generic-function-method-combination)
   (classes-to-emf :accessor generic-function-classes-to-emf)
   (required-length :accessor generic-function-required-length)))
(defclass method (metaobject) ())
(defclass standard-method (method)
  ((function :accessor method-function
	     :initarg :function)
   (generic-function :accessor method-generic-function
		     :initarg :generic-function)
   (lambda-list :accessor method-lambda-list
		:initarg :lambda-list)
   (specializers :accessor method-specializers
		 :initarg :specializers)
   (qualifiers :accessor method-qualifiers
	       :initarg :qualifiers)))
(defclass standard-accessor-method (standard-method)
  (slot-definition :accessor accessor-method-slot-definition))
(defclass standard-reader-method (standard-accessor-method) ())
(defclass standard-writer-method (standard-accessor-method) ())
(defclass slot-definition (metaobject) ())
(defclass direct-slot-definition (slot-definition) ())
(defclass effective-slot-definition (slot-definition) ())
(defclass standard-slot-definition (slot-definition)
  ((name :accessor slot-definition-name
	 :initarg :name)
   (initform :accessor slot-definition-initform
	     :initarg :initform)
   (initfunction :accessor slot-definition-initfunction
		 :initarg :initfunction
		 :initform nil)
   (type :accessor slot-definition-type
	 :initarg :type
	 :initform t)
   (allocation :accessor slot-definition-allocation
	       :initarg :allocation
	       :initform :instance)
   (initargs :accessor slot-definition-initargs
	     :initarg :initargs
	     :initform nil)))
(defclass standard-direct-slot-definition
    (standard-slot-definition direct-slot-definition)
  ((readers :accessor slot-definition-readers
	    :initarg :readers
	    :initform nil)
   (writers :accessor slot-definition-writers
	    :initarg :writers
	    :initform nil)))
(defclass standard-effective-slot-definition
    (standard-slot-definition effective-slot-definition) ())
(defclass specializer (metaobject) ())
(defclass eql-specializer (specializer)
  ((object :accessor eql-specializer-object)))
(defclass class (specializer)
  ((name :accessor class-name)
   (direct-superclasses :accessor class-direct-superclasses
			:initarg :direct-superclasses)
   (direct-slots :accessor class-direct-slots)
   (precedence-list :accessor class-precedence-list
		    :initform nil)
   (slots :accessor class-slots)
   (direct-subclasses :accessor class-direct-subclasses
		      :initform nil)
   (direct-methods :accessor class-direct-methods)
   (direct-default-initargs :accessor class-direct-default-initargs
			    :initform nil)
   (default-initargs :accessor class-default-initargs)))
(defclass built-in-class (class) ())
(defclass forward-referenced-class (class) ())
(defclass standard-class (class) ())
(defclass funcallable-standard-class (class) ())
(defclass structure-class (class) ())
(dolist (built-in-def '((array (t))
			(sequence (t))
			(vector (array sequence))
			(bit-vector (vector))
			(character (t))
			(number (t))
			(complex (number))
			(list (sequence))
			(cons (list))
			(function (t))
			(real (number))
			(rational (real))
			(integer (rational))
			(symbol (t))
			(null (symbol list))
			(package (t))
			(ratio (rational))
			(real (number))
			(string (vector))
			(hash-table (structure-object))))
  (let* ((direct-superclasses (mapcar #'find-class (cadr built-in-def)))
	 (class (or (find-class (car built-in-def) nil)
		    (makei 1 *built-in-class*))))
    (setf (iref class 2) (makei 8 3 (car built-in-def) direct-superclasses))
    (setf (find-class (car built-in-def)) class)
    (dolist (super direct-superclasses)
      (push class (iref (iref super 2) 7)))
    (standard-finalize-inheritance class)))
(defmethod make-instance ((class standard-class) &rest initargs)
  (unless (class-finalized-p class)
    (finalize-inheritance class))
  (let ((additional-initargs nil))
    (dolist (default-initarg (class-direct-default-initargs class))
      (let ((default (getf initargs (car default-initarg))))
	(when default
	  (push (car default-initarg) additional-initargs)
	  (push (funcall (caddr default-initarg)) additional-initargs))))
    (setq initargs (append initargs (reverse additional-initargs))))
  (let ((instance (apply #'allocate-instance class initargs)))
    (apply #'initialize-instance instance initargs)
    instance))
(defmethod make-instance ((class symbol) &rest initargs)
  (apply #'make-instance (find-class class) initargs))
(defmethod allocate-instance ((class standard-class) &rest initargs)
  (let* ((length (count :instance (class-slots class)
			:key #'slot-definition-allocation))
	 (slots (makei length 3)))
    (dotimes (i length)
      (imakunbound slots (+ 2 i)))
    (makei 1 class slots)))
(defmethod initialize-instance ((instance standard-object) &rest initargs)
  (apply #'shared-initialize instance t initargs))
(defmethod shared-initialize ((instance standard-object) slot-names
			      &rest initargs)
  (let ((class (iref instance 1))
	(i 2))
    (dolist (slot (class-slots class))
      (multiple-value-bind (indicator value tail)
	  (get-properties initargs (slot-definition-initargs slot))
	(when indicator
	  (if (eq :instance (slot-definition-allocation slot))
	      (setf (iref (iref instance 2) i) value)
	      (setf (iref (iref (iref (iref slot 2) 8) 2) 10) value))))
      (when (eq :instance (slot-definition-allocation slot))
	(incf i)))
    (setq i 2)
    (dolist (slot (class-slots class))
      (when (and (not (iboundp (iref instance 2) i))
		 (or (eq slot-names 't)
		     (member (slot-definition-name slot) slot-names))
		 (slot-definition-initfunction slot))
	(if (eq :instance (slot-definition-allocation slot))
	    (setf (iref (iref instance 2) i)
		  (funcall (slot-definition-initfunction slot)))
	    (setf (iref (iref (iref (iref slot 2) 8) 2) 10)
		  (funcall (slot-definition-initfunction slot)))))
      (when (eq :instance (slot-definition-allocation slot))
	(incf i))))
  instance)
(defmethod reinitialize-instance ((instance standard-object) &rest initargs)
  (apply #'shared-initialize instance nil initargs))
(defmethod ensure-class-using-class ((class null) name &rest rest
				     &key (metaclass *standard-class*)
				     direct-superclasses)
  (unless direct-superclasses (setq direct-superclasses '(standard-object)))
  (setq direct-superclasses (mapcar #'(lambda (super)
					(if (symbolp super)
					    (find-class super)
					    super))
				    direct-superclasses))
  (let ((class (apply #'make-instance metaclass rest)))
    (setf (find-class name) class)
    (setf (class-name class) name)
    class))
(defmethod shared-initialize :after
    ((class class) slot-names &key direct-slots direct-superclasses
     direct-default-initargs)
  (unless (class-direct-superclasses class)
    (setf (class-direct-superclasses class)
	  (list 'standard-object)))
  (setf (class-direct-superclasses class)
	(mapcar #'(lambda (super)
		    (if (symbolp super)
			(find-class super)
			super))
		(class-direct-superclasses class)))
  (setf (class-direct-slots class)
	(mapcar #'(lambda (slot)
		    (apply #'make-instance
			   (apply #'direct-slot-definition-class
				  class slot)
			   slot))
		direct-slots))
  (dolist (slot (class-direct-slots class))
    (dolist (reader (slot-definition-readers slot))
      (let* ((gf (ensure-generic-function reader :lambda-list '(object)))
	     (slot-name (slot-definition-name slot))
	     (initargs (list :slot-definition slot :lambda-list '(object)
			     :function #'(lambda (args next)
					   (slot-value (car args) slot-name))
			     :qualifiers nil :specializers (list class)))
	     (reader-method-class (reader-method-class class slot initargs)))
	(add-method gf (apply #'make-instance reader-method-class initargs))))
    (dolist (writer (slot-definition-writers slot))
      (let* ((gf (ensure-generic-function writer
					  :lambda-list '(new-value object)))
	     (slot-name (slot-definition-name slot))
	     (initargs (list :slot-definition slot :qualifiers nil
			     :lambda-list '(new-value object)
			     :specializers (list (find-class 't) class)
			     :function
			     #'(lambda (args next)
				 (setf (slot-value (cadr args) slot-name)
				       (car args)))))
	     (writer-method-class (writer-method-class class slot initargs)))
	(add-method gf (apply #'make-instance writer-method-class initargs)))))
  (dolist (super (class-direct-superclasses class))
    (add-direct-subclass super class)))
(defmethod add-method ((generic-function standard-generic-function)
		       (method standard-method))
  (add-standard-method generic-function method))
(defmethod add-direct-subclass ((superclass class) (subclass class))
  (push subclass (class-direct-subclasses superclass)))
(defmethod reader-method-class
    ((class standard-class) (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (find-class 'standard-reader-method))
(defmethod reader-method-class
    ((class funcallable-standard-class)
     (direct-slot standard-direct-slot-definition) &rest initargs)
  (find-class 'standard-reader-method))
(defmethod writer-method-class
    ((class standard-class) (direct-slot standard-direct-slot-definition)
     &rest initargs)
  (find-class 'standard-writer-method))
(defmethod writer-method-class
    ((class funcallable-standard-class)
     (direct-slot standard-direct-slot-definition) &rest initargs)
  (find-class 'standard-writer-method))
(defmethod direct-slot-definition-class
    ((class standard-class) &rest initargs)
  (find-class 'standard-direct-slot-definition))
(defmethod direct-slot-definition-class
    ((class funcallable-standard-class) &rest initargs)
  (find-class 'standard-direct-slot-definition))
(defmethod finalize-inheritance ((class standard-class))
  (dolist (super (class-direct-superclasses class))
    (unless (class-finalized-p super)
      (finalize-inheritance super)))
  (setf (class-precedence-list class)
	(compute-class-precedence-list class))
  (setf (class-slots class)
	(compute-slots class))
  (setf (class-default-initargs class)
	(compute-default-initargs class)))
(defmethod class-finalized-p ((class class))
  (class-precedence-list class))
(defmethod compute-class-precedence-list ((class standard-class))
  (let ((superclasses
	 (cons class (reduce #'union
			     (mapcar #'class-precedence-list
				     (class-direct-superclasses class)))))
	(dependencies (make-hash-table)))
    (dolist (super superclasses)
      (dolist (direct-super (class-direct-superclasses super))
	(incf (gethash direct-super dependencies 0))))
    (do ((minimal (list class))
	 (result nil))
	((not minimal) (if (zerop (hash-table-count dependencies))
			   (reverse result)
			   (error "Incorrect dependency graph.")))
      (let ((next (if (cdr minimal)
		      (dolist (constituent result)
			(let ((common (intersection minimal
						    (class-direct-superclasses
						     constituent))))
			  (when common (return (car common)))))
		      (car minimal))))
	(setq minimal (remove next minimal))
	(push next result)
	(dolist (direct-super (class-direct-superclasses next))
	  (when (zerop (decf (gethash direct-super dependencies)))
	    (remhash direct-super dependencies)
	    (push direct-super minimal)))))))
(defmethod compute-slots ((class class))
  (let ((defs nil))
    (dolist (super (reverse (class-precedence-list class)))
      (dolist (slot (class-direct-slots super))
	(let* ((name (slot-definition-name slot))
	       (cons (assoc name defs)))
	  (unless cons
	    (setq cons (list name))
	    (push cons defs))
	  (push slot (cdr cons)))))
    (mapcar #'(lambda (cons)
		(compute-effective-slot-definition class (car cons)
						   (cdr cons)))
	    (reverse defs))))
(defmethod compute-effective-slot-definition
    ((class class) name direct-slot-definitions)
  (let* ((unbound (gensym))
	 (initfunction unbound)
	 (initform unbound)
	 (type 't)
	 (allocation :instance)
	 (initargs nil)
	 (readers nil)
	 (writers nil))
    (dolist (slot (reverse direct-slot-definitions))
      (let ((initfn (slot-definition-initfunction slot)))
	(when initfn
	  (setq initfunction initfn)
	  (setq initform (slot-definition-initform slot))))
      (setq type (slot-definition-type slot))
      (setq allocation (slot-definition-allocation slot))
      (setq initargs (append readers (slot-definition-initargs slot)))
      (setq readers (append readers (slot-definition-readers slot)))
      (setq writers (append writers (slot-definition-writers slot))))
    (let ((effective-initargs (list :name name :type type
				    :allocation allocation :initargs initargs
				    :readers readers :writers writers)))
      (unless (eq initfunction unbound)
	(setq effective-initargs
	      (list* :initfunction initfunction :initform initform
		     effective-initargs)))
      (apply #'make-instance
	     (apply #'effective-slot-definition-class class effective-initargs)
	     effective-initargs))))
(defmethod effective-slot-definition-class
    ((class standard-class) &rest initargs)
  (find-class 'standard-effective-slot-definition))
(defmethod effective-slot-definition-class
    ((class funcallable-standard-class) &rest initargs)
  (find-class 'standard-effective-slot-definition))
(defmethod compute-default-initargs ((class class))
  nil)
(defmethod slot-value-using-class
    ((class standard-class) object (slot standard-effective-slot-definition))
  (standard-slot-value class object (slot-definition-name slot)))
(defmethod slot-value-using-class ((class funcallable-standard-class) object
				   (slot standard-effective-slot-definition))
  (standard-slot-value class object (slot-definition-name slot)))
(defmethod no-applicable-method (generic-function &rest function-arguments)
  (error "no applicable method on ~A for ~A"
	 generic-function function-arguments))
(init-known-streams)
(defparameter *report-hash* (make-hash-table))
(defmacro define-condition (name parent-types slot-specifiers &rest options)
  (let* ((report (cadr (assoc :report options)))
	 (report-form (when report
			(if (stringp report)
			    `#'(lambda (condition stream)
				 (write-string ,report stream))
			    `#',report))))
    `(progn
      (defclass ,name ,(if parent-types parent-types '(condition))
	,slot-specifiers ,@(remove :report options :key #'car))
      (setf (gethash ',name *report-hash*) ,report-form)
      ',name)))
(define-condition condition (standard-object) ()
  (:report (lambda (condition stream)
	     (format stream "Condition ~A"
		     (class-name (class-of condition))))))
(define-condition serious-condition (condition) ())
(define-condition error (serious-condition) ()
  (:report (lambda (condition stream)
	     (format stream "Error ~A"
		     (class-name (class-of condition))))))
(define-condition arithmetic-error (error)
  ((operation :initarg :operation
	      :reader arithmetic-error-operation)
   (operands :initarg :operands
	     :reader arithmetic-error-operands)))
(define-condition cell-error (error)
  ((name :initarg :name
	 :reader cell-error-name))
  (:report (lambda (condition stream)
	     (format stream "Cell ~A not bound"
		     (cell-error-name condition)))))
(define-condition control-error (error) ())
(define-condition division-by-zero (arithmetic-error) ())
(define-condition stream-error (error)
  ((stream :initarg :stream
	   :reader stream-error-stream)))
(define-condition end-of-file (stream-error) ()
  (:report (lambda (condition stream)
	     (format stream "End of file"))))
(define-condition file-error (error)
  ((pathname :initarg :pathname
	     :reader file-error-pathname)))
(define-condition floating-point-inexact (arithmetic-error) ())
(define-condition floating-point-invalid-operation (arithmetic-error) ())
(define-condition floating-point-overflow (arithmetic-error) ())
(define-condition floating-point-underflow (arithmetic-error) ())
(define-condition package-error (error)
  ((package :initarg :package
	    :reader package-error-package)))
(define-condition parse-error (error) ())
(define-condition print-not-readable (error)
  ((object :initarg :object
	   :reader print-not-readable-object))
  (:report (lambda (condition stream)
	     (format stream "Cannot print ~A readably."
		     (print-not-readable-object condition)))))
(define-condition program-error (error) ())
(define-condition reader-error (parse-error) ())
(define-condition simple-condition (condition)
  ((format-control :initarg :format-control
		   :reader simple-condition-format-control)
   (format-arguments :initarg :format-arguments
		     :reader simple-condition-format-arguments))
  (:report (lambda (condition stream)
	     (apply #'format stream
		    (simple-condition-format-control condition)
		    (simple-condition-format-arguments condition)))))
(define-condition simple-error (simple-condition error) ())
(define-condition type-error (error)
  ((datum :initarg :datum
	  :reader type-error-datum)
   (expected-type :initarg :expected-type
		  :reader type-error-expected-type)))
(define-condition simple-type-error (simple-condition type-error) ())
(define-condition warning (condition) ())
(define-condition simple-warning (simple-condition warning) ())
(define-condition storage-condition (serious-condition) ())
(define-condition style-warning (warning) ())
(define-condition unbound-slot (cell-error)
  ((instance :initarg :instance
	     :reader unbound-slot-instance)))
(define-condition unbound-variable (cell-error) ())
(define-condition undefined-function (cell-error) ())
(defun make-condition (type &rest slot-initializations)
  (apply #'make-instance type slot-initializations))
(defmethod print-object (object stream)
  (case (ldb '(2 . 0) (ival object))
    (0 (if object
	   (if (= (ldb '(1 . 3) (ival object)) 0)
	       (write-string (integer-string object *print-base*) stream)
	       (let ((name (char-name object)))
		 (write-string "#\\" stream)
		 (write-string (or name (string object)) stream)))
	   (write-string "NIL" stream)))
    (1 (write-string "(" stream)
       (tagbody
	  (print-object (car object) stream)
	  (setq object (cdr object))
	start
	  (when (consp object)
	    (write-string " " stream)
	    (print-object (car object) stream)
	    (setq object (cdr object))
	    (go start)))
       (when object
	 (write-string " . " stream)
	 (print-object object stream))
       (write-string ")" stream))
    (2 (case (iref object 1)
	 (0 (write-string (symbol-name object) stream))
	 (3 (write-string "#(" stream)
	    (let ((i 0))
	      (tagbody
	       start
		 (when (< i (length object))
		   (when (< 0 i)
		     (write-string " " stream))
		   (print-object (aref object i) stream)
		   (setq i (+ 1 i))
		   (go start))))
	    (write-string ")" stream))
	 (4 (write-string "#<array>" stream))
	 (5 (write-string "#<package>" stream))
	 (6 (write-string "#<function>" stream))
	 (t (write-string "#<object " stream)
	    (let ((class (iref object 1)))
	      (if (= (ldb '(2 . 0) (ival class)) 2)
		  (print-object (class-name class) stream)
		  (print-object (iref object 1) stream)))
	    (write-string ">" stream))))
    (3 (case (jref object 1)
	 (20 (write-string object stream))
	 (84 (if (zerop (nth-value 1 (floor object)))
		 (write-string (integer-string object *print-base*) stream)
		 (write-string "#<double>" stream)))
	 (116 (write-string "#<file-stream>" stream))
	 (180 (write-string "" stream))
	 (t (write-string "#<bit object " stream)
	    (print-object (jref object 1) stream)
	    (write-string ">" stream)))))
  object)
(defmethod print-object ((condition condition) stream)
  (if *print-escape*
      (call-next-method)
      (dolist (super (class-precedence-list (class-of condition))
	       (call-next-method))
	(let ((report (gethash (class-name super) *report-hash*)))
	  (when report
	    (funcall report condition stream)
	    (return))))))
(defmethod print-object ((restart restart) stream)
  (if *print-escape*
      (call-next-method)
      (funcall (restart-report-function restart) stream)))
(defvar -)
(defvar +)
(defvar ++)
(defvar +++)
(defvar *)
(defvar **)
(defvar ***)
(defvar /)
(defvar //)
(defvar ///)
(defun read-eval-print-loop ()
  (tagbody
   start
     (with-simple-restart (abort "Return to lisp toplevel.")
       (format t "~%? ")
       (let* ((- (read))
	      (values (multiple-value-list (eval -)))
	      (count 0))
	 (when (boundp '++) (setq +++ ++))
	 (when (boundp '+) (setq ++ +))
	 (setq + -)
	 (when (boundp '//) (setq /// //))
	 (when (boundp '/) (setq // /))
	 (setq / values)
	 (when (boundp '**) (setq *** **))
	 (when (boundp '*) (setq ** *))
	 (setq * (car values))
	 (if values
	     (dolist (value values)
	       (format t ";~A: ~S~%" count value)
	       (incf count))
	     (format t ";No values.~%"))))
     (go start)))
(defun ierror (index args)
  (case index
    (0 (error 'unbound-variable :name args))
    (1 (error 'undefined-function :name args))
    (2 (error 'program-error))
    (3 (error 'program-error))
    (4 (error 'program-error))
    (5 (error 'control-error))
    (6 (error 'program-error))
    (7 (error 'program-error))
    (8 (error 'control-error))
    (9 (error 'control-error))
    (t (error "ierror ~A ~A~%" index args))))
(defvar *compilation*)
(defparameter *compiler-output* *standard-output*)
(defun start-compilation ()
  (let ((compilation (construct-compilation
		      (make-hash-table) (make-hash-table) (make-hash-table)
		      (make-hash-table)
		      (make-array 32 :adjustable t :fill-pointer 0
				  :initial-element 0)
		      (make-array 32 :adjustable t :fill-pointer 0
				  :initial-element 0)
		      *compiler-output*)))
    (format *compiler-output* "#include \"lisp500.h\"~%")
    (when (featurep :windows)
      (format *compiler-output* "#include <windows.h>~%"))
    (format *compiler-output* "lval *value, *opaque;~%")
    compilation))
(if (featurep :windows)
    (defun run-cc (basename)
      (run-program "c:/Program Files/Microsoft Visual Studio/VC98/bin/cl.exe"
		   (conc-string "cl /LD /Fe" basename ".dll " basename
				".c lisp500.lib")))
    (let ((end (if (featurep :cygwin) " lisp500.imp" "")))
      (defun run-cc (basename)
	(run-program "/bin/sh" "sh" "-c"
		     (conc-string "cc -fPIC -shared -g -o " basename ".so "
				  basename ".c" end)))))
(defun finish-compilation (&optional init)
  (let ((value-hash (compilation-value-hash *compilation*))
	(package-hash (compilation-package-hash *compilation*))
	(symbol-hash (compilation-symbol-hash *compilation*))
	(class-hash (compilation-class-hash *compilation*))
	(vals (compilation-values *compilation*))
	(opaques (compilation-opaques *compilation*)))
    (format *compiler-output* "lval package[] = {~%")
    (dolist (package (reverse (compilation-packages *compilation*)))
      (format *compiler-output* "~A,~%"
	      (gethash (package-name package) value-hash)))
    (format *compiler-output* "0~%};~%lval symbol[] = {~%")
    (dolist (symbol (reverse (compilation-symbols *compilation*)))
      (format *compiler-output* "~A, /* ~A */~%"
	      (gethash (symbol-name symbol) value-hash)
	      (symbol-name symbol)))
    (format *compiler-output* "0~%};~%lval symbol_package[] = {~%")
    (dolist (symbol (reverse (compilation-symbols *compilation*)))
      (format *compiler-output* "~A,~%"
	      (gethash (symbol-package symbol) package-hash)))
    (format *compiler-output* "0~%};~%lval klass[] = {~%")
    (dolist (class (reverse (compilation-classes *compilation*)))
      (format *compiler-output* "~A,~%"
	      (gethash (class-name class) symbol-hash)))
    (format *compiler-output* "0~%};~%lval value_data[] = {~%")
    (if (zerop (fill-pointer vals))
	(format *compiler-output* "0,~%0,~%")
	(dotimes (i (fill-pointer vals))
	  (format *compiler-output* "~A,~%" (aref vals i))))
    (format *compiler-output* "0~%};~%lval opaque_data[] = {~%")
    (if (zerop (fill-pointer opaques))
	(format *compiler-output* "0,~%0,~%")
	(dotimes (i (fill-pointer opaques))
	  (format *compiler-output* "~A,~%" (aref opaques i))))
    (format *compiler-output* "0~%};~%")
    (when (featurep :windows)
      (format *compiler-output* "__declspec(dllexport) "))
    (format *compiler-output* "lval init(lval *f) {~%")
    (format *compiler-output*
	    "fasr(f, package, ~A, symbol, symbol_package, ~A, klass, ~A, value_data, ~A, opaque_data, ~A, &value, &opaque);~%"
	    (hash-table-count package-hash)
	    (hash-table-count symbol-hash)
	    (hash-table-count class-hash)
	    (max (fill-pointer vals) 2)
	    (max (fill-pointer opaques) 2))
    (when init
      (format *compiler-output* "*++f = 0;~%")
      (write-string init *compiler-output*))
    (format *compiler-output* "return 0;~%")
    (format *compiler-output* "}~%")
    (when (featurep :windows)
      (format *compiler-output* "BOOL WINAPI DllMain() { return TRUE; }~%"))))
(defun intern-constant-string (value)
  (multiple-value-bind (index type)
      (intern-constant value)
    (case type
      (:package (conc-string "package[" (integer-string index 10) "]"))
      (:symbol (conc-string "symbol[" (integer-string index 10) "]"))
      (:class (conc-string "klass[" (integer-string index 10) "]"))
      (:immediate (integer-string index 10))
      (:cons (conc-string "(lval)value+"
			  (integer-string (+ 1 (* 4 index)) 10)))
      (:value (conc-string "(lval)value+"
			   (integer-string (+ 2 (* 4 index)) 10)))
      (:opaque (conc-string "(lval)opaque+"
			    (integer-string (+ 3 (* 4 index)) 10))))))
(defun intern-constant-lval (value)
  (multiple-value-bind (index type)
      (intern-constant value)
    (case type
      (:package (+ 3221225472 2 (* 4 index)))
      (:symbol (+ 2147483648 2 (* 4 index)))
      (:class (+ 1073741824 2 (* 4 index)))
      (:immediate index)
      (:cons (+ 1 (* 4 index)))
      (:value (+ 2 (* 4 index)))
      (:opaque (+ 3 (* 4 index))))))
(defun intern-constant (value)
  (cond
    ((= (ldb '(2 . 0) (ival value)) 0)
     (values (ival value) :immediate))
    ((packagep value)
     (let* ((hash (compilation-package-hash *compilation*))
	    (index (gethash value hash)))
       (unless index
	 (intern-constant (package-name value))
	 (setq index (setf (gethash value hash) (hash-table-count hash)))
	 (push value (compilation-packages *compilation*)))
       (values index :package)))
    ((symbolp value)
     (let* ((hash (compilation-symbol-hash *compilation*))
	    (index (gethash value hash)))
       (unless index
	 (intern-constant (symbol-package value))
	 (intern-constant (symbol-name value))
	 (setq index (setf (gethash value hash) (hash-table-count hash)))
	 (push value (compilation-symbols *compilation*)))
       (values index :symbol)))
    ((typep value 'class)
     (let* ((hash (compilation-class-hash *compilation*))
	    (index (gethash value hash)))
       (unless index
	 (intern-constant (class-name value))
	 (setq index (setf (gethash value hash) (hash-table-count hash)))
	 (push value (compilation-classes *compilation*)))
       (values index :class)))
    (t
     (let* ((hash (compilation-value-hash *compilation*))
	    (index (gethash value hash))
	    (tag (ldb '(2 . 0) (ival value))))
       (unless index
	 (let ((vals (if (= tag 3)
			 (compilation-opaques *compilation*)
			 (compilation-values *compilation*)))
	       (length (case tag
			 (1 2)
			 (2 (+ 2 (/ (ival (iref value 0)) 256)))
			 (3 (+ 2 (floor (jref value 0) 256))))))
	   (setq index (setf (gethash value hash) (fill-pointer vals)))
	   (let ((new-fill (+ (fill-pointer vals)
			      (if (oddp length) (+ 1 length) length))))
	     (when (> new-fill (array-dimension vals 0))
	       (adjust-array vals (* 2 new-fill) :initial-element 0))
	     (setf (fill-pointer vals) new-fill))
	   (case tag
	     (1 (setf (aref vals index) (intern-constant-lval (car value)))
		(setf (aref vals (+ 1 index))
		      (intern-constant-lval (cdr value))))
	     (2 (setf (aref vals index) (ival (iref value 0)))
		(setf (aref vals (+ 1 index))
		      (+ 4 (intern-constant-lval (iref value 1))))
		(dotimes (i (- length 2))
		  (setf (aref vals (+ index 2 i))
			(intern-constant-lval (iref value (+ 2 i))))))
	     (3 (dotimes (i length)
		  (setf (aref vals (+ index i)) (jref value i)))))))
       (values index (case tag
		       (1 :cons)
		       (2 :value)
		       (3 :opaque)))))))
(defparameter *control-obstacles*
  '(unwind-protect lambda block tagbody catch
    let-special let*-special))
(defparameter *stack-obstacles* '(lambda))
(defun binding (environment name &optional obstacle-names)
  (let ((obstacles nil))
    (dolist (bind environment)
      (when (equal name (car bind))
	(return (values (cdr bind) obstacles)))
      (when (and (consp (car bind)) (member (caar bind) obstacle-names))
	(push (cdr bind) obstacles)))))
(defun user-obstacle-p (user)
  (dolist (obstacle (aref user 2))
    (unless (member (aref obstacle 0) '(block-local tagbody-local))
      (return t))))
(defun binding-obstacle-p (binding)
  (some #'user-obstacle-p (binding-users binding)))
(defun binding-users (binding)
  (aref binding 3))
(defun (setf binding-users) (new-users binding)
  (setf (aref binding 3) new-users))
(defun binding-height (binding)
  (aref binding 4))
(defun (setf binding-height) (new-height binding)
  (setf (aref binding 4) new-height))
(defun user-obstacles (user)
  (aref user 2))
(defun function-upward-funarg-p (function)
  (aref function 4))
(defun user-upward-funarg-p (user)
  (some #'function-upward-funarg-p (user-obstacles user)))
(defun binding-upward-funarg-p (binding)
  (some #'user-upward-funarg-p (binding-users binding)))
(defun transform-function (lambda-list body environment)
  (let ((transformed-lambda-list nil))
    (dolist (elem lambda-list)
      (if (member elem lambda-list-keywords)
	  (push elem transformed-lambda-list)
	  (if (consp elem)
	      (let* ((initializer (transform (cadr elem) environment))
		     (binding (vector 'lambda-let initializer nil nil nil)))
		(push (list* (car elem) binding (cddr elem))
		      transformed-lambda-list)
		(push (cons (car elem) binding) environment)
		(when (cddr elem)
		  (push (caddr elem) environment)))
	      (let ((binding (vector 'lambda-let (vector 'constant nil)
				     nil nil nil)))
		(push (list elem binding) transformed-lambda-list)
		(push (cons elem binding) environment)))))
    (push (cons (list 'lambda) (vector 'lambda nil nil nil nil)) environment)
    (vector 'lambda (reverse transformed-lambda-list)
	    (transform-progn body environment)
	    nil nil (incf (compilation-label-counter *compilation*)))))
(defun transform-progn (forms environment)
  (mapcar #'(lambda (form)
	      (transform form environment))
	  forms))
(defparameter *transforms* (make-hash-table))
(defparameter *write-cs* (make-hash-table))
(defmacro deftransform (operator lambda-list &rest body)
  `(setf (gethash ',operator *transforms*)
    #'(lambda ,(cons 'environment lambda-list) ,@body)))
(defmacro defwrite-c (operator &rest body)
  `(setf (gethash ',operator *write-cs*)
    #'(lambda (intermediate stack-height frame-height receiver) ,@body)))
(deftransform block (tag &rest forms)
  (let* ((binding (vector 'block tag nil nil
			  (incf (compilation-label-counter *compilation*))
			  nil))
	 (new-env (acons (list 'block tag) binding environment)))
    (setf (aref binding 2) (transform-progn forms new-env))
    (unless (binding-obstacle-p binding)
      (setf (aref binding 0) 'block-local))
    binding))
(deftransform catch (tag-form &rest forms)
  (let* ((binding (vector 'catch (transform tag-form environment) nil nil))
	 (new-env (acons (list 'catch) binding environment)))
    (setf (aref binding 2) (transform-progn forms new-env))
    binding))
(deftransform flet (bindings &rest forms)
  (let ((binding (vector 'flet nil nil nil))
	(functions nil)
	(new-env environment))
    (dolist (bind bindings)
      (let* ((rest (cdr bind))
	     (function (transform-function (car rest) (cdr rest) environment)))
	(push function functions)
	(push (cons (list 'function (car bind)) function) new-env)))
    (setf (aref binding 1) (reverse functions))
    (setf (aref binding 2) (transform-progn forms new-env))
    binding))
(deftransform function (specifier)
  (if (and (consp specifier) (eq 'lambda (car specifier)))
      (let ((function (transform-function (cadr specifier) (cddr specifier)
					  environment)))
	(setf (aref function 4) t)
	function)
      (let ((binding (binding environment (list 'function specifier))))
	(if binding
	    (let ((reference (vector 'function-local binding)))
	      (push reference (aref binding 3))
	      reference)
	    (vector 'function-global specifier)))))
(deftransform go (tag)
  (multiple-value-bind (binding obstacles)
      (binding environment (list 'go tag) *control-obstacles*)
    (if binding
	(let ((reference (vector 'go binding obstacles)))
	  (push reference (aref (cdr binding) 3))
	  reference)
	(vector 'go-unbound tag))))
(deftransform if (if then else)
  (vector 'if (transform if environment)
	  (transform then environment)
	  (transform else environment)))
(deftransform labels (bindings &rest forms)
  (let ((binding (vector 'flet nil nil nil)))
    (dolist (bind bindings)
      (push (cons (list 'function (car bind))
		  (vector 'lambda nil nil nil nil))
	    environment))
    (setf (aref binding 1)
	  (mapcar #'(lambda (bind)
		      (transform-function (cadr bind) (cddr bind)
					  environment))))
    (do ((functions (reverse (aref binding 1)) (cdr functions))
	 (binds environment))
	((not functions))
      (let ((function (car functions))
	    (bind-fn (cdar binds)))
	(setf (aref function 3) (aref bind-fn 3))))
    (setf (aref binding 2) (transform-progn forms environment))
    binding))
(deftransform let (bindings &rest forms)
  (labels ((descend-bind (bindings new-env)
	     (if bindings
		 (let* ((bind (car bindings))
			(binding (vector 'let
					 (transform (cadr bind) environment)
					 nil nil nil)))
		   (setf (aref binding 2)
			 (descend-bind (cdr bindings)
				       (acons (car bind) binding new-env)))
		   binding)
		 (transform-progn forms new-env))))
    (descend-bind bindings environment)))
(deftransform let* (bindings &rest forms)
  (labels ((descend-bind (bindings new-env)
	     (if bindings
		 (let* ((bind (car bindings))
			(binding (vector 'let
					 (transform (cadr bind) new-env)
					 nil nil nil)))
		   (setf (aref binding 2)
			 (descend-bind (cdr bindings)
				       (acons (car bind) binding new-env)))
		   binding)
		 (transform-progn forms new-env))))
    (descend-bind bindings environment)))
(deftransform macrolet (bindings &rest forms)
  (dolist (bind bindings)
    (push (cons (car bind)
		(list (coerce `#'(lambda ,@(cdr arguments)) 'function)))
	  environment))
  (vector 'progn (transform-progn forms environment)))
(deftransform multiple-value-call (fn-form &rest forms)
  (vector 'multiple-value-call
	  (transform fn-form enviroment)
	  (transform-progn forms environment)))
(deftransform multiple-value-prog1 (form-1 &rest forms)
  (vector 'multiple-value-prog1
	  (transform form-1 environment)
	  (transform-progn forms environment)))
(deftransform progn (&rest forms)
  (vector 'progn (transform-progn forms environment)))
(deftransform progv (&rest forms)
  (vector 'progv (transform-progn forms environment)))
(deftransform quote (datum)
  (vector 'constant datum))
(deftransform return-from (tag &optional form)
  (multiple-value-bind (binding obstacles)
      (binding environment (list 'block tag) *control-obstacles*)
    (if binding
	(let ((reference (vector 'return-from binding obstacles
				 (transform form environment))))
	  (push reference (aref binding 3))
	  reference)
	(vector 'return-from-unbound tag))))
(deftransform setq (&rest arguments)
  (do ((pairs arguments (cddr pairs))
       (sets nil))
      ((not pairs) (vector 'progn (reverse sets)))
    (let ((symbol (car pairs))
	  (value (cadr pairs)))
      (multiple-value-bind (binding obstacles)
	  (binding environment symbol *stack-obstacles*)
	(if binding
	    (if (consp binding)
		(push (transform `(setf ,symbol ,value) environment) sets)
		(let ((set (vector 'setq binding obstacles
				   (transform value environment))))
		  (push set (binding-users binding))
		  (push set sets)))
	    (multiple-value-bind (symbol expandedp)
		(macroexpand-1 symbol)
	      (if expandedp
		  (push (transform `(setf ,symbol ,value) environment) sets)
		  (push (vector 'dynamic-setq symbol
				(transform value environment))
			sets))))))))
(deftransform symbol-macrolet (bindings &rest forms)
  (dolist (bind bindings)
    (push bind environment))
  (vector 'progn (transform-progn forms environment)))
(deftransform tagbody (&rest arguments)
  (let ((tags (remove-if #'consp arguments))
	(binding (vector 'tagbody nil nil nil))
	(label-counter (compilation-label-counter *compilation*)))
    (push (cons (list 'tagbody) binding) environment)
    (dolist (tag tags)
      (push (list* (list 'go tag)
		   (incf (compilation-label-counter *compilation*))
		   binding)
	    environment))
    (setf (aref binding 1)
	  (mapcar #'(lambda (form)
		      (if (consp form)
			  (transform form environment)
			  (vector 'tag (incf label-counter))))
		  arguments))
    (unless (binding-obstacle-p binding)
      (setf (aref binding 0) 'tagbody-local))
    binding))
(deftransform throw (&rest arguments)
  (vector 'throw (transform-progn arguments environment)))
(deftransform unwind-protect (form-1 &rest forms)
  (vector 'unwind-protect
	  (transform form-1 (acons (list 'unwind-protect) nil environment))
	  (transform-progn forms environment)))
(defun transform (form &optional environment)
  (if (consp form)
      (let* ((operator (car form))
	     (arguments (cdr form))
	     (transform (gethash operator *transforms*)))
	(if transform
	    (apply transform environment arguments)
	    (let ((binding (binding environment (list 'function operator)))
		  (targs (transform-progn arguments environment)))
	      (if binding
		  (if (consp binding)
		      (transform (funcall (car binding) form) environment)
		      (let ((reference (vector 'funcall-local binding targs
					       environment)))
			(push reference (binding-users binding))
			reference))
		  (multiple-value-bind (form expandedp)
		      (macroexpand-1 form)
		    (if expandedp
			(transform form environment)
			(vector 'funcall-global operator targs)))))))
      (if (symbolp form)
	  (multiple-value-bind (binding obstacles)
	      (binding environment form *stack-obstacles*)
	    (if binding
		(if (consp binding)
		    (transform (car binding) environment)
		    (let ((reference (vector 'reference binding obstacles)))
		      (push reference (aref binding 3))
		      reference))
		(multiple-value-bind (form expandedp)
		    (macroexpand-1 form)
		  (if expandedp
		      (transform form environment)
		      (vector 'dynamic-reference form)))))
	  (vector 'constant form))))
(defun write-c-progn (intermediate stack-height frame-height receiver)
  (do ((intermediate intermediate (cdr intermediate)))
      ((not (cdr intermediate))
       (write-c (if intermediate (car intermediate) (vector 'constant nil))
		stack-height frame-height receiver))
    (write-c (car intermediate) stack-height frame-height nil)))
(defun write-receive (receiver frame-height)
  (case receiver
    ((nil))
    ((t) (format *compiler-output* "return "))
    (t (format *compiler-output* "f[~A]=" (- receiver frame-height)))))
(defwrite-c block-local
  (setf (aref intermediate 5) receiver)
  (write-c-progn (aref intermediate 2) stack-height frame-height receiver)
  (format *compiler-output* "L~A: ;~%" (aref intermediate 4)))
(defwrite-c constant
    (when receiver
      (write-receive receiver frame-height)
      (format *compiler-output* "~A;~%"
	      (intern-constant-string (aref intermediate 1)))))
(defwrite-c dynamic-reference
    (when receiver
      (write-receive receiver frame-height)
      (format *compiler-output* "o2a(~A)[4];~%"
	      (intern-constant-string (aref intermediate 1)))))
(defwrite-c dynamic-setq
  (incf stack-height)
  (write-c (aref intermediate 2) stack-height frame-height stack-height)
  (write-receive receiver frame-height)
  (format *compiler-output* "o2a(~A)[4]=f[~A];~%"
	  (intern-constant-string (aref intermediate 1))
	  (- stack-height frame-height)))
(defwrite-c flet
  (dolist (function (aref intermediate 1))
    (setf (binding-height function) (incf stack-height))
    (write-receive stack-height frame-height)
    (format *compiler-output*
	    "ma(f,5,212,ms(f,3,212,F~A,0,-1),0,0,0,0);~%"
	    (aref function 5))
    (write-string
     (with-output-to-string (*compiler-output*)
       (format *compiler-output* "lval F~A(lval *f, lval *h) {~%"
	       (aref function 5))
       (let ((sh stack-height)
	     (frame-height stack-height))
	 (dolist (arg (aref function 1))
	   (let ((binding (cadr arg)))
	     (setf (binding-height binding) (incf sh))))
	 (write-c-progn (aref function 2) sh frame-height t))
       (format *compiler-output* "}~%"))
     (compilation-output *compilation*)))
  (write-c-progn (aref intermediate 2) stack-height frame-height receiver))
(defwrite-c funcall-global
  (unless (= frame-height stack-height)
    (incf stack-height)
    (format *compiler-output* "f[~A]=f[-1];~%"
	    (- stack-height frame-height)))
  (let ((arg-height (+ 2 stack-height)))
    (dolist (arg (aref intermediate 2))
      (write-c arg stack-height frame-height arg-height)
      (incf arg-height)))
  (write-receive receiver frame-height)
  (format *compiler-output* "call(f~A, ~A, ~A);~%"
	  (if (= frame-height stack-height)
	      ""
	      (conc-string "+"
			   (integer-string (- stack-height frame-height))))
	  (intern-constant-string (aref intermediate 1))
	  (length (aref intermediate 2))))
(defwrite-c funcall-local
  (unless (= frame-height stack-height)
    (incf stack-height)
    (format *compiler-output* "f[~A]=f[-1];~%"
	    (- stack-height frame-height)))
  (format *compiler-output* "f[~A]=f[~A];~%"
	  (+ 1 (- stack-height frame-height))
	  (- (binding-height (aref intermediate 1)) frame-height))
  (let ((arg-height (+ 2 stack-height)))
    (dolist (arg (aref intermediate 2))
      (write-c arg stack-height frame-height arg-height)
      (incf arg-height))
    (write-receive receiver frame-height)
    (format *compiler-output* "F~A(f+~A, f+~A);~%"
	    (aref (aref intermediate 1) 5)
	    (+ 1 (- stack-height frame-height))
	    (- arg-height frame-height))))
(defwrite-c function-global
  (when receiver
    (write-receive receiver frame-height)
    (let ((name (aref intermediate 1)))
      (if (consp name)
	  (format *compiler-output* "o2a(~A)[6];~%"
		  (intern-constant-string (cadr name)))
	  (format *compiler-output* "o2a(~A)[5];~%"
		  (intern-constant-string name))))))
(defwrite-c go
  (format *compiler-output* "goto L~A;~%" (car (aref intermediate 1))))
(defwrite-c go-unbound
  (format *compiler-output* "dbgr(f, 9, ~A, 0);~%"
	  (intern-constant-string (aref intermediate 1))))
(defwrite-c if
  (write-c (aref intermediate 1) stack-height frame-height
	   (+ 1 stack-height))
  (format *compiler-output* "if (f[~A]) {~%"
	  (- (+ 1 stack-height) frame-height))
  (write-c (aref intermediate 2) stack-height frame-height receiver)
  (format *compiler-output* "} else {~%")
  (write-c (aref intermediate 3) stack-height frame-height receiver)
  (format *compiler-output* "}~%"))
(defwrite-c lambda
  (write-string
   (with-output-to-string (*compiler-output*)
     (format *compiler-output* "lval F~A(lval *f, lval *h) {~%"
	     (aref intermediate 5))
     (let ((frame-height stack-height))
       "(incf stack-height)"
       (dolist (arg (aref intermediate 1))
	 (let ((binding (cadr arg)))
	   (setf (binding-height binding) (incf stack-height))))
       (write-c-progn (aref intermediate 2) stack-height frame-height t))
     (format *compiler-output* "}~%"))
   (compilation-output *compilation*))
  (write-receive receiver frame-height)
  (format *compiler-output* "ma(f,5,212,ms(f,3,212,F~A,0,-1),0,0,0,0);~%"
	  (aref intermediate 5)))
(defwrite-c let
  (incf stack-height)
  (setf (binding-height intermediate) stack-height)
  (write-c (aref intermediate 1) (- stack-height 1) frame-height
	   stack-height)
  (write-c-progn (aref intermediate 2) stack-height frame-height receiver))
(defwrite-c progn
  (write-c-progn (aref intermediate 1) stack-height frame-height receiver))
(defwrite-c reference
  (when receiver
    (write-receive receiver frame-height)
    (format *compiler-output* "f[~A];~%"
	    (- (binding-height (aref intermediate 1)) frame-height))))
(defwrite-c return-from
  (let ((binding (aref intermediate 1)))
    (write-c (aref intermediate 3) stack-height frame-height
	     (aref binding 5))
    (format *compiler-output* "goto L~A;~%" (aref binding 4))))
(defwrite-c return-from-unbound
  (format *compiler-output* "dbgr(f, 8, ~A, 0);~%"
	  (intern-constant-string (aref intermediate 1))))
(defwrite-c setq
  (write-c (aref intermediate 3) stack-height frame-height
	   (binding-height (aref intermediate 1))))
(defwrite-c tag
  (format *compiler-output* "L~A: ;~%" (aref intermediate 1)))
(defwrite-c tagbody-local
  (dolist (form (aref intermediate 1))
    (write-c form stack-height frame-height nil))
  (when receiver
    (write-receive receiver frame-height)
    (format *compiler-output* "0;~%")))
(defun write-c (intermediate &optional (stack-height 0) (frame-height 0)
		receiver)
  (let ((write-c (gethash (aref intermediate 0) *write-cs*)))
    (if write-c
	(funcall write-c intermediate stack-height frame-height receiver)
	(error))))
(defstruct (compilation
	     (:constructor construct-compilation
			   (package-hash symbol-hash class-hash value-hash
					 values opaques output)))
  package-hash
  symbol-hash
  class-hash
  value-hash
  (value-length 0)
  (packages nil)
  (symbols nil)
  (classes nil)
  values
  opaques
  output
  (label-counter 0))
(defun test-compilation (val)
  (let ((basename "test"))
    (with-open-file (*compiler-output* (conc-string basename ".c")
				       :direction :output)
      (let ((*compilation* (start-compilation)))
	(finish-compilation (with-output-to-string (*compiler-output*)
			      (write-c (transform val))))))
    (run-cc basename)))
(defun test-transform (val)
  (let ((*compilation* (start-compilation)))
    (transform val)))
(defun show-ascii-art ()
  (write-line "         ___     _,.--.,_")
  (write-line "      .-~   ~--\"~-.   ._ \"-.")
  (write-line "     /      ./_    Y    \"-. \\")
  (write-line "    Y       :~     !         Y")
  (write-line "    lq p    |     /         .|")
  (write-line " _   \\. .-, l    /          |j")
  (write-line "()\\___) |/   \\_/\";          !")
  (write-line " \\._____.-~\\  .  ~\\.      ./")
  (write-line "            Y_ Y_.\"vr\"~  T")
  (write-line "            (  (    |L    j")
  (write-line "            [nn[nn..][nn..]"))
(show-ascii-art)
(read-eval-print-loop)