;;; -*- Mode:Common-Lisp; Package:Compiler; Base:10; Patch-file:T -*- ;;; Reason: Fix for two COMPILE-FILEs running at the same time. [SPR 9776] ;;; 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 2909, M/S 2151 ;;; AUSTIN, TEXAS 78769 ;;; ;;; Copyright (C) 1989 Texas Instruments Incorporated. ;;; All rights reserved. ;;; Written 07/07/89 13:46:12 by GRAY, ;;; while running on Kelvin from band LOD2 ;;; With SYSTEM 6.10, VIRTUAL-MEMORY 6.1, EH 6.3, MAKE-SYSTEM 6.0, MICRONET 6.0, LOCAL-FILE 6.0, ;;; BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1, NETWORK-NAMESPACE 6.0, ;;; DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0, NETWORK-PATHNAME 6.0, ;;; Inconsistent COMPILER 6.7, TV 6.12, DATALINK 6.0, CHAOSNET 6.0, GC 6.3, MEMORY-AUX 6.0, ;;; NVRAM 6.1, SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0, METER 6.1, ;;; ZWEI 6.3, DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1, DATALINK-DISPLAYS 6.0, ;;; FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1, PRINTER-TYPES 6.1, ;;; IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.0, TELNET 6.0, VT100 6.0, ;;; NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, Inconsistent TI-CLOS 6.16, CLEH 6.4, ;;; IP 3.47, Experimental BUG 11.10, Experimental CLX 6.2, CLUE 6.8, X11M 6.1, Experimental DOCUMENTER 619.0, ;;; microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8 ;;; BUG REPORT NUMBER: 9776 ;;; ;;; PROBLEM: Got error ">>Error: -160 LAP-FASD-NIBBLE-COUNT" when two ;;; COMPILE-FILEs running at the same time. The problem is that ;;; LAP-FASD-NIBBLE-COUNT is being SETQd but never bound. ;;; ;;; SOLUTION: Add a binding of LAP-FASD-NIBBLE-COUNT to function QLAPP. #!C ; From file LAP.LISP#> COMPILER; MR-X: #10R COMPILER#: (COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER")) (SI:*LISP-MODE* :COMMON-LISP) (*READTABLE* COMMON-LISP-READTABLE) (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*)) (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; LAP.#" (DEFUN QLAPP (FCTN LAP-MODE) ;; 8/26/85 - Add binding of LOCAL-BLOCK-LENGTH. [SPR 558] ;; 9/30/85 - Include LOCAL-BLOCK-LENGTH with new structure QLP-FEF-HEADER. ;; 12/19/85 - Move setting of ALLVARS, FREEVARS, and SPECVARS to QLP1. ;; 1/05/86 - CLM When lap-mode is disassemble, LAP-OUTPUT-BLOCK will be called. ;; 3/05/86 - CLM Modify for FEF offsets greater than 191. ;; 7/29/86 DNG - When LAP-MODE is COMPILE-TO-CORE and the name is NIL, return the FEF. ;; 8/04/86 DNG - In COMPILE-TO-CORE mode, if the FDEFINE fails, then don't ;; try to define its :INTERNAL functions either. [SPR 1730 and 2632] ;; 9/24/86 DNG - Fix definition of :INTERNAL functions in encapsulations. [SPR 3 and 1167] ;; 1/22/87 DNG - Fix installation of :INTERNAL functions in parent that is a macro. ;; 1/08/88 CLM - Fix to not try to do handle :INTERNAL functions that have ;; been optimized out before QLAPP [SPR 7058]. ;; 3/16/89 DNG - Use new function FASD-INDEX. ;; 7/07/89 DNG - Add LAP-FASD-NIBBLE-COUNT to the list of variables bound. [SPR 9776]. (PROG (SYMTAB ADR NBR SYMPTR SPECVARS SPECVARS-BIND-COUNT LOW-HALF-Q MAX-ARGS MIN-ARGS SM-ARGS-NOT-EVALD REST-ARG DATA-TYPE-CHECKING-FLAG LENGTH-OF-PROG PROG-ORG FCTN-NAME LAP-OUTPUT-AREA TEM LAP-LASTQ-MODIFIER QUOTE-LIST QUOTE-COUNT ALLVARS FREEVARS LAP-OUTPUT-BLOCK LAP-OUTPUT-BLOCK-LENGTH LAP-STORE-POINTER LAP-MACRO-FLAG LAP-FASD-NIBBLE-COUNT BREAKOFF-FUNCTION-OFFSETS DISPATCH-LIST DISPATCH-OFFSET-LIST QUOTE-LIST-LENGTH SHORT-FEF-MAX-QUOTE-LENGTH (QLP-FEF-HEADER (MAKE-FEF-HEADER))) ;;if this is an internal function that has been optimized out, do nothing and ;;return (LET ((FCTN-NAME (COMPILAND-FUNCTION-SPEC *CURRENT-COMPILAND*)) PARENT) (WHEN (AND (EQ (CAR-SAFE FCTN-NAME) ':INTERNAL) (SETQ PARENT (COMPILAND-PARENT *CURRENT-COMPILAND*)) (DEBUG-ASSERT (EQUAL (SECOND FCTN-NAME) (COMPILAND-FUNCTION-SPEC PARENT))) ) (LET* ((DEBUG-INFO (COMPILAND-DEBUG-INFO PARENT)) (INDEX (IF (FIXNUMP (THIRD FCTN-NAME)) (THIRD FCTN-NAME) (POSITION (THIRD FCTN-NAME) (THE LIST (GET-DEBUG-INFO-FIELD DEBUG-INFO :INTERNAL-FEF-NAMES)) :TEST #'EQ)))) ;;the reference to the :internal function has ;;been optimized out (WHEN (NULL (NTH INDEX (GET-DEBUG-INFO-FIELD DEBUG-INFO :INTERNAL-FEF-OFFSETS))) (RETURN) ) ))) (SETQ LAP-OUTPUT-AREA 'MACRO-COMPILED-PROGRAM) (SETQ MIN-ARGS 0) (SETQ MAX-ARGS 0) (SETQ SYMTAB (LIST NIL)) (SETQ QUOTE-COUNT 0) (SETQ QUOTE-LIST-LENGTH 0) (SETQ ADR 0) (QLAP-PASS1 FCTN) (RPLACD SYMTAB (NREVERSE (CDR SYMTAB))) (SETQ QUOTE-LIST (NREVERSE QUOTE-LIST)) ;JUST SO FIRST ONES WILL BE FIRST (SETQ TEM (LAP-SYMTAB-PLACE 'QUOTE-BASE)) (LAP-SYMTAB-RELOC (CADDAR TEM) ;VALUE OF QUOTE-BASE (* 2 (LENGTH QUOTE-LIST)) (CDR TEM)) (SETQ NBR (QLAP-ADJUST-SYMTAB)) ;NUMBER BRANCHES TAKING EXTRA WD (SETQ LENGTH-OF-PROG (+ ADR (+ NBR (* 2 (LENGTH QUOTE-LIST))))) (SETQ SYMPTR SYMTAB) (SETQ QUOTE-COUNT 0) (SETQ ADR 0) (QLAP-PASS2 FCTN) ;Don't call FASD with the temporary area in effect (LET-IF QC-FILE-IN-PROGRESS ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) (WHEN (OR LOW-HALF-Q (AND (OR (EQ LAP-MODE 'QFASL) (EQ LAP-MODE 'QFASL-NO-FDEFINE)) (NOT (= 0 (LOGAND ADR 1))))) (LAP-OUTPUT-WORD 0 #+compiler:debug T)) #+compiler:debug (LET (OLD-FEF-LEN NEW-FEF-LEN) (WHEN (AND (NOT '#.SI:FILE-IN-COLD-LOAD) (SETQ OLD-FEF-LEN (FEF-LEN FCTN-NAME)) (SETQ NEW-FEF-LEN LAP-OUTPUT-BLOCK-LENGTH) (STRING-EQUAL USER-ID "GRAY")) ; no one else is interested ;; check that not generating worse code than previous version (COND ((< OLD-FEF-LEN NEW-FEF-LEN) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) ;Stream may cons (FORMAT T "~%Warning: the new FEF for ~S is ~D words longer than the old one." FCTN-NAME (- NEW-FEF-LEN OLD-FEF-LEN)))) ((AND (> OLD-FEF-LEN NEW-FEF-LEN) COMPILER-VERBOSE) (LET ((DEFAULT-CONS-AREA BACKGROUND-CONS-AREA)) ;Stream may cons (FORMAT T " ~D words shorter" (- OLD-FEF-LEN NEW-FEF-LEN))))))) (COND ((EQ LAP-MODE 'QFASL) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL))) (UNLESS (= 0 LAP-FASD-NIBBLE-COUNT) (BARF LAP-FASD-NIBBLE-COUNT 'LAP-FASD-NIBBLE-COUNT 'BARF)) ;; If this function is supposed to be a macro, ;; dump directions to cons MACRO onto the fef. (WHEN LAP-MACRO-FLAG (FASD-START-GROUP T 1 FASL-OP-LIST) (FASD-NIBBLE 2) (FASD-CONSTANT 'MACRO) (FASD-INDEX TEM) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL)))) (FASD-STOREIN-FUNCTION-CELL FCTN-NAME TEM) (FASD-FUNCTION-END) (RETURN NIL)) ((EQ LAP-MODE 'QFASL-NO-FDEFINE) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL))) (UNLESS (= 0 LAP-FASD-NIBBLE-COUNT) (BARF LAP-FASD-NIBBLE-COUNT 'LAP-FASD-NIBBLE-COUNT 'BARF)) ;; If this function is supposed to be a macro, ;; dump directions to cons MACRO onto the fef. (WHEN LAP-MACRO-FLAG (FASD-START-GROUP T 1 FASL-OP-LIST) (FASD-NIBBLE 2) (FASD-CONSTANT 'MACRO) (FASD-INDEX TEM) (SETQ TEM (FASD-TABLE-ADD (CONS NIL NIL)))) (RETURN TEM)) ((EQ LAP-MODE 'COMPILE-TO-CORE) (LET (( DEF (IF LAP-MACRO-FLAG (CONS-IN-AREA 'MACRO LAP-OUTPUT-BLOCK BACKGROUND-CONS-AREA) LAP-OUTPUT-BLOCK) ) PARENT) (SETF (GETF (COMPILAND-PLIST *CURRENT-COMPILAND*) 'FEF) DEF) (IF (NULL FCTN-NAME) (RETURN DEF) (UNLESS (IF (AND (EQ (CAR-SAFE FCTN-NAME) ':INTERNAL) (SETQ PARENT (COMPILAND-PARENT *CURRENT-COMPILAND*)) (DEBUG-ASSERT (EQUAL (SECOND FCTN-NAME) (COMPILAND-FUNCTION-SPEC PARENT)))) ;; Refer directly to the parent FEF instead of its ;; name so that if we are compiling an encapsulation, ;; we don't try to store into the function being ;; encapsulated. [SPR 3 and 1167] (LET ((PARENT-FEF (GETF (COMPILAND-PLIST PARENT) 'FEF))) (WHEN (EQ (CAR-SAFE PARENT-FEF) 'MACRO) (SETQ PARENT-FEF (CDR PARENT-FEF))) (FDEFINE `(:INTERNAL ,PARENT-FEF . ,(CDDR FCTN-NAME)) DEF NIL)) ;; Else normal definition of unencapsulated function. (FDEFINE FCTN-NAME DEF T)) ;; If the function definition fails, then don't try to define ;; its :INTERNAL functions either. [SPR 1730 and 2632] (SETQ COMPILER-QUEUE NIL) (WHEN (< *RETURN-STATUS* FATAL) (SETQ *RETURN-STATUS* FATAL)))))) #+compiler:debug ((EQ LAP-MODE :JUST-COUNT)) #+compiler:debug ((EQ LAP-MODE 'DISASSEMBLE) (LOCALLY (DECLARE (SPECIAL *DISASSEMBLE-OPTIONS*)) (APPLY #'DISASSEMBLE LAP-OUTPUT-BLOCK *DISASSEMBLE-OPTIONS*))) #+compiler:debug ((EQ LAP-MODE :DUMP) (DUMP-FEF LAP-OUTPUT-BLOCK)) (T (FERROR NIL "~S is a bad lap mode" LAP-MODE)))) )) ))