;;; -*- Mode: Common-Lisp; Package: UCL; Base: 10.; Patch-File: T -*- ;;; Reason: Modified build-menu to handle :column-list-order entry that is a string. [3435] ;;; RESTRICTED RIGHTS LEGEND ;;; ;;; Use, duplication, or disclosure by the Government is subject to ;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in ;;; Technical Data and Computer Software clause at 52.227-7013. ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 149149, M/S 2151 ;;; AUSTIN, TEXAS 78714-9149 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 06/20/90 12:50:55 by BERGER, ;;; while running on ARIES from band LODX ;;; With SYSTEM 6.41, VIRTUAL-MEMORY 6.3, EH 6.8, MAKE-SYSTEM 6.5, MICRONET 6.0, LOCAL-FILE 6.2, ;;; BASIC-PATHNAME 6.5, NETWORK-SUPPORT-COLD 6.2, BASIC-NAMESPACE 6.8, NETWORK-NAMESPACE 6.1, ;;; DISK-IO 6.4, DISK-LABEL 6.1, BASIC-FILE 6.13, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.2, ;;; COMPILER 6.18, TV 6.30, DATALINK 6.0, CHAOSNET 6.8, GC 6.4, MEMORY-AUX 6.0, NVRAM 6.4, ;;; SYSLOG 6.2, STREAMER-TAPE 6.6, UCL 6.0, INPUT-EDITOR 6.0, METER 6.2, ZWEI 6.22, ;;; DEBUG-TOOLS 6.5, NETWORK-SUPPORT 6.1, NETWORK-SERVICE 6.3, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.8, MAC-PRINTER-TYPES 6.2, PRINTER-TYPES 6.2, ;;; IMAGEN 6.1, SUGGESTIONS 6.1, MAIL-DAEMON 6.6, MAIL-READER 6.8, TELNET 6.1, VT100 6.0, ;;; NAMESPACE-EDITOR 6.6, PROFILE 6.3, VISIDOC 6.7, TI-CLOS 6.53, CLEH 6.5, IP 3.65, ;;; Experimental BUG 11.19, Experimental CLX 7.0, Experimental CLUE 7.1, X11M 6.30, ;;; Experimental DOCUMENTER 6.0, VISIDOC-SERVER 6.2, microcode 483, Band Name: Rel 6.1 *b +SLE 6/18 #!C ; From file DEFCOM.LISP#> UCL; SYS: #10R UCL#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "UCL")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* SYS:COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: UCL; DEFCOM.#" (Defun BUILD-MENU (menu-name flavor &OPTIONAL &KEY sort-items item-list-order default-item-options extra-items sort-columns column-list-order column-options (item-form 'GENERAL-PARSE-MENU-ITEM) temporary? superior-menus documentation (name (MAKE-COMMAND-NAME menu-name))) ;; If :ITEM-LIST-ORDER is non-NIL, collect an ordered list of menu items. If an explicit-order ;; (explicit source) of commands isn't supplied, we use the list of commands which accumulated in ;; every DEFCOMMAND mentioning MENU-NAME in the :MENUS option. (WHEN column-options ;; Flag this obsolete, but add the options into COLUMN-LIST-ORDER. COLUMN-OPTIONS should ;; be done away with at some point, but is presently being used here and there. (PRINC (STRING-APPEND " Keyword :COLUMN-OPTIONS, used in (Build-Menu '" menu-name " ...) is obsolete. Replace it with :COLUMN-LIST-ORDER. ") *ERROR-OUTPUT*) (SETQ column-list-order (IF column-list-order (LOOP FOR entry IN column-list-order COLLECT (IF (CONSP entry) `(,(CAR entry) ,@(CDR (FIND (CAR entry) column-options :Test #'(LAMBDA (item sequence-item) (IF (CONSP sequence-item) (EQUAL item (CAR sequence-item)))))) . ,(CDR entry)) `(,entry ,@(CDR (FIND entry column-options :Test #'(LAMBDA (item sequence-item) (IF (CONSP sequence-item) (EQUAL item (CAR sequence-item))))))))) column-options))) (WHEN column-list-order (setf column-list-order ; DAB 06-20-90 Make sure all entries are list. It could be a string. [3435] (LOOP FOR entry IN column-list-order COLLECT (if (consp entry) entry (list entry)))) (SET menu-name (LOOP FOR entry IN column-list-order FOR column-name = (Gen-Column-Symbol menu-name (CAR entry)) DO (SET column-name Nil) COLLECT `(,(CAR entry) ,column-name . ,(CDR entry))))) (LET* ((all-items (NUNION (NUNION item-list-order (GET menu-name 'COMMANDS-WANTING-ON) :Test #'EQ) extra-items :Test #'EQ))) (MULTIPLE-VALUE-BIND (menu-items command-instances) (Collect-Menu-Items menu-name flavor all-items temporary? T default-item-options item-form column-list-order) (SET menu-name (DELETE-DUPLICATES menu-items :FROM-END T :TEST #'(LAMBDA (x y) (AND (consp x) ; DAB 06-20-90 (TYPEP (THIRD x) 'UCL:COMMAND) (EQUAL x y))))) (SETF (GET menu-name 'Items) command-instances))) (REMPROP menu-name 'COMMANDS-WANTING-ON) ;;Store the other options (which may well be NIL) in MENU-NAME's plist. (SETF (GET menu-name 'sort-items) sort-items) (SETF (GET menu-name 'sort-columns) sort-columns) (SETF (GET menu-name 'column-list-order) column-list-order) (SETF (GET menu-name 'item-form) item-form) (SETF (GET menu-name 'default-item-options) default-item-options) ;; For now the menu sorting must go after these SETFs so that the right properties are on ;; menu-name when sort-menu is called. Eventually these values should be passed to sort-menu as ;; arguments to improve performance. (WHEN sort-items (SORT-MENU menu-name)) ;;Store a menu name used in Suggestions, in case this menu is used as a Suggestions submenu. (SETF (GET menu-name 'menu-name) name) (WHEN superior-menus (LET ((item `(,(GET menu-name 'menu-name) :SUGGESTIONS-MENU ,menu-name))) (WHEN documentation (SETQ item (NCONC item `(:DOCUMENTATION ,documentation)))) (DOLIST (superior superior-menus) ;;We might already be on from previous evaluation. (SETF (GET superior 'items) (NUNION (LIST item) (GET superior 'ITEMS) :Test #'EQ)) ;; In case SUPERIOR has already been built (and sug items are being added), add an item. ;; If SUPERIOR has not been, this will get cleared in BUILD-MENU and we'll get on because ;; we're on UCL:ITEMS property. (UNLESS (AND (BOUNDP superior) (CONSP (SYMBOL-VALUE superior))) (SET superior nil)) (SET superior (NCONC (SYMBOL-VALUE superior) (LIST item)))))) ) ))