(FILECREATED " 6-Nov-84 15:48:38" {ERIS}<LISPNEW>SOURCES>NSFONTCOERCEPATCH.;2
 3521   

      changes to:  (FNS \COERCEASCIITONSFONT)

      previous date: " 5-Nov-84 17:27:41" {ERIS}<LISPNEW>SOURCES>NSFONTCOERCEPATCH.;1)


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

(PRETTYCOMPRINT NSFONTCOERCEPATCHCOMS)

(RPAQQ NSFONTCOERCEPATCHCOMS
 ((FNS \COERCEASCIITONSFONT)))
(DEFINEQ

(\COERCEASCIITONSFONT

  [LAMBDA (ASCIITONSMAPARRAY ASCIITONSFIXARRAY ASCIIFAMILY NSFAMILY SIZE FONTFACE ROTATION DEVICE)
                                                             (* jds " 6-Nov-84 15:47")

                                                             (* Produces an ascii font with the proper widths for 

							     the ns-character correspondences defined by 

							     ASCIITONSMAPARRAY)

                                                             (* ASCIITONSFIXARRAY is for temporary problems with 

							     font compatibility between printer and widths/screen.

							     in OS5.0 fonts)

    (
PROG
 (CHARSETDIR [ASCIITONSMAP (fetch
 (
ARRAYP
 BASE) of
 (
\DTEST
 (
OR
 ASCIITONSFIXARRAY 
									ASCIITONSMAPARRAY)
								    (
QUOTE
 ARRAYP]
		      (FD (
\CREATESTARFONT
 NSFAMILY SIZE FONTFACE ROTATION DEVICE)))
          (
OR
 FD (
RETURN
 NIL))
          (
SETQ
 CHARSETDIR (
CONS
 (
CONS
 0 FD)))
          [for
 I NSCODE CS from
 0 to
 255 unless
 (
OR
 (
EQ
 I (
SETQ
 NSCODE (
\GETBASE
 ASCIITONSMAP I)))
						    (
ASSOC
 (
SETQ
 CS (NSCHARSET NSCODE))
							   CHARSETDIR))
	     do
                                              (* Run thru the translate table looking for non-0 

							     charsets. Add their width info to the directory)

		(push
 CHARSETDIR (
CONS
 CS
				       (
COND

					 ((
\CREATESTARFONT
 NSFAMILY SIZE FONTFACE ROTATION DEVICE CS))
					 (T                  (* There isn't any info for that character.

							     Warn the guy, but continue.)

					    (
FRESHLINE
 PROMPTWINDOW)
					    (printout
 PROMPTWINDOW 
						     "Warning:  Information about character set "
						      .I3.8 CS " missing from font " ASCIIFAMILY , 
						      SIZE ".")
					    NIL]             (* Return if one of the fonts couldn't be found)

          (bind
 CHARSETINFO for
 I NSCODE (WD _(fetch
 \SFWidths of
 FD)) from
 0 to
 255
	     unless
 (
EQ
 I (
SETQ
 NSCODE (
\GETBASE
 ASCIITONSMAP I)))
	     when
 (
SETQ
 CHARSETINFO (
CDR
 (
ASSOC
 (NSCHARSET NSCODE)
						CHARSETDIR)))
	     do
                                              (* For each non-ASCII character, look for width info in

							     the right NS place. If none, use zero width.)

		(
SETA
 WD I (
CHARWIDTH
 (NSCHAR NSCODE)
				      CHARSETINFO)))
          [replace
 OTHERDEVICEFONTPROPS of
 FD with
 (fetch
 (
ARRAYP
 BASE) of
 (
\DTEST
 ASCIITONSMAPARRAY
										   (
QUOTE
 ARRAYP]
          [
COND

	    ((
NEQ
 NSFAMILY ASCIIFAMILY)

          (* Update the font deacriptor so it looks like it's really for the family the guy wanted. Also save the info we used

	  to get here.)



	      (replace
 FONTFAMILY of
 FD with
 ASCIIFAMILY)
	      (replace
 FONTDEVICESPEC of
 FD with
 (
LIST
 NSFAMILY SIZE FONTFACE ROTATION DEVICE]
          (
RETURN
 FD])
)
(PUTPROPS NSFONTCOERCEPATCH COPYRIGHT ("Xerox Corporation" 1984))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (399 3433 (\COERCEASCIITONSFONT 409 . 3431)))))
STOP