LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760031515. :SYSTEM-TYPE :LOGICAL :VERSION 6. :TYPE "LISP" :NAME "RESOURCE" :DIRECTORY ("REL3-SOURCE" "KERNEL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-SOURCE\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :VERSION-LIMIT 0. :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2758644165. :AUTHOR "REL3" :LENGTH-IN-BYTES 25801. :LENGTH-IN-BLOCKS 26. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                             ;;;-*- cold-load:t; Mode:Common-Lisp; Package:SYSTEM-INTERNALS; Base:10 -*-;;;                           RESTRICTED RIGHTS LEGEND;;;Use, duplication, or disclosure by the Government is subject to;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in;;;Technical Data and Computer Software clause at 52.227-7013.;;;                     TEXAS INSTRUMENTS INCORPORATED.;;;                              P.O. BOX 2909;;;                           AUSTIN, TEXAS 78769;;;                                 MS 2151;;; Copyright (C) 1985,1987 Texas Instruments Incorporated. All rights reserved.;;; ** (c) Copyright 1982 Massachusetts Institute of Technology **;;; Change history:;;;  Date      AuthorDescription;;; -------------------------------------------------------------------------------------;;;  4/21/87   ab       Change REINITIALIZE-RESOURCE not to relase resource objects;;;                     created in static areas.;;; 04/07/87   LGOFix bug 4622 - lambda list evaluated in :deallocator form;;; 04/01/87   LGOAdd the :CLEANUP option to DEFRESOURCE and CLEAN-OUT-RESOURCES;;;  3/23/87   DNGRemove MAKE-OBSOLETE declarations.;;; 12/06/86   LGOAdd the :DEALLOCATOR option and the reinitialize-resource and;;;clean-out-resources functions.;;; 08/12/85   LGONEWER and FASTER version of resource package. Uses one dimensional;;;arrays instead of two, and collapses all of allocate-resource;;; into two functions.;;; New version of resource package, subsumes system-window facility;;; Note that WITH-RESOURCE is obsolete because it takes its "arguments";;; in the wrong order.  It has been replaced by USING-RESOURCE.;;; Old form of DEFRESOURCE:;;;(DEFRESOURCE [name | (name dont-make-initial-copy)] . creator-body);;; New form of DEFRESOURCE:;;;(DEFRESOURCE name parameters keyword value keyword value ...);;;  Keywords are:;;;:CONSTRUCTOR form   (this is required);;;Sees parameters as arguments.;;;:FINDER form;;;Sees parameters as arguments.;;;:MATCHER form;;;Sees OBJECT (in current package) and parameters as arguments.;;;:CHECKER form;;;Sees OBJECT and IN-USE-P (in current package) and parameters as arguments.;;;:INITIALIZER form;;;Sees OBJECT and parameters as arguments.;;;:DEALLOCATOR form;;;Sees OBJECT (in current package) and parameters as arguments.;;;  In the above six options, form may also be a symbol which is a function to call.;;;  It gets the resource data structure as its first argument then the specified args.;;;:INITIAL-COPIES number  (default 0);;;If this is specified, all parameters must be &optional and;;;have suitable defaults.  This is generally a good idea anyway.;;;Specifying NIL here is the same as zero.;;;     :FREE-LIST-SIZE number  (default 20.);;;If this is specified, the size of the free-list for this resource;;;will initially be that number.;;;  If :FINDER is specified, we keep no list of free objects and use :FINDER;;;  to find a free one by looking through the general environment.;;;  Otherwise we keep a table of objects and whether they are free.;;;  If :MATCHER is specified, we use it to check them against the parameters.;;;  Otherwise the a-list also includes the parameter values, which are checked;;;  with EQUAL (not EQ).;;;  If :CHECKER is specified, then it gets to pass on each object to decide whether;;;  or not to reuse it, whether or not it is already marked as in-use.;;;;;;  The finder, matcher, and checker are called without-interrupts.;;;;;;  Possible features that might be added: ability to keep a free list threaded;;;  through the objects.  Code to be run when something is deallocated, e.g.;;;  to deactivate a window.;;;;;;  Note: for windows, you typically want to use DEFWINDOW-RESOURCE,;;;  which supplies the right options to DEFRESOURCE.;;;;;; DEFRESOURCE no longer uses the value and function cells of the resource's name.;;; It puts on a DEFRESOURCE property of the following defstruct.  Note: only the;;; functions right here are "allowed" to know what is in this structure.(defstruct (resource (:type :named-array-leader)      (:callable-constructors nil))  name;Symbol which names it  (n-entries 0);Number of objects on the free list times 3  allocator;Allocation function  deallocator;DeAllocation function  initial-copies;Number if initial copies  );;; The free list is the (n x 3) array itself, with the following fields:(defsubst resource-in-use-p   (resource i) (aref resource (* i 3)))(defsubst resource-object     (resource i) (aref resource (1+ (* i 3))))(defsubst resource-parameters (resource i) (aref resource (+ 2 (* i 3))))(defsubst resource-n-objects  (resource) (truncate (resource-n-entries resource) 3));; The following 4 lines commented out because these are still the documented interface. --  D.N.G. 3/23/87;(compiler:make-obsolete resource-in-use-p resource-inuse-p);(compiler:make-obsolete resource-object resource-entry);(compiler:make-obsolete resource-parameters resource-parms);(compiler:make-obsolete resource-n-objects resource-n-entries)(defsubst resource-inuse-p (resource i)  "Accessor for the inuse flag of resource item number (truncate I 3)"  (aref resource i))(defsubst resource-entry (resource i)  "Accessor for the entry of resource item number (truncate I 3)"  (aref resource (1+ i)))(defsubst resource-parms (resource i)  "Accessor for the parameters of resource item number (truncate I 3)"  (aref resource (+ i 2)));;PAD 2/13/87 Added resource-entry-size.(defconstant resource-entry-size 3.)(defsubst get-resource-structure (resource-name) (get resource-name 'defresource));;; Note that the free list is a list of consecutive objects with NILs;;; filling out the rest of the array.  If one is doing an allocate then;;; one searches through N-OBJECTS objects in the free list until an;;; available one is found.  If one isn't found then one is created and;;; is placed after the last object and N-OBJECTS is incremented by one.;;; Deallocate is quite simple: one sets the IN-USE-P flag to nil for;;; that object in the free list.  Clear-Resource specifying a;;; particular instance will remove that instance from the free list,;;; filling in the gap if necessary.  At all times, the first N-OBJECTS;;; objects in the free list are objects that are either in use or not;;; in use.(defun (:property resource named-structure-invoke) (op &optional self &rest args)  (cond ((eq op :which-operations) '(:describe :print-self))((eq op :describe) (describe-defstruct self) (let* ((resource self) (n-entries (resource-n-entries resource)))   (cond ((zerop n-entries)  (format t "~&There are currently no objects.~%")) (t (format t "~%There ~[~;is~:;are~] currently ~:*~D object~:P:"    (truncate n-entries resource-entry-size))    (format t "~% N   In Use  Object~35@TParameters")    (loop for i from 0 below n-entries by resource-entry-size  for n upfrom 0 do  (format t "~%~4d  ~:[No ~;Yes~]    ~40S ~S"  n  (resource-inuse-p resource i)  (resource-entry resource i)  (resource-parms resource i)))    (format t "~%")))))((eq op :print-self)   (let ((stream (car args)))     (si:printing-random-object         (self stream)         (princ "Resource " stream) (princ (resource-name self) stream)) t))));;;(DEFSELECT ((:PROPERTY RESOURCE NAMED-STRUCTURE-INVOKE));;;  (:DESCRIBE (RESOURCE &AUX (N-ENTRIES (RESOURCE-N-ENTRIES RESOURCE)));;;    (DESCRIBE-DEFSTRUCT RESOURCE);;;    (COND ((ZEROP N-ENTRIES);;;   (FORMAT T "~&There are currently no objects.~%"));;;  (T (FORMAT T "~&There ~[~;is~:;are~] currently ~:*~D object~:P:~@;;;Object~40TParameters~60TIn Use";;;     (/ N-ENTRIES resource-entry-size));;;     (LOOP FOR I FROM 0 BELOW N-ENTRIES by resource-entry-size DOING;;;   (FORMAT T "~%~S~40T~S~60T~:[No~;Yes~]";;;   (RESOURCE-ENTRY RESOURCE I);;;   (RESOURCE-PARMS RESOURCE I);;;   (RESOURCE-INUSE-P RESOURCE I)));;;     (FORMAT T "~%")))));(defmacro defresource (name parameters &rest options)  "Define a resource named NAME, with parameters PARAMETERS for constructing objects.OPTIONS can specify how to create objects and how to tell when old objectscan be reused."  ;; Old format?  (if (or (consp name) (null options) (listp (car options)))      ;; In system 88, crack down on these; make sure they finally get fixed.      (ferror nil "Obsolete form of DEFRESOURCE for ~S~%" name)    (let ((constructor-form nil) (finder-form nil) (matcher-form nil) (checker-form nil)  (initializer-form nil) (free-list-size 20.) (params nil) (cleanup-function t)  (initial-copies 0)  (deallocator-form nil)  (documentation nil)  (obj (intern "OBJECT"))  (in-use-p (intern "IN-USE-P")))      (or (listp parameters) (null parameters)  (ferror nil "~S invalid parameter list" parameters))      (setq params (loop for p in parameters unless (member p lambda-list-keywords :test #'eq) collect (if (symbolp p) p (car p))))      ;; if first option is a string, use it as documentation instead      (when (stringp (car options))(setq documentation (pop options)))      (loop for (keyword value) on options by #'cddr    do (case keyword (:constructor (setq constructor-form value)) (:finder (setq finder-form value)) (:matcher (setq matcher-form value)) (:checker (setq checker-form value)) (:initializer (setq initializer-form value)) (:deallocator (setq deallocator-form value)) (:cleanup (SETQ cleanup-function value)) (:initial-copies  (setq initial-copies(cond ((null value) 0)      ((numberp value) value)      (t (ferror nil ":INITIAL-COPIES ~S - number required" value))))) (:free-list-size  (setq free-list-size(cond ((null value) 20.)      ((numberp value) value)      (t (ferror nil ":FREE-LIST-SIZE ~S - number required"))))) (otherwise (ferror nil "~S illegal option in DEFRESOURCE" keyword))))      (when finder-form (setq free-list-size 0))      (or constructor-form (ferror nil "DEFRESOURCE requires the :CONSTRUCTOR option"))      (if (atom deallocator-form)  (when deallocator-form    (setq deallocator-form `',deallocator-form)) (setq deallocator-form `(function (lambda (ignore ,obj ,@parameters)     ,obj ,@params ,deallocator-form))))      ;; Generate the ALLOCATE function      `(progn   ,(if finder-form(if (symbolp finder-form)    `(defun (:property ,name resource-allocator) (resource parameters &rest ignore)       (without-interrupts  (apply ',finder-form resource parameters)))    `(defun (:property ,name resource-allocator) (resource ignore ,@parameters)       resource ;; just in case it isn't used       (without-interrupts  ,finder-form)))`(defun (:property ,name resource-allocator) (resource parameters ,@parameters &aux ,obj new-p)   parameters ;; Not used when there's a matcher-form   (without-interrupts     (do* ((n-entries (resource-n-entries resource))   (n (- n-entries resource-entry-size) (- n resource-entry-size))   ,@(when checker-form `(,in-use-p)))  ((minusp n) (setq new-p t))       ,@(if checker-form     `((setq ,obj (resource-entry resource n)     ,in-use-p (resource-inuse-p resource n))       (unless ,(if (symbolp checker-form)    `(,checker-form resource ,obj ,in-use-p ,@params)    checker-form) (go end-loop)))     `((when (resource-inuse-p resource n) (go end-loop))       (setq ,obj (resource-entry resource n))))       (when ,(if matcher-form  (if (and (symbolp matcher-form) (not (eq 't matcher-form)))      `(,matcher-form resource ,obj ,@params)      matcher-form)  (if params      `(equal parameters (resource-parms resource n)) t)) (setf (resource-inuse-p resource n) t) (return)) end-loop))   (when new-p     (setq ,obj ,(if (symbolp constructor-form)     `(,constructor-form resource ,@params)     constructor-form)))   ,@(when initializer-form       (if (symbolp initializer-form)   `((,initializer-form resource ,obj ,@params))   (cons initializer-form nil)))   (when new-p     (add-new-resource resource ,obj parameters))   ,obj))  (initialize-resource ',name ',initial-copies ',free-list-size ,deallocator-form ,cleanup-function) ;; update documentation ,(when documentation   `(setf (documentation ',name 'defresource) ,documentation))))))(defprop defresource "Resource" definition-type-name)(defvar *all-resources* nil "List of all symbols that are names of DEFRESOURCEs.")(defun initialize-resource (name initial-copies free-list-size &optional deallocator (cleanup-function t))  (when (record-source-file-name name 'defresource)    ;; Set the cleanup-function property.    (IF (EQ cleanup-function t) ;;  When T, use the default(REMPROP name 'resource-cleanup-function) ;; Do this first, so the property is last      (PUTPROP name (OR cleanup-function 'IGNORE) 'resource-cleanup-function))    (let ((old-resource (get-resource-structure name)) resource)      ;; Be careful that there's enough room for all objects in the old resource      ;; when replacing it.      (setq free-list-size (* free-list-size resource-entry-size)) ;; three array elements for each free list entry      (when (and old-resource (plusp free-list-size))(setq free-list-size (max (resource-n-entries old-resource)  free-list-size)))      (setq resource (make-resource :name name    :make-array (:dimensions  free-list-size     :area permanent-storage-area)    :allocator (get name 'resource-allocator)    :deallocator deallocator    :initial-copies initial-copies))      ;; Save any old objects when reloading a DEFRESOURCE      (when (and old-resource (plusp free-list-size))(copy-array-contents old-resource resource)(setf (resource-n-entries resource)      (resource-n-entries old-resource)))      (putprop name resource 'defresource)      (loop for object in (loop repeat initial-copies collect (allocate-resource name))    do (deallocate-resource name object))      ;; Ensure the allocator property is first      (LET ((allocator (GET name 'resource-allocator)))(REMPROP name 'resource-allocator)(PUTPROP name allocator 'resource-allocator))))  (unless (member name *all-resources* :test #'eq)    (push name *all-resources*))  name);Don't record this in qfasl files because it always does a RECORD-SOURCE-FILE-NAME.(defprop initialize-resource t qfasl-dont-record);;PAD 2/13/87 Corrected found-instance loop to decrement by resource-entry-size rather than 1(defun clear-resource (resource-name &optional (this-instance nil)                       (print-warning t)       &aux resource            n-entries    (found-instance nil))  "Throw away objects allocated from the specified resource.RESOURCE-NAME is the name of the resource to clear.THIS-INSTANCE is optional and is either NIL or an instance of theresource.  If this argument is NIL then all instances of thisresource are cleared.  If this argument is an instance then onlythat instance is cleared from the resource.PRINT-WARNING is optional and is either T or NIL.  If this argument is Tthen if the instance being cleared is still in use then awarning message is printed.  If this argument is NIL then nowarning message is printed.This is function useful if you discover instances of a resource were allconstructed wrong, and you fix the constructor.  Call this function tomake sure newly constructed objects will be used."  (check-arg resource-name (setq resource (get-resource-structure resource-name))     "the name of a resource")  (without-interrupts    (loop for i from 0 below (setq n-entries (resource-n-entries resource)) by resource-entry-size  when (and (or (null this-instance) (eq this-instance (resource-entry resource i)))    (resource-inuse-p resource i)                    print-warning)    do (format *error-output* "~%[Warning: ~S still in use]"       (resource-entry resource i))  do (progn       (when found-instance ;; We already found a single instance to clear out. Move ;; this instance which follows that instance back one to ;; fill in the gap.  Note that in the resource array ;; there are no gaps. (setf (resource-entry     resource (- i resource-entry-size)) (resource-entry     resource i))   (setf (resource-inuse-p   resource (- i resource-entry-size)) (resource-inuse-p   resource i)) (setf (resource-parms resource (- i resource-entry-size)) (resource-parms resource i)) ;; Clear the actual cells so the old objects can be ;; garbage collected immediately. (setf (resource-entry     resource i) nil) (setf (resource-inuse-p   resource i) nil) (setf (resource-parms resource i) nil) )       (when (or (null this-instance) (eq this-instance (resource-entry resource i))) (if this-instance     ;; Indicate that we found the instance which is to be removed.     (setq found-instance t)) (decf n-entries resource-entry-size) ;; Clear the actual cells so the old objects can be ;; garbage collected immediately. (setf (resource-entry     resource i) nil) (setf (resource-inuse-p   resource i) nil) (setf (resource-parms resource i) nil)))  finally (setf (resource-n-entries resource) n-entries))))(defun map-resource (function resource-name &rest extra-args &aux resource)  "Call FUNCTION on each object created in resource RESOURCE-NAME.FUNCTION gets three args at each call: the object, whether the resourcebelieves it is in use, and RESOURCE-NAME."  (check-arg resource-name (setq resource (get-resource-structure resource-name))     "the name of a resource")  ;;Windows are the user's problem....  (loop for i from 0 below (resource-n-entries resource) by resource-entry-sizefor object = (resource-entry resource i)when object  do (apply function object (resource-inuse-p resource i) resource-name    extra-args)))  (defun allocate-resource (resource-name &rest parameters &aux resource)  "Allocate an object from resource RESOURCE-NAME according to PARAMETERS.An old object is reused if possible; otherwise a new one is created.The significance of the PARAMETERS is determined by the individual resource.If a new object is created, it is created in BACKGROUND-CONS-AREA unlessthe constructor function specifies a different area."  (check-arg resource-name (setq resource (get-resource-structure resource-name))     "the name of a resource")  (let ((default-cons-area background-cons-area))    (apply (resource-allocator resource) resource parameters parameters)));; Internal function used by resource-allocator functions to add a new object to a resource;;PHD 4/15/87 added no-memory feature.(defun add-new-resource (resource resource-entry parameters &aux index)  (without-interrupts    (unless (get (resource-name resource) 'no-memory)      (setf (resource-n-entries resource)    (+ resource-entry-size (setq index (resource-n-entries resource))))      (when (>= (+ resource-entry-size index) (array-length resource))(putprop (resource-name resource) (setq resource (adjust-array resource (+ index (max 20. (truncate index 2))))) 'defresource))      (setf (resource-entry resource index) resource-entry)      (setf (resource-inuse-p resource index) t)      (setf (resource-parms resource index) (copy-list parameters))))  resource-entry);;PHD 4/15/87 added no-memory feature.(defun deallocate-resource (resource-name object &aux resource n-entries)  "Return OBJECT to the free pool of resource RESOURCE-NAME.OBJECT should have been returned by a previous call to ALLOCATE-RESOURCE."  (check-arg resource-name (setq resource (get-resource-structure resource-name))     "the name of a resource")  (unless (get resource-name 'no-memory)    (setq n-entries (resource-n-entries resource))    (loop for n from (- n-entries resource-entry-size) downto 0 by resource-entry-size  when (eq (resource-entry resource n) object)  ;; Note that this doesn't need any locking.  do (let ((deallocator (resource-deallocator resource)))       (when deallocator (apply deallocator resource object (resource-parms resource n)))       (return (setf (resource-inuse-p resource n) nil)))  finally (signal (make-condition 'deallocate-non-resource-entry  "~S is not an object from the ~S resource"  object resource-name)  :proceed-types '(:no-action))  )))(defun deallocate-whole-resource (resource-name &aux resource)  "Return all objects allocated from resource RESOURCE-NAME to the free pool."  (check-arg resource-name (setq resource (get-resource-structure resource-name))     "the name of a resource")  (loop with n-entries = (resource-n-entries resource)for n from 0 below n-entries by resource-entry-sizewhen (resource-inuse-p resource n)do (let ((deallocator (resource-deallocator resource)))     (when deallocator (apply deallocator resource (resource-entry resource n) (resource-parms resource n)))     (setf (resource-inuse-p resource n) nil))));; All other resource functions have the resource-name as the first parameter...(defun resource-object-in-use (resource-object resource-name &aux resource)  "Return T if RESOURCE-OBJECT was created in resource RESOURCE-NAME and is in use."  (check-arg resource-name (setq resource (get-resource-structure resource-name))     "the name of a resource")  (loop for i from 0 below (resource-n-entries resource) by resource-entry-sizewhen (eq (resource-entry resource i) resource-object)do (return (resource-inuse-p resource i))))(defmacro using-resource ((var resource-name . parameters) &environment environment &body body)  "Execute BODY with VAR bound to an object allocated from resource RESOURCE-NAME.PARAMETERS are used in selecting or creating the object,according to the definition of the resource."  (multiple-value-bind (body declarations)      (parse-body body environment nil)    `(let ((,var nil))       ,@declarations       (unwind-protect   (progn     (setq ,var (allocate-resource ',resource-name . ,parameters))     . ,body) (and ,var (deallocate-resource ',resource-name ,var))))));For compatibility with old programs(deff with-resource 'using-resource)(defun reinitialize-resource (resource-name &optional kill-function &aux resource)  "Clean out all unused resource objects from RESOURCE-NAME, and replace them with the number specified by the:INITIAL-COPIES option to DEFRESOURCE. KILL-FUNCTION, if supplied,is called with one argument, the resource object,to cleanup unusedresource objects to ensure they can be garbage collected"  (check-arg resource-name (setq resource (get-resource-structure resource-name))     "the name of a resource")  (let (initial-copies(unused-count 0))    (UNLESS (OR (ZEROP (resource-n-entries resource))(area-static-p (%area-number (resource-entry resource 0))))      ;; Clear un-used objects from the resource      (loop for i from 0 below (resource-n-entries resource) by resource-entry-size    with unused-instances do    (unless (resource-inuse-p resource i)      (incf unused-count)      (push (resource-entry resource i) unused-instances))    finally    (dolist (instance unused-instances)      (clear-resource resource-name instance)      (WHEN kill-function(FUNCALL kill-function instance)))))    ;; Replace the initial copies, ensuring that we don't create more than what we started with.    ;; The reason we don't just keep some of the unused objects in the resource, is that new copies    ;; are less likely to contain pointers to other structures which could be garbage collected.    (when (plusp (setq initial-copies (min unused-count (resource-initial-copies resource))))      (loop for object in (loop repeat initial-copies collect (allocate-resource resource-name))    do (deallocate-resource resource-name object)))))(defun clean-out-resources ()  "Called before FULL-GC to purge resources of extra entries."  (dolist (resource-name *all-resources*)    (when (get-resource-structure resource-name)      (reinitialize-resource resource-name))));;PHD 4/15/87 added no-memory feature.(defparameter  *resources-without-memory*       '(ip:tftp-connections  ip:tcbs  ip:ip-routing-list  tv:confirmation-window  tv:inspect-frame-resource  w:menu  w:fake-minibuffer-window  w:traveling-search-window  telnet:telnet-server-window  zwei:mail-filter-menu  sugg:pop-up-keystrokes-window  zwei:converse-simple-reply-window  ucl:get-keystroke-window  tv:trace-pop-up-menu  sugg:suggestions-pop-up-notification-window  zwei:mail-multiple-menu  sys:ucl-break  eh:ucl-debugger  ucl:temporary-command  eh:debugger-frame  sugg:suggestions-pop-up-standalone-editor-frame  tv:system-menu  tv:flavor-inspector-resource  tv:system-menu  tv::background-lisp-interactors)  "Resources in this list will be managed without memory i.e., a request for one will always make a new one.")    ;;PHD 4/15/87 added no-memory feature.(defun clear-resources-without-memory ()  "This function will clear resources without memory."  (mapcar #'(lambda (name)      (if (member name *resources-without-memory* :test #'eq)  (progn    (setf (get name 'no-memory) t)    (clear-resource name))  (remprop name 'no-memory)))  *all-resources*))(add-initialization "disable resources without-memory"    '(clear-resources-without-memory)    :before-cold)(add-initialization "Clean Out Resources"      '(clean-out-resources)      :full-gc)rget string :start1 0 :start2 1+prev-hyphen-pos                                             :end1 (array-active-length target) :end2 end)                               (return (cdr elem))))))    ;; Note: combine with LOGIOR rather than DPB, since mouse                    ;; characters have the high %%KBD-MOUSE bit on.                    (return (greekify-character tem greek-flag top-flag shift-flag char)))                   (t (return ())))))))) ;Given a character, return the greek or top equivalent of it according to;the specified flags.  If the flags are all NIL, the original character is returned.(defun greekify-character (start-char greek-flag top-flag shift-flag &optional (metabits 0))  (cond    ((and top-flag greek-flag) NIL)    (greek-flag     (let* ((greek-char             (dotimes (i 2