Trailing-Edge - PDP-10 Archives - clisp - clisp/upsala/trans.clisp
There are no other files named trans.clisp in the archive.
;;; This is a -*-Lisp-*- file.

;;; Copyright (c) 1985 J S Hall, C L Hedrick

;;; Source-level transforms for the Common Lisp Compiler.  These
;;; transforms work like macros, but are only used when compiling.

;;; Original version by Scott Fahlman, Dave Dill, Skef Wholey, et al.
;;; Modified for the Dec-20 by Dave Steiner.

(in-package "COMPILER")
;;; **********************************************************************

;;;; Random utilities:

;;; will be expanded later...
(defun find-type (x) t)
;;;; Functions for Building the Compiler Environment.

;;; DEFTRANSFORM is like DEFMACRO, but adds the expander function to
;;; a list kept under the function's TRANSFORMS property.  There can be
;;; many transforms for a given function, and they are applied until the
;;; form is changed into something without transforms or until all of the
;;; transforms pass.  If a transform does not want to change a function,
;;; it should return the marker %PASS%.

(eval-when (eval)
(defmacro deftransform (fn name arglist &body body)
  (let ((local-decs nil)
	(lisp::%arg-count 0)
	(lisp::%min-args 0)
	(lisp::%restp nil)
	(lisp::%let-list nil)
	(lisp::%keyword-tests nil))
    (declare (special lisp::%arg-count lisp::%min-args lisp::%restp
		      lisp::%let-list lisp::%keyword-tests))
    ;; Check for local declarations and documentation string.
    (prog ()
      (cond ((atom body)
	     (setq body '(nil)))
	    ((and (not (atom (car body))) (eq (caar body) 'declare))
	     (setq local-decs (append local-decs (cdar body)))
	     (setq body (cdr body))
	     (go loop))
	    ((and (stringp (car body)) (not (null (cdr body))))
	     (setq body (cdr body))
	     (go loop))))
    ;; Analyze the defmacro argument list.
    (lisp::analyze1 arglist '(cdr **form**) fn '**form**)
    ;; Now build the body of the transform.
    (when (null arglist) (push '(ignore **form**) local-decs))
    (setq body `(let* ,(nreverse lisp::%let-list)
		  ,@(and local-decs (list (cons 'declare local-decs)))
		  ,@ body))
      (defun ,name (**form**) ,body)
      (%put ',fn 'clc-transforms (cons ',name (get ',fn 'clc-transforms)))))))

;;; Once-Only returns a piece of code in which the body is evaluated with each
;;; of the variables in Var-List bound to the corresponding form iff the form
;;; is non-trivial.  This is mainly of use in writing transforms and such.
;;; A typical use looks like:
;;; (deftransform foo foo-transform (a b c)
;;;   (once-only ((a-name a) (b-name b))
;;;     `(bar ,a-name ,b-name ,c ,a-name ,b-name)))
;;; <=>
;;; (deftransform foo foo-transform (a b c)
;;;   (let ((a-name (if (trivialp a) a (new-internal-variable)))
;;;         (b-name (if (trivialp b) b (new-internal-variable))))
;;;     `(let (,@(unless (eq a a-name) `((,a-name ,a)))
;;;            ,@(unless (eq b b-name) `((,b-name ,b))))
;;;        `(bar ,a-name ,b-name ,c ,a-name ,b-name))))

(eval-when (eval)
(defmacro once-only (var-list &rest body)
  (do ((var-list var-list (cdr var-list))
       (name-bindings ())
       (variable-bindings ()))
      ((null var-list)
       `(let ,name-bindings
	  (list 'let (nconc ,@variable-bindings) ,@body)))
    (let ((var-name (caar var-list))
	  (var (cadar var-list))
	  (gensym (new-internal-variable)))
      (push `(,var-name (if (trivialp ,var) ,var ',gensym))
      (push `(if  (not (eq ,var-name ,var)) (list (list ',gensym ,var)))

(eval-when (eval)
(defmacro new-internal-variable ()
  '(if *currently-free-internal-variables*
       (pop *currently-free-internal-variables*)

;;; Defsynonym declares NEW to be a synonym for OLD.  Both must be symbols
;;; appearing the function position of a form.

(defmacro defsynonym (new old)
  `(%put ',new 'synonym ',old))

;;; needed when compiling code in a running lisp

(deftransform lisp::*macroexpansion* macex-xform (foo bar)
  (declare (ignore bar))


;;; Turn any multiple SETQ forms into a progn of individual SETQs.
;;; Setq of 0 pairs is legal, and returns NIL.

(deftransform setq setq-transform (&rest pairs)
  (let ((n (length pairs)))
    (cond ((zerop n) nil)
	  ((= n 2)
	   (test-varname (car pairs))
	  ((oddp n)
	   (clc-error "Odd number of args to SETQ.")
	  (t (do ((m pairs (cddr m))
		  (l nil))
		 ((null m)
		  `(progn ,@(nreverse l)))
	       (push `(setq ,(car m) ,(cadr m)) l))))))

;;; Handle cases of PSETQ with 0, 2 or odd number of args.

(deftransform psetq psetq-transform (&rest pairs)
  (let ((n (length pairs)))
    (cond ((zerop n) nil)
	  ((= n 2)
	   `(setq ,(car pairs) ,(cadr pairs)))
	  ((oddp n)
	   (clc-error "Odd number of args to PSETQ.")
	  (t '%pass%))))


;;; Just turn NULL into NOT.

(defsynonym null not)

;;; Handle degenerate case of NOT with constant or null argument.

(deftransform not not-transform (x)
  (cond ((or (null x) (equal x '(quote nil))) t)
	((or (eq x t) (equal x '(quote t))) nil)
	(t '%pass%)))

;;; Transform for EQ.  If one arg is NIL, convert form to NOT test.

(deftransform eq eq-transform (x y)
  (cond ((or (null x) (equal x '(quote nil))) `(not ,y))
	((or (null y) (equal y '(quote nil))) `(not ,x))
	(t '%pass%)))

;;; Transform for EQL.  Convert to EQ where one arg is constant and not
;;; a number.

(deftransform eql eql-transform (x y)
  (cond ((fixnump x) `(eq ,x ,y))
	((fixnump y) `(eq ,x ,y))
	((numberp x) '%pass%)
	((numberp y) '%pass%)
	((or (constantp x) (constantp y))
	 `(eq ,x ,y))
	(t '%pass%)))

;;; Transform for =.   This only handles the two-arg case.
;;; If one arg is zero, convert to ZEROP.

(deftransform = =-transform (x &rest y)
  (cond ((not (= (length y) 1)) '%pass%)
	((and (numberp x) (zerop x))
	 `(zerop ,(car y)))
	((and (numberp (car y)) (zerop (car y)))
	 `(zerop ,x))
	(t '%pass%)))

(deftransform return return-transform (&optional (value nil))
  `(return-from nil ,value))

(deftransform prog prog-transform (varlist &rest forms)
  (let* ((pb (parse-body2 forms))
	 (decls (car pb))
	 (body (cadr pb)))
    `(let ,varlist
       (declare ,@decls)
       (block nil (tagbody ,@body)))))

(deftransform prog* prog*-transform (varlist &rest forms)
  (let* ((pb (parse-body2 forms))
	 (decls (car pb))
	 (body (cadr pb)))
    `(let* ,varlist
       (declare ,@decls)
       (block nil (tagbody ,@body)))))

;;; progv now handled directly
;;; throw and catch now compiled in the right order
;;; The following transform only gets called on DEFUN forms not at top level.

;;; It makes sure that the function name gets printed out by setting *verbose*
;;; on and setting up *inner-function-name*, so that the first function forms
;;; in the code as we look down (only the one 10 lines below) get compiled as
;;; if it had that name.

(deftransform defun defun-transform (name varlist &rest forms)
  (let* ((pb (parse-body1 forms))
	 (decls (car pb))
	 (doc (cadr pb))
	 (body (caddr pb)))
    `(compiler-let ((*verbose* t)
		    (*inner-function-name* ',name))
       ,@(if doc `((%put ',name 'lisp::%fun-documentation ',doc)))
       (remprop ',name 'lisp::macro-in-compiler)
       (setf (symbol-function ',name)
	     (function (lambda ,varlist
			 (declare ,@decls)
			 (block ,name ,@body))))

;;; The following transform catches EVAL-WHEN forms that are not at top level.

(deftransform eval-when eval-when-transform (situations &rest forms)
  (cond ((or (atom situations)
	     (eq 'quote (car situations)))
	 (clc-error "Ill-formed EVAL-WHEN situation list: ~S. ~
		     Ignoring its contents." situations)
	(t (let ((*eval-when-compile* (memq 'compile situations))
		 (*eval-when-load* (memq 'load situations)))
	    (dolist (x forms) (process-form x))
	    (if (memq 'EVAL situations)
		`(progn ,@forms))))))

;;; For Funcall, if the function is 'symbol or #'symbol (and the symbol isn't
;;; functionally bound in the current lexical environment), turn it into the
;;; equivalent form with the symbol in the car.

(deftransform funcall funcall-transform (fn &rest args)
  (if (and (consp fn)
	   (consp (cdr fn))
	   (symbolp (cadr fn))
	   (or (eq (car fn) 'function)
	       (and (eq (car fn) 'quote)
		    (not (assq (cadr fn) *fenv*)))))
      (cons (cadr fn) args)

;;; IDENTITY turns into its arg.

(deftransform identity identity-transform (x) `(values ,x))

(deftransform caar caar-transform (x) `(car (car ,x)))
(deftransform cadr cadr-transform (x) `(car (cdr ,x)))
(deftransform cdar cdar-transform (x) `(cdr (car ,x)))
(deftransform cddr cddr-transform (x) `(cdr (cdr ,x)))
(deftransform caaar caaar-transform (x) `(car (car (car ,x))))
(deftransform caadr caadr-transform (x) `(car (car (cdr ,x))))
(deftransform cadar cadar-transform (x) `(car (cdr (car ,x))))
(deftransform caddr caddr-transform (x) `(car (cdr (cdr ,x))))
(deftransform cdaar cdaar-transform (x) `(cdr (car (car ,x))))
(deftransform cdadr cdadr-transform (x) `(cdr (car (cdr ,x))))
(deftransform cddar cddar-transform (x) `(cdr (cdr (car ,x))))
(deftransform cdddr cdddr-transform (x) `(cdr (cdr (cdr ,x))))
(deftransform caaaar caaaar-transform (x) `(car (car (car (car ,x)))))
(deftransform caaadr caaadr-transform (x) `(car (car (car (cdr ,x)))))
(deftransform caadar caadar-transform (x) `(car (car (cdr (car ,x)))))
(deftransform caaddr caaddr-transform (x) `(car (car (cdr (cdr ,x)))))
(deftransform cadaar cadaar-transform (x) `(car (cdr (car (car ,x)))))
(deftransform cadadr cadadr-transform (x) `(car (cdr (car (cdr ,x)))))
(deftransform caddar caddar-transform (x) `(car (cdr (cdr (car ,x)))))
(deftransform cadddr cadddr-transform (x) `(car (cdr (cdr (cdr ,x)))))
(deftransform cdaaar cdaaar-transform (x) `(cdr (car (car (car ,x)))))
(deftransform cdaadr cdaadr-transform (x) `(cdr (car (car (cdr ,x)))))
(deftransform cdadar cdadar-transform (x) `(cdr (car (cdr (car ,x)))))
(deftransform cdaddr cdaddr-transform (x) `(cdr (car (cdr (cdr ,x)))))
(deftransform cddaar cddaar-transform (x) `(cdr (cdr (car (car ,x)))))
(deftransform cddadr cddadr-transform (x) `(cdr (cdr (car (cdr ,x)))))
(deftransform cdddar cdddar-transform (x) `(cdr (cdr (cdr (car ,x)))))
(deftransform cddddr cddddr-transform (x) `(cdr (cdr (cdr (cdr ,x)))))

(deftransform first first-transform (x) `(car ,x))
(deftransform second second-transform (x) `(cadr ,x))
(deftransform third third-transform (x) `(caddr ,x))
(deftransform fourth fourth-transform (x) `(cadddr ,x))
(deftransform fifth fifth-transform (x) `(car (cddddr ,x)))
(deftransform sixth sixth-transform (x) `(cadr (cddddr ,x)))
(deftransform seventh seventh-transform (x) `(caddr (cddddr ,x)))
(deftransform eighth eighth-transform (x) `(cadddr (cddddr ,x)))
(deftransform ninth ninth-transform (x) `(car (cddddr (cddddr ,x))))
(deftransform tenth tenth-transform (x) `(cadr (cddddr (cddddr ,x))))

;;; Transform to open code short NTH and NTHCDR.
(deftransform nth nth-transform (n l)
  `(car (nthcdr ,n ,l)))

(deftransform nthcdr nthcdr-transform (n l)
  (if (and (integerp n) (< -1 n *nthcdr-open-code-limit*))
      (do ((x n (1- x))
	   (f l (list 'cdr f)))
	  ((zerop x) f))

(deftransform plusp plusp-transform (x)
  `(> ,x 0))

(deftransform minusp minusp-transform (x)
  `(< ,x 0))

(deftransform oddp oddp-transform (x)
  `(not (zerop (boole 1 ,x 1))))

(deftransform evenp evenp-transform (x)
  `(zerop (boole 1 ,x 1)))

;;; Handler for multi-argument comparisons.  Basically, turn things
;;; like (> a b c ... ) to (AND (> a b) (> b c) ... ).  But if an
;;; interior arg is not a number or symbol, have to do a setq to
;;; avoid evaling the arg twice.  If any setqs are needed, have to
;;; make one extra local variable with a LET form.

#|  this code commented out. the kernel loop for multi-compare is faster.

(defun multi-compare (form)
  (cond ((= (length form) 2) 't)
	((= (length form) 3) '%pass%)
	;; Simple case, args have no side effects.
	((do ((args (cdr form) (cdr args))
	      (result nil))
	     ((atom (cdr args))
	      (cons 'and (nreverse result)))
	   (cond ((trivialp (car args))
		  (push `(,(car form) ,(car args) ,(cadr args)) result))
		 (t (return nil)))))
	;; Bad case, eval all args first, exactly once.
	(t (do ((args (cddr form) (cdr args))
		(oldvar (if (numberp (cadr form))
			    (cadr form)
		(oldarg (cadr form) (car args))
		(newvar nil)
		(varlist nil (if (numberp oldvar)
				 (cons (list oldvar oldarg) varlist)))
		(result nil))
	       ((null args)
		(or (numberp oldvar)
		    (push (list oldvar oldarg) varlist))
		`(let ,(nreverse varlist) (and ,@(nreverse result))))
	     (setq newvar (if (numberp (car args))
			      (car args)
	     (push `(,(car form) ,oldvar ,newvar) result)))))

(push 'multi-compare (get '= 'clc-transforms))
(push 'multi-compare (get '> 'clc-transforms))
(push 'multi-compare (get '< 'clc-transforms))
(push 'multi-compare (get '>= 'clc-transforms))
(push 'multi-compare (get '<= 'clc-transforms))

End of commented-out code.  |#

;;; Convert 2-arg comparisons to equivalents.

(deftransform >= >=-two-arg (x &rest y)
  (if (= (length y) 1)
      `(not (< ,x ,(car y)))

(deftransform <= <=-two-arg (x &rest y)
  (if (= (length y) 1)
      `(not (> ,x ,(car y)))

;;; /= is different, since it requires every element of the arglist to
;;; be compared to every other -- a doubly-nested DO loop.  Only open-code
;;; the one arg and two arg cases, and let the rest go call the actual /=
;;; function.

(deftransform /= /=-transform (x &rest more)
  (cond ((null more) 't)
	((null (cdr more))
	 `(not (= ,x ,(car more))))
	(t '%pass%)))

;;; Transforms for max and min.  Zap one-arg case and open-code
;;; two-arg case.

(deftransform max max-transform (x &rest more)
  (cond ((null more) `(values ,x))
	((null (cdr more))
	 (once-only ((a x) (b (car more)))
	   `(if (> ,a ,b) ,a ,b)))
	(t '%pass%)))

(deftransform min min-transform (x &rest more)
  (cond ((null more) `(values ,x))
	((null (cdr more))
	 (once-only ((a x) (b (car more)))
	   `(if (< ,a ,b) ,a ,b)))
	(t '%pass%)))

;;; Transform for multi-arg arithmetic and logical functions.

(defun multi-arith (form)
  (if (< (length form) 4)
      (do ((f form `(,op (,op ,(cadr f) ,(caddr f)) ,@(cdddr f)))
	   (op (car form)))
	  ((< (length f) 4) f))))

(push 'multi-arith (get '+ 'clc-transforms))
(push 'multi-arith (get '- 'clc-transforms))
(push 'multi-arith (get '* 'clc-transforms))
(push 'multi-arith (get '/ 'clc-transforms))
(push 'multi-arith (get 'logior 'clc-transforms))
(push 'multi-arith (get 'logxor 'clc-transforms))
(push 'multi-arith (get 'logand 'clc-transforms))
(push 'multi-arith (get 'logeqv 'clc-transforms))

;;; Some of the following use EQL on numbers deliberately.  If the number
;;; is merely = to 1 or 0, it might be a float and should cause contagion.
;; we cheat and use EQ since it works on -20 clisp.  Fix if ported.

(deftransform + +-transform (&rest args)
  (cond ((null args) 0)
	((null (cdr args)) `(values ,(car args)))
	((cddr args) '%pass%)
	((eq (car args) 0) `(values ,(cadr args)))
	((eq (car args) 1) `(1+ ,(cadr args)))
	((eq (cadr args) 0) `(values ,(car args)))
	((eq (cadr args) 1) `(1+ ,(car args)))
	(t '%pass%)))

(deftransform - --transform (x &rest args)
  (cond ((cdr args) '%pass%)
	((eq (car args) 0) `(values ,x))
	((eq (car args) 1) `(1- ,x))
	(t '%pass%)))

(deftransform * *-transform (&rest args)
  (cond ((null args) 1)
	((null (cdr args)) `(values ,(car args)))
	((cddr args) '%pass%)
	((eq (car args) 1) `(values ,(cadr args)))
	((eq (cadr args) 1) `(values ,(car args)))
	((or (eq (car args) 0) (eq (cadr args) 0)) 0)
	(t '%pass%)))

(deftransform / /-transform (x &rest args)
  (cond ((null args) `(/ 1 ,x))
	((cdr args) '%pass%)
	((eql (car args) 0)
	 (clc-warning "Dividing by constant 0.")
	((eq (car args) 1) `(values ,x))
	(t '%pass%)))

;;; Transform one-arg forms to two-arg with 1 as second arg.  Also
;;; if not for value, just eval args for side-effect.

(defun second-arg-is-1 (form)
  ;; All of these guys return multiple values.
  (cond ((cddr form) '%pass%)
	(t `(,(car form) ,(cadr form) 1))))

(push 'second-arg-is-1 (get 'truncate 'clc-transforms))
(push 'second-arg-is-1 (get 'floor 'clc-transforms))
(push 'second-arg-is-1 (get 'ceiling 'clc-transforms))
(push 'second-arg-is-1 (get 'round 'clc-transforms))
(push 'second-arg-is-1 (get 'ftruncate 'clc-transforms))
(push 'second-arg-is-1 (get 'ffloor 'clc-transforms))
(push 'second-arg-is-1 (get 'fceiling 'clc-transforms))
(push 'second-arg-is-1 (get 'fround 'clc-transforms))

;;; Handle degenerate 0 and 1 arg cases of logical functions.

(deftransform logior logior-transform (&rest args)
  (cond ((null args) 0)
	((null (cdr args)) `(values ,(car args)))
	(t '%pass%)))

(deftransform logxor logxor-transform (&rest args)
  (cond ((null args) 0)
	((null (cdr args)) `(values ,(car args)))
	(t '%pass%)))

(deftransform logand logand-transform (&rest args)
  (cond ((null args) -1)
	((null (cdr args)) `(values ,(car args)))
	(t '%pass%)))

;;; Other logical functions.

(deftransform logeqv logeqv-transform (&rest args)
  (cond ((null args) -1)
	((null (cdr args)) `(values ,(car args)))
	((null (cddr args))
	 `(lognot (boole 6 ,(car args) ,(cadr args))))
	(t '%pass%)))

(deftransform lognand lognand-transform (x y)
  `(boole 14 ,x ,y))

(deftransform lognor lognor-transform (x y)
  `(boole 8 ,x ,y))

(deftransform logandc1 logandc1-transform (x y)
  `(boole 2 ,x ,y))

(deftransform logandc2 logandc2-transform (x y)
  `(boole 4 ,x ,y))

(deftransform logorc1 logorc1-transform (x y)
  `(boole 11 ,x ,y))

(deftransform logorc2 logorc2-transform (x y)
  `(boole 13 ,x ,y))

(deftransform logtest logtest-transform (x y)
  `(not (zerop (boole 1 ,x ,y))))

(deftransform logbitp logbitp-transform (x y)
  `(not (zerop (ldb (byte 1 ,x) ,y))))

;;; Byte specifier is just the cons of Size and Position.

(defsynonym byte cons)
(defsynonym byte-size car)
(defsynonym byte-position cdr)

(deftransform ldb-test ldb-test-transform (bytespec x)
  `(not (zerop (ldb ,bytespec ,x))))

;;; General Lisp-level accessors:

(deftransform aref aref-transform (array &rest indices)
  (let ((index (car indices)))
    (if (null (cdr indices))
	(case (find-type array)
	  (simple-vector `(svref ,array ,index))
	  (simple-string `(schar ,array ,index))
	  (simple-bit-vector `(sbit ,array ,index))
	  (simple-array `(lisp::%sp-saref1 ,array ,index))
	  (t '%pass%))

(deftransform char char-transform (array index)
  (if (eq (find-type array) 'simple-string)
      `(schar ,array ,index)
      `(aref ,array ,index)))

(deftransform bit bit-transform (array index)
  (if (eq (find-type array) 'simple-bit-vector)
      `(sbit ,array ,index)
      `(aref ,array ,index)))

;;; General Lisp-level setters:

(deftransform %aset %aset-transform (array index new &rest more)
  (if (null more)
      (case (find-type array)
	(simple-vector `(%svset ,array ,index ,new))
	(simple-string `(%scharset ,array ,index ,new))
	(simple-bit-vector `(%sbitset ,array ,index ,new))
	(simple-array `(lisp::%sp-saset1 ,array ,index ,new))
	(t '%pass%))

(deftransform %charset %charset-transform (array index new)
  (if (eq (find-type array) 'simple-string)
      `(%scharset ,array ,index ,new)
      `(%aset ,array ,index ,new)))

(deftransform %bitset %bitset-transform (array index new)
  (if (eq (find-type array) 'simple-bit-vector)
      `(%sbitset ,array ,index ,new)
      `(%aset ,array ,index ,new)))

(defsynonym svref lisp::%sp-svref)
(defsynonym lisp::%svset lisp::%sp-svset)

;;; CHAR= is just EQ in this system.

(deftransform char= char=-transform (char &rest more)
  (cond ((null more) t)
	((null (cdr more)) `(eq ,char ,(car more)))
	(t '%pass%)))

;;; Handle >2 arg cases just like numerical comparisons.
(push 'multi-compare (get 'char= 'clc-transforms))
(push 'multi-compare (get 'char> 'clc-transforms))
(push 'multi-compare (get 'char< 'clc-transforms))
(push 'multi-compare (get 'char>= 'clc-transforms))
(push 'multi-compare (get 'char<= 'clc-transforms))
;;; Like /=, this requires that all chars be compared.

(deftransform char/= char/=-transform (char &rest more)
  (cond ((null more) t)
	((null (cdr more)) `(not (eq ,char ,(car more))))
	(t '%pass%)))
;;; A transform for FORMAT, courtesy of Skef.

(deftransform format format-transform (stream control &rest args)
  (if (and (simple-string-p control)
	   (trivialp stream)
	   (or (eq stream t) (eq (find-type stream) 'stream)))
      (do* ((index 0)
	    (forms ())
	    (end (length control))
	    (penultimus (1- end))
	    (stream-var (new-internal-variable))
	    (stream-form (if (eq stream t) () `(,stream-var))))
	  ((= index end)
	   `(let (,@(if (eq stream t)
			`((,stream-var ,stream))))
	      ,@(nreverse forms)
	(let* ((command-index (position #\~ (the simple-string control)
					:start index)))
	  (cond (command-index
		 (when (= command-index penultimus)
		   (clc-error "FORMAT control string ends in a ~~: ~S" control)
		   (return '%pass%))
		 ;; Get the format directive.
		 (let ((command-char (schar control (1+ command-index))))
		   ;; Non-command stuff gets write-string'ed out.
		   (if (/= index command-index)
		       (push `(write-string
			       ,(subseq (the simple-string control)
					index command-index)
		   ;; Generate code for the command.
		    (case command-char
		      ((#\b #\B) `(let ((*print-base* 2))
				    (princ ,(pop args) ,@stream-form)))
		      ((#\o #\O) `(let ((*print-base* 8))
				    (princ ,(pop args) ,@stream-form)))
		      ((#\d #\D) `(let ((*print-base* 10))
				    (princ ,(pop args) ,@stream-form)))
		      ((#\x #\X) `(let ((*print-base* 16))
				    (princ ,(pop args) ,@stream-form)))
		      ((#\a #\A) `(princ ,(pop args) ,@stream-form))
		      ((#\s #\S) `(prin1 ,(pop args) ,@stream-form))
		      (#\% `(terpri ,@stream-form))
		      (#\& `(fresh-line ,@stream-form))
		      (#\| `(write-char #\form ,@stream-form)) ; |) for EMACS
		      (#\~ `(write-char #\~ ,@stream-form))
		       (let ((new-pos (position-if-not
				       (the simple-string control)
				       :start (+ command-index 2))))
			 (if new-pos
			     (setq command-index (- new-pos 2)))))
		      (t (return '%pass%)))
		 (setq index (+ command-index 2)))
		 ;; Write out the final part of the string.
		 (push `(write-string ,(subseq (the simple-string control)
					       index end)
		 (setq index end)))))
;;; Write-Line and Write-String take keyword args, but people call them who 
;;; don't want to cons.  So we turn them into calls to non-keyword parsing 
;;; functions.

(deftransform write-string write-string-transform
  (string &optional (stream '*standard-output*)
	  &key (start 0) (end))
  `(lisp::%sp-write-string ,string ,stream ,start ,end))

(deftransform write-line write-line-transform
  (string &optional (stream '*standard-output*)
	  &key (start 0) (end))
    (lisp::%sp-write-string ,string ,stream ,start ,end)
    (terpri ,stream)))

(deftransform do do-transform (varlist endlist &body body)
  (let ((decl nil) (inits nil) (steps nil) (l1 (gensym)) (l2 (gensym)))
    ;; Check for illegal old-style do.
    (if (or (and varlist (atom varlist))
            (and endlist (atom endlist)))
        (error "Ill-formed DO -- possibly illegal old style DO?" nil))
    ;; Dig out the declarations.
    (do ((b body (cdr b)))
        ((or (atom b)
             (not (and b (car b) (listp (car b))
                       (eq (caar b) 'declare))))
         (setq decl (nreverse decl))
         (setq body b))
      (setq decl (cons (car b) decl)))
    ;; Parse the varlist to get inits and steps.
    (do ((vl varlist (cdr vl))
        ((atom vl))
      (setq v (car vl))
      (cond ((atom v)
             (setq inits (cons v inits)))
            ((and (= (length v) 1) (symbolp (car v)))
             (setq inits (cons (car v) inits)))
            ((and (= (length v) 2) (symbolp (car v)))
             (setq inits (cons v inits)))
            ((and (= (length v) 3) (symbolp (car v)))
             (setq inits (cons (list (car v) (cadr v)) inits))
             (setq steps (cons (caddr v) (cons (car v) steps))))
            (t (error "~S is illegal form in a DO varlist." v))))
    ;; And finally construct the new form.
    `(block nil
       (let ,(nreverse inits)
           (go ,L2)
           (psetq ,@(nreverse steps))
           (unless ,(car endlist) (go ,L1))
           (return (progn ,@(cdr endlist))))))))

(deftransform do* do*-transform (varlist endlist &body body)
  (let ((decl nil) (inits nil) (steps nil) (l1 (gensym)) (l2 (gensym)))
    ;; Check for illegal old-style do.
    (if (or (and varlist (atom varlist))
            (and endlist (atom endlist)))
        (error "Ill-formed DO -- possibly illegal old style DO?" nil))
    ;; Dig out the declarations.
    (do ((b body (cdr b)))
        ((or (atom b)
             (not (and b (car b) (listp (car b))
                       (eq (caar b) 'declare))))
         (setq decl (nreverse decl))
         (setq body b))
      (setq decl (cons (car b) decl)))
    ;; Parse the varlist to get inits and steps.
    (do ((vl varlist (cdr vl))
        ((atom vl))
      (setq v (car vl))
      (cond ((atom v)
             (setq inits (cons v inits)))
            ((and (= (length v) 1) (symbolp (car v)))
             (setq inits (cons (car v) inits)))
            ((and (= (length v) 2) (symbolp (car v)))
             (setq inits (cons v inits)))
            ((and (= (length v) 3) (symbolp (car v)))
             (setq inits (cons (list (car v) (cadr v)) inits))
             (setq steps (cons (caddr v) (cons (car v) steps))))
            (t (error "~S is illegal form in a DO varlist." v))))
    ;; And finally construct the new form.
    `(block nil
       (let* ,(nreverse inits)
           (go ,L2)
           (setq ,@(nreverse steps))
           (unless ,(car endlist) (go ,L1))
           (return (progn ,@(cdr endlist))))))))

(deftransform dotimes dotimes-transform
  ((var count &optional (result nil)) &body body)
  (cond ((numberp count)
         `(do ((,var 0 (1+ ,var)))
              ((>= ,var ,count) ,result)
        (t (let ((v1 (gensym)))
             `(do ((,var 0 (1+ ,var)) (,v1 ,count))
                  ((>= ,var ,v1) ,result)

(deftransform dolist dolist-transform
  ((var list &optional (result nil)) &body body)
  (let ((v1 (gensym)))
    `(do* ((,v1 ,list (cdr ,v1))
           (,var (car ,v1) (car ,v1)))
          ((atom ,v1) ,result)
;;; Map-hash

;;; The following code is actually not quite as good as the code
;;; in the interpreter.  However because it is inline, it allows us
;;; to avoid producing closures in many cases.  At the moment this
;;; is a great advantage.

;;; The following is a sneaky way to produce Lisp objects with arbitrary
;;; binary codes.

;;; delkey is a special key used for deleted objects

(defvar delkey (lisp::%deposit-word 5 #o010000000126))

;;; nilkey is a special key used for NIL, since nil mean unassigned

(defvar nilkey (lisp::%deposit-word 5 #o010000000000))

;;; Now for the actual transform

(deftransform maphash maphash-trans (&rest form)
  (let (fn key funcallp hashtab)
    (setq fn (car form)
	  hashtab (cadr form))
    (cond ((atom fn) (setq funcallp t))
	  ((eq (car fn) 'quote)
	   (error "Use /#/' for functional args.")
	   (setq fn (cadr fn)))
	  ((eq (car fn) 'function) (setq fn (cadr fn)))
	  (t (setq funcallp t)))
    (setq fn (cond (funcallp `(funcall ,fn key (lisp::%sp-svref hashtab index2)))
		   (t `(,fn key (lisp::%sp-svref hashtab index2)))))
    `(let* ((makmaph-hashtab ,hashtab)
	    (hashsize (lisp::%sp-svref makmaph-hashtab 0))
	    (hashtab (lisp::%sp-svref makmaph-hashtab 5))
	(do ((index 0 (1+ index))
	     (index2 hashsize (1+ index2)))
	    ((eq index hashsize))
	  (unless (or (not (setq key (lisp::%sp-svref hashtab index)))
		      (eq key delkey))
		  (if (eq key nilkey)
		      (setq key nil))

(defun whitespace-char-p (c) (lisp::whitespacep c))