(FILECREATED "16-Nov-84 09:03:37" {ERIS}<LISPNEW>FONTUNPARSEPATCH.;5
 6055   

      changes to:  (FNS FONTCREATE FONTUNPARSE)

      previous date: "13-Nov-84 18:27:04" {ERIS}<LISPNEW>FONTUNPARSEPATCH.;2)


(* Copyright (c) 1984 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT FONTUNPARSEPATCHCOMS)

(RPAQQ FONTUNPARSEPATCHCOMS
 ((FNS FONTUNPARSE FONTCREATE)))
(DEFINEQ

(FONTUNPARSE

  [LAMBDA (FONT)                                             (* rmk: "15-Nov-84 17:24")

                                                             (* Used by TEDIT, should be flushed after Harmony)

    (
PROG
 [FACE (SPEC (
COND

			((TYPE?
 FONTDESCRIPTOR FONT)
			  (
FONTPROP
 FONT (
QUOTE
 SPEC)))
			(T                                   (* Could be a non-instantiated specification of a 

							     fontclass, just use it as the spec without creating the

							     font.)

			   FONT]
          (
OR
 SPEC (
RETURN
))
          (
SETQ
 FACE (
CADDR
 SPEC))
          [
SETQ
 FACE (if
 [
NOT
 (
EQUAL
 FACE (
QUOTE
 (MEDIUM REGULAR REGULAR]
			 then
 (
PACK*
 (
NTHCHAR
 (
CAR
 FACE)
					      1)
				     (
NTHCHAR
 (
CADR
 FACE)
					      1)
				     (
NTHCHAR
 (
CADDR
 FACE)
					      1]             (* Don't return device, or any trailing defaults)

          (
RETURN
 (
CONS
 (
CAR
 SPEC)
			(
CONS
 (
CADR
 SPEC)
			      (if
 (
NEQ
 0 (
CADDDR
 SPEC))
				  then
 (
LIST
 FACE (
CADDDR
 SPEC))
				elseif
 FACE
				  then
 (
CONS
 FACE])

(FONTCREATE

  [LAMBDA (FAMILY SIZE FACE ROTATION DEVICE NOERRORFLG)      (* rmk: "16-Nov-84 09:03")

                                                             (* Cache and fonts.widths traffic in uppercase only.)

    (DECLARE
 (
GLOBALVARS
 IMAGESTREAMTYPES))
    (
PROG
 [FONTX (DEV (
COND

			((type?
 STREAM DEVICE)
			  (fetch
 IMFONTCREATE of
 (fetch
 IMAGEOPS of
 DEVICE)))
			(DEVICE)
			(T (
QUOTE
 DISPLAY]
          (
RETURN
 (
COND

		    ((
LISTP
 FAMILY)
		      (
COND

			((
EQ
 (
CAR
 FAMILY)
			     (
QUOTE
 FONT))
			  (
SETQ
 FONTX (
CDR
 FAMILY)))
			(T (
SETQ
 FONTX FAMILY)))
		      (FONTCREATE
 (
CAR
 FONTX)
				  (
OR
 (
CADR
 FONTX)
				      SIZE)
				  (
OR
 (
CADDR
 FONTX)
				      FACE)
				  (
OR
 (
CADDDR
 FONTX)
				      ROTATION)
				  (
OR
 (
CADR
 (
CDDDR
 FONTX))
				      DEV)
				  NOERRORFLG))
		    ([
SETQ
 FONTX (
COND

			  ((type?
 FONTDESCRIPTOR FAMILY)
			    FAMILY)
			  ((
NULL
 FAMILY)
			    (
DEFAULTFONT
 DEV))
			  ((type?
 FONTCLASS FAMILY)

          (* We know that this won't attempt a cyclic fontcreate in \COERCEFONTDESC, because we are passing a known class.

	  Unless NOERROFLG, an error will be caused on the actual device font if it can't be found.)



			    (
\COERCEFONTDESC
 FAMILY DEV NOERRORFLG))
			  ((
OR
 (
IMAGESTREAMP
 FAMILY)
			       (type?
 WINDOW FAMILY))
			    (
DSPFONT
 NIL FAMILY]             (* FAMILY was a spec for a font descriptor, use it and 

							     extend it by the other args.)

		      (
COND

			((
OR
 SIZE FACE ROTATION DEVICE)
			  (FONTCREATE
 (
FONTPROP
 FONTX (
QUOTE
 FAMILY))
				      (
OR
 SIZE (
FONTPROP
 FONTX (
QUOTE
 SIZE)))
				      (
OR
 FACE (
FONTPROP
 FONTX (
QUOTE
 FACE)))
				      (
OR
 ROTATION (
FONTPROP
 FONTX (
QUOTE
 ROTATION)))
				      (
OR
 DEVICE (
FONTPROP
 FONTX (
QUOTE
 DEVICE)))
				      NOERRORFLG))
			(T FONTX)))
		    (T (
PROG
 (FONTFACE TEMPDEV)
			 RETRY
			     [
OR
 (
LITATOM
 FAMILY)
				 (
COND

				   (NOERRORFLG (
RETURN
))
				   (T (
LISPERROR
 "ARG NOT LITATOM" FAMILY T]
			     [
OR
 (
AND
 (
FIXP
 SIZE)
				      (
IGREATERP
 SIZE 0))
				 (
COND

				   (NOERRORFLG (
RETURN
 NIL))
				   (T (
\ILLEGAL.ARG
 SIZE]
			     (
SETQ
 FONTFACE (
OR
 (
\FONTFACE
 FACE NOERRORFLG)
						(
RETURN
 NIL)))
			     (
OR
 (
U-CASEP
 FAMILY)
				 (
SETQ
 FAMILY (
U-CASE
 FAMILY)))
			     (
COND

			       ((
NULL
 ROTATION)
				 (
SETQ
 ROTATION 0))
			       ((
AND
 (
FIXP
 ROTATION)
				     (
IGEQ
 ROTATION 0)))
			       (NOERRORFLG (
RETURN
 NIL))
			       (T (
\ILLEGAL.ARG
 ROTATION)))
			 NEWDEV
			     [
RETURN
 (
COND

				       ((
\LOOKUPFONT
 FAMILY SIZE FONTFACE ROTATION DEV))
				       [[
SETQ
 FONTX (
ASSOC
 (
QUOTE
 FONTCREATE)
							   (
CDR
 (
ASSOC
 DEV IMAGESTREAMTYPES]
                                                             (* We found the device, but maybe didn't find the font.

							     We know not to try to coerce the device into a stream, 

							     though.)

					 (
COND

					   ((
SETQ
 FONTX (
APPLY*
 (
OR
 (
CADR
 FONTX)
								    (
FUNCTION
 NILL))
								FAMILY SIZE FONTFACE ROTATION DEV))
					     (
SETFONTDESCRIPTOR
 FAMILY SIZE FONTFACE ROTATION DEV 
								FONTX))
					   (T (
GO
 NOTFOUND]
				       ((
AND
 (
NULL
 TEMPDEV)
					     (
SETQ
 TEMPDEV (
\GETSTREAM
 DEVICE (
QUOTE
 OUTPUT)
								       T)))

          (* Here only if we haven't recognized the device. This could be slow for litatoms, but unless NOERROR, we are 

	  heading for an error anyway. But for things like windows, it will be reasonably fast. We don't do this above cause 

	  the recognized litatom case is common.)


                                                             (* Don't change DEV to NIL, so it is meaningful in 

							     error message)

					 (
SETQ
 DEV (fetch
 IMFONTCREATE of
 (fetch
 IMAGEOPS
									     of
 TEMPDEV)))
					 (
GO
 NEWDEV))
				       (T (
GO
 NOTFOUND]
			 NOTFOUND
			     (
COND

			       (NOERRORFLG (
RETURN
 NIL))
			       (T (
ERROR
 "FONT NOT FOUND" (
LIST
 FAMILY SIZE FONTFACE ROTATION DEV))
				  (
GO
 RETRY])
)
(PUTPROPS FONTUNPARSEPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (383 5968 (FONTUNPARSE 393 . 1569) (FONTCREATE 1571 . 5966)))))
STOP