[Mit-cadr-cvs] r321 - in trunk/lisp: cold io network sys
rswindells at common-lisp.net
rswindells at common-lisp.net
Sun Nov 18 01:46:14 UTC 2012
Author: rswindells
Date: Sat Nov 17 17:46:14 2012
New Revision: 321
Log:
Switch to sys99 format for pathname property lists.
Initial version of tftp-mini.
Added:
trunk/lisp/network/
trunk/lisp/network/tftp-mini.lisp
Modified:
trunk/lisp/cold/coldld.lisp
trunk/lisp/io/mini.lisp
trunk/lisp/io/pathnm.lisp
trunk/lisp/io/rtc.lisp
trunk/lisp/sys/qfasl.lisp
Modified: trunk/lisp/cold/coldld.lisp
==============================================================================
--- trunk/lisp/cold/coldld.lisp Sun Nov 4 15:20:57 2012 (r320)
+++ trunk/lisp/cold/coldld.lisp Sat Nov 17 17:46:14 2012 (r321)
@@ -79,7 +79,9 @@
(let (this-file-definitions)
(do () ((eq (qfasl-whack) 'eof)))
(set-file-loaded-id qfasl-binary-file)
- (record-definitions this-file-definitions))))
+ ;; restore this for sys99
+ ;;(record-definitions this-file-definitions)
+ )))
;Add the list of function specs defined in a file
;to that file's property list. The argument is a list in this world.
Modified: trunk/lisp/io/mini.lisp
==============================================================================
--- trunk/lisp/io/mini.lisp Sun Nov 4 15:20:57 2012 (r320)
+++ trunk/lisp/io/mini.lisp Sat Nov 17 17:46:14 2012 (r321)
@@ -7,7 +7,8 @@
(DECLARE (SPECIAL MINI-PKT MINI-PKT-STRING MINI-FILE-ID MINI-OPEN-P MINI-CH-IDX MINI-UNRCHF
MINI-LOCAL-INDEX MINI-LOCAL-HOST MINI-REMOTE-INDEX MINI-REMOTE-HOST
MINI-IN-PKT-NUMBER MINI-OUT-PKT-NUMBER MINI-EOF-SEEN
- MINI-DESTINATION-ADDRESS MINI-ROUTING-ADDRESS))
+ MINI-DESTINATION-ADDRESS MINI-ROUTING-ADDRESS
+ MINI-PLIST-RECEIVER-POINTER))
;;; Compile time chaosnet address lookup and routing.
(DEFMACRO GET-INTERESTING-CHAOSNET-ADDRESSES (HOST-TO-USE)
@@ -245,16 +246,34 @@
(DECLARE (SPECIAL *COLD-LOADED-FILE-PROPERTY-LISTS*))
+;This kludge simulates the behavior of PROPERTY-LIST-MIXIN.
+;It is used instead of the generic-pathname in fasloading and readfiling;
+;it handles the same messages that generic-pathnames are typically sent.
+(DEFUN MINI-PLIST-RECEIVER (OP &REST ARGS)
+ (SELECTQ OP
+ (:GET (GET MINI-PLIST-RECEIVER-POINTER (CAR ARGS)))
+ (:GETL (GETL MINI-PLIST-RECEIVER-POINTER (CAR ARGS)))
+ (:PUTPROP (PUTPROP MINI-PLIST-RECEIVER-POINTER (CAR ARGS) (CADR ARGS)))
+ (:REMPROP (REMPROP MINI-PLIST-RECEIVER-POINTER (CAR ARGS)))
+ (:PLIST (CAR MINI-PLIST-RECEIVER-POINTER))
+ (:PUSH-PROPERTY (PUSH (CAR ARGS) (GET MINI-PLIST-RECEIVER-POINTER (CADR ARGS))))
+ (OTHERWISE
+ (PRINT "Bad op to MINI-PLIST-RECEIVER ")
+ (PRINT OP)
+ (%HALT))))
+
(DEFUN MINI-FASLOAD (FILE-NAME PKG
- &AUX FASL-STREAM W1 W2 TEM
+ &AUX FASL-STREAM W1 W2 TEM TEM1
(FDEFINE-FILE-PATHNAME FILE-NAME) FASL-GENERIC-PATHNAME-PLIST
FASLOAD-FILE-PROPERTY-LIST-FLAG
(FASL-TABLE NIL) (FASL-STREAM-BYPASS-P NIL))
;; Set it up so that file properties get remembered for when there are pathnames
(OR (SETQ TEM (ASSOC FILE-NAME *COLD-LOADED-FILE-PROPERTY-LISTS*))
- (PUSH (SETQ TEM (LIST FILE-NAME NIL NIL)) *COLD-LOADED-FILE-PROPERTY-LISTS*))
- (SETQ FASL-GENERIC-PATHNAME-PLIST (LOCF (THIRD TEM)))
+ (PUSH (SETQ TEM (NCONS FILE-NAME)) *COLD-LOADED-FILE-PROPERTY-LISTS*))
+
+ (SETQ FASL-GENERIC-PATHNAME-PLIST (LOCF TEM1))
+ (SETQ MINI-PLIST-RECEIVER-POINTER TEM)
(FASL-START)
@@ -277,7 +296,7 @@
(DO () (MINI-EOF-SEEN)
(FUNCALL FASL-STREAM ':TYI))
;; If package is NIL, will be fixed later
- (SET-FILE-LOADED-ID (LOCF (SECOND TEM)) MINI-FILE-ID PACKAGE)))
+ (SET-FILE-LOADED-ID 'MINI-PLIST-RECEIVER MINI-FILE-ID PACKAGE)))
((FERROR NIL "~A is not a QFASL file" FILE-NAME))) ;Otherwise, barf out.
FILE-NAME)
@@ -288,8 +307,9 @@
(DO FORM (READ STANDARD-INPUT EOF) (READ STANDARD-INPUT EOF) (EQ FORM EOF)
(EVAL FORM))
(OR (SETQ TEM (ASSOC FILE-NAME *COLD-LOADED-FILE-PROPERTY-LISTS*))
- (PUSH (SETQ TEM (LIST FILE-NAME NIL NIL)) *COLD-LOADED-FILE-PROPERTY-LISTS*))
- (SET-FILE-LOADED-ID (LOCF (SECOND TEM)) MINI-FILE-ID PACKAGE)))
+ (PUSH (SETQ TEM (NCONS FILE-NAME)) *COLD-LOADED-FILE-PROPERTY-LISTS*))
+ (SETQ MINI-PLIST-RECEIVER-POINTER TEM)
+ (SET-FILE-LOADED-ID 'MINI-PLIST-RECEIVER MINI-FILE-ID PACKAGE)))
(ADD-INITIALIZATION "MINI" '(SETQ MINI-OPEN-P NIL) '(WARM FIRST))
Modified: trunk/lisp/io/pathnm.lisp
==============================================================================
--- trunk/lisp/io/pathnm.lisp Sun Nov 4 15:20:57 2012 (r320)
+++ trunk/lisp/io/pathnm.lisp Sat Nov 17 17:46:14 2012 (r321)
@@ -1756,34 +1756,32 @@
(LET* ((PATHNAME (FUNCALL SYS-PATHNAME ':BACK-TRANSLATED-PATHNAME
(MERGE-PATHNAME-DEFAULTS (CAR ELEM))))
(GENERIC-PATHNAME (FUNCALL PATHNAME ':GENERIC-PATHNAME)))
- (DO L (SECOND ELEM) (CDDR L) (NULL L)
- (LET ((PROP (INTERN (CAR L) ""))) ;Lossage in cold load generator
- (COND ((EQ PROP ':FILE-ID-PACKAGE-ALIST)
- ;; Kludge, built before there are packages
- (SETF (CAAADR L) (PKG-FIND-PACKAGE (OR (CAAADR L)
- SI:PKG-SYSTEM-INTERNALS-PACKAGE)))
- ;; And before there are truenames
- (LET ((INFO (CADR (CAADR L))))
- (AND (STRINGP (CAR INFO))
- (RPLACA INFO (MERGE-PATHNAME-DEFAULTS (CAR INFO)))))))
- (FUNCALL PATHNAME ':PUTPROP (CADR L) PROP)))
- (DO L (THIRD ELEM) (CDDR L) (NULL L)
- (LET ((PROP (INTERN (CAR L) ""))
+ (DO L (CDR ELEM) (CDDR L) (NULL L)
+ (LET ((PROP (INTERN (CAR L) "")) ;Lossage in cold load generator
(VAL (CADR L)))
;;Cold load generator does not know how to put in instances, it makes
;;strings instead. Also, during MINI loading, calls to MAKE-PATHNAME-INTERNAL
;;are saved just as lists. Note: we do not back translate this pathname, so
;;that we really remember the machine it was compiled on.
- (AND (EQ PROP ':QFASL-SOURCE-FILE-UNIQUE-ID)
- (COND ((STRINGP VAL)
- (SETQ VAL (MERGE-PATHNAME-DEFAULTS VAL)))
- ((LISTP VAL)
- ;; Symbols like UNSPECIFIC may be in the wrong package
- (SETF (CAR VAL) (GET-PATHNAME-HOST (CAR VAL)))
- (DO L (CDR VAL) (CDR L) (NULL L)
- (AND (SYMBOLP (CAR L))
- (SETF (CAR L) (INTERN (GET-PNAME (CAR L)) ""))))
- (SETQ VAL (APPLY #'MAKE-PATHNAME-INTERNAL VAL)))))
+ (COND ((EQ PROP ':QFASL-SOURCE-FILE-UNIQUE-ID)
+ (COND ((STRINGP VAL)
+ (SETQ VAL (MERGE-PATHNAME-DEFAULTS VAL)))
+ ((LISTP VAL)
+ ;; Symbols like UNSPECIFIC may be in the wrong package
+ (SETF (CAR VAL) (GET-PATHNAME-HOST (CAR VAL)))
+ (DO L (CDR VAL) (CDR L) (NULL L)
+ (AND (SYMBOLP (CAR L))
+ (SETF (CAR L) (INTERN (GET-PNAME (CAR L)) ""))))
+ (SETQ VAL (APPLY #'MAKE-PATHNAME-INTERNAL VAL)))))
+ ((EQ PROP ':FILE-ID-PACKAGE-ALIST)
+ ;; Kludge, built before there are packages
+ (SETF (CAAR VAL) (PKG-FIND-PACKAGE (OR (CAAR VAL)
+ SI:PKG-SYSTEM-INTERNALS-PACKAGE)))
+ ;; And before there are truenames
+ (LET ((INFO (CADAR VAL)))
+ (AND (STRINGP (CAR INFO))
+ (RPLACA INFO (MERGE-PATHNAME-DEFAULTS (CAR INFO)))))))
+
(FUNCALL GENERIC-PATHNAME ':PUTPROP VAL PROP)))))
;; Replace all strings saved on symbols with pathnames
(MAPATOMS-ALL #'(LAMBDA (SYMBOL &AUX NAME)
@@ -2614,4 +2612,4 @@
(ADD-LOGICAL-PATHNAME-HOST
"SYS" (SI:GET-SITE-OPTION ':SYS-HOST)
(SI:GET-SITE-OPTION ':SYS-DIRECTORY-TRANSLATIONS)))
-
\ No newline at end of file
+
Modified: trunk/lisp/io/rtc.lisp
==============================================================================
--- trunk/lisp/io/rtc.lisp Sun Nov 4 15:20:57 2012 (r320)
+++ trunk/lisp/io/rtc.lisp Sat Nov 17 17:46:14 2012 (r321)
@@ -1179,10 +1179,10 @@
'(:OUT :FIXNUM))
(COMPILER:FASD-INITIALIZE)
(COMPILER:FASD-START-FILE)
-; (COMPILER:FASD-FILE-PROPERTY-LIST (LIST ':QFASL-SOURCE-FILE-UNIQUE-ID INFILETRUENAME
-; ':PACKAGE ':SYSTEM-INTERNALS))
- (COMPILER:FASD-FILE-PROPERTY-LIST (LIST (LIST ':PACKAGE ':SYSTEM-INTERNALS
- ':QFASL-SOURCE-FILE-UNIQUE-ID INFILETRUENAME)))
+ (COMPILER:FASD-FILE-PROPERTY-LIST (LIST ':QFASL-SOURCE-FILE-UNIQUE-ID INFILETRUENAME
+ ':PACKAGE ':SYSTEM-INTERNALS))
+; (COMPILER:FASD-FILE-PROPERTY-LIST (LIST (LIST ':PACKAGE ':SYSTEM-INTERNALS
+; ':QFASL-SOURCE-FILE-UNIQUE-ID INFILETRUENAME)))
(SETQ INDEX-INDEX (COMPILER:FASD-CONSTANT 1))
(SETQ SYMBOL-INDEX
Added: trunk/lisp/network/tftp-mini.lisp
==============================================================================
--- /dev/null 00:00:00 1970 (empty, because file is newly added)
+++ trunk/lisp/network/tftp-mini.lisp Sat Nov 17 17:46:14 2012 (r321)
@@ -0,0 +1,448 @@
+;;; -*- Mode: Lisp; Package: System-Internals; BASE: 8; Cold-load: T -*-
+
+;;; Implementation of TFTP protocol suitable for use in a cold load.
+;;;
+;;; It also knows the format of a packet non-symbolically.
+
+(DECLARE (SPECIAL MINI-RECV-PKT MINI-PKT MINI-FILE-ID MINI-OPEN-P MINI-CH-IDX
+ MINI-UNRCHF MINI-PKT-NUMBER MINI-EOF-SEEN MINI-STARTED
+ MINI-LOCAL-PORT MINI-LOCAL-HOST
+ MINI-REMOTE-PORT MINI-REMOTE-HOST
+ MINI-REMOTE-ADDRESS MINI-LOCAL-ADDRESS
+ MINI-PKT-SIZE MINI-PLIST-RECEIVER-POINTER))
+
+;This is the filename (a string) on which MINI-FASLOAD was called.
+(DEFVAR MINI-FASLOAD-FILENAME)
+
+(SETQ MINI-REMOTE-HOST "ren")
+(SETQ MINI-REMOTE-ADDRESS 30052000006) ; REN
+(SETQ MINI-LOCAL-ADDRESS 30052000030) ; CADR-1
+(DEFVAR MINI-HIS-ETHERNET-ADDRESS (MAKE-ARRAY 6 ':TYPE ':ART-8B))
+(DEFVAR MINI-MY-ETHERNET-ADDRESS (MAKE-ARRAY 6 ':TYPE ':ART-8B))
+
+(defconst +ether-regs-base+ 376000)
+(defconst +ether-descriptors-base+ 376400)
+
+;;; Initialization, usually only called once.
+(DEFUN MINI-INIT ()
+ ;; Init lists microcode looks at
+; (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-FREE-LIST) NIL)
+; (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-RECEIVE-LIST) NIL)
+; (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-TRANSMIT-LIST) NIL)
+ ;; Fake up two packet buffers for the microcode, locations 1200-x through 1377
+ ;; I.e. in the unused portions of SCRATCH-PAD-INIT-AREA
+ (%P-STORE-TAG-AND-POINTER 1150 DTP-ARRAY-HEADER
+ (DPB 1 %%ARRAY-NUMBER-DIMENSIONS
+ (DPB 1056 %%ARRAY-INDEX-LENGTH-IF-SHORT
+ (DPB 1 %%ARRAY-LEADER-BIT
+ ART-8B))))
+ (%P-STORE-TAG-AND-POINTER 1147 DTP-FIX #.(LENGTH ETHER-BUFFER-LEADER-QS))
+ (%P-STORE-TAG-AND-POINTER (- 1147 1 #.(LENGTH ETHER-BUFFER-LEADER-QS))
+ DTP-HEADER
+ (DPB %HEADER-TYPE-ARRAY-LEADER %%HEADER-TYPE-FIELD
+ (+ 2 #.(LENGTH ETHER-BUFFER-LEADER-QS))))
+ (SETQ MINI-RECV-PKT (%MAKE-POINTER DTP-ARRAY-POINTER 1150))
+ ;; Need to fake up MINI-PKT too.
+ (SETQ MINI-PKT (MAKE-ARRAY 200 ':TYPE ':ART-8B))
+ (OR (BOUNDP 'MINI-LOCAL-PORT)
+ (SETQ MINI-LOCAL-PORT 1024.))
+ (SETQ MINI-OPEN-P NIL)
+ (SETQ MINI-STARTED NIL)
+ (ether-init))
+
+;;; Get a connection to a file server
+(DEFUN MINI-OPEN-CONNECTION (HOST PORT)
+ (OR (BOUNDP 'MINI-PKT) (MINI-INIT))
+ (SETQ MINI-LOCAL-PORT (1+ MINI-LOCAL-PORT))
+ (AND (= MINI-LOCAL-PORT 200000) (SETQ MINI-LOCAL-PORT 1024.))
+ (SETQ MINI-REMOTE-PORT PORT)
+; (get-his-ethernet-address)
+ )
+
+;;; Send an ACK
+(DEFUN MINI-SEND-ACK ()
+ ;(FORMAT DEBUG-STREAM "MINI-SEND-ACK: ~D~%" MINI-PKT-NUMBER)
+ (ASET 0 MINI-PKT 52)
+ (ASET 4 MINI-PKT 53) ; ACK
+
+ (ASET (LDB 1010 MINI-PKT-NUMBER) MINI-PKT 54)
+ (ASET (LDB 0010 MINI-PKT-NUMBER) MINI-PKT 55)
+
+ (MINI-SEND-PKT 4)
+ (SETQ MINI-PKT-NUMBER (1+ MINI-PKT-NUMBER)))
+
+;;; Open a file for read
+(DEFUN MINI-OPEN-FILE (FILENAME BINARY-P &AUX LEN MODE MODELEN)
+ (SETQ MINI-UNRCHF NIL MINI-EOF-SEEN NIL MINI-PKT-NUMBER 1)
+ (OR MINI-OPEN-P
+ (MINI-OPEN-CONNECTION MINI-REMOTE-HOST 69.))
+ (SETQ LEN (ARRAY-ACTIVE-LENGTH FILENAME))
+ (SETQ MODE (IF BINARY-P "octet" "netascii"))
+ (SETQ MODELEN (ARRAY-ACTIVE-LENGTH MODE))
+
+ (ASET 0 MINI-PKT 52)
+ (ASET 1 MINI-PKT 53) ; RRQ
+ (COPY-ARRAY-PORTION (STRING-DOWNCASE FILENAME) 0 LEN MINI-PKT 54 (+ 54 LEN))
+ (ASET 0 MINI-PKT (+ 54 LEN))
+ (COPY-ARRAY-PORTION MODE 0 MODELEN MINI-PKT (+ 55 LEN) (+ 55 LEN MODELEN))
+ (ASET 0 MINI-PKT (+ 55 LEN MODELEN))
+
+ (MINI-SEND-PKT (+ LEN MODELEN 4))
+
+ (OR MINI-STARTED
+ (ether-start))
+
+ ;; Before pathnames and time parsing is loaded, things are stored as strings.
+ (SETQ MINI-FILE-ID (CONS FILENAME "11//06//12 17:30:00"))
+ (MINI-NEXT-PKT T)
+ (IF BINARY-P #'MINI-BINARY-STREAM #'MINI-ASCII-STREAM))
+
+;; Doesn't use symbols for packet fields since not loaded yet
+;; This sends a packet and doesn't return until it has cleared microcode.
+;; You fill in the data part before calling, this fills in the header.
+(DEFUN MINI-SEND-PKT (N-BYTES &AUX CHECKSUM)
+ ;; UDP
+ (ASET (LDB 1010 MINI-LOCAL-PORT) MINI-PKT 42)
+ (ASET (LDB 0010 MINI-LOCAL-PORT) MINI-PKT 43)
+ (ASET (LDB 1010 MINI-REMOTE-PORT) MINI-PKT 44)
+ (ASET (LDB 0010 MINI-REMOTE-PORT) MINI-PKT 45)
+ (ASET 0 MINI-PKT 46)
+ (ASET (+ N-BYTES 10) MINI-PKT 47)
+ (ASET 0 MINI-PKT 50)
+ (ASET 0 MINI-PKT 51)
+
+ ;; IP
+ (ASET 105 MINI-PKT 16) ;v4 + header length
+ (ASET 0 MINI-PKT 17) ; TOS
+ (ASET 0 MINI-PKT 20)
+ (ASET (+ N-BYTES 34) MINI-PKT 21)
+ (ASET 0 MINI-PKT 22)
+ (ASET 0 MINI-PKT 23)
+ (ASET 0 MINI-PKT 24)
+ (ASET 0 MINI-PKT 25)
+ (ASET 100 MINI-PKT 26) ; TTL
+ (ASET 21 MINI-PKT 27) ; UDP
+ (ASET 0 MINI-PKT 30)
+ (ASET 0 MINI-PKT 31)
+
+ (ASET (LDB 3010 MINI-LOCAL-ADDRESS) MINI-PKT 32)
+ (ASET (LDB 2010 MINI-LOCAL-ADDRESS) MINI-PKT 33)
+ (ASET (LDB 1010 MINI-LOCAL-ADDRESS) MINI-PKT 34)
+ (ASET (LDB 0010 MINI-LOCAL-ADDRESS) MINI-PKT 35)
+
+ (ASET (LDB 3010 MINI-REMOTE-ADDRESS) MINI-PKT 36)
+ (ASET (LDB 2010 MINI-REMOTE-ADDRESS) MINI-PKT 37)
+ (ASET (LDB 1010 MINI-REMOTE-ADDRESS) MINI-PKT 40)
+ (ASET (LDB 0010 MINI-REMOTE-ADDRESS) MINI-PKT 41)
+
+ (SETQ CHECKSUM (LOGXOR 177777 (%IP-CHECKSUM MINI-PKT 0 16 24 NIL)))
+ (ASET (LDB 1010 CHECKSUM) MINI-PKT 30)
+ (ASET (LDB 0010 CHECKSUM) MINI-PKT 31)
+
+ ;; Ethernet
+ (COPY-ARRAY-PORTION MINI-HIS-ETHERNET-ADDRESS 0 6 MINI-PKT 0 6)
+ (COPY-ARRAY-PORTION MINI-MY-ETHERNET-ADDRESS 0 6 MINI-PKT 6 14)
+ (ASET 10 MINI-PKT 14)
+ (ASET 0 MINI-PKT 15)
+
+; (STORE-ARRAY-LEADER NIL MINI-PKT %ETHER-LEADER-THREAD)
+; (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-TRANSMIT-LIST) MINI-PKT)
+; (%ETHER-WAKEUP)
+; (DO () ;Await completion of transmission
+; ((NULL (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-TRANSMIT-LIST))))
+ ;; Disallow use of the packet by the receive side, flush any received packet that snuck in
+; (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-FREE-LIST) NIL)
+; (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-RECEIVE-LIST) NIL)
+
+ (MINI-ETHER-SEND MINI-PKT (+ N-BYTES 52)))
+
+;; Return opcode of next packet other than those that are no good.
+;; If the arg is NIL, can return NIL if no packet arrives after a while.
+;; If T, waits forever. Return value is the opcode of the packet in MINI-PKT.
+(DEFUN MINI-NEXT-PKT (MUST-RETURN-A-PACKET)
+ (PROG (IRQ)
+ TOP
+ ;; Enable receive
+ (%xbus-write (+ +ether-descriptors-base+ 200)
+ #.(logior (dpb 1 %%ether-desc-rx-empty 0)
+ (dpb 1 %%ether-desc-rx-wrap 0)
+ (dpb 1 %%ether-desc-rx-irq 0)))
+
+ ;; Enable microcode to receive a packet
+; (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-FREE-LIST) NIL)
+; (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-RECEIVE-LIST) NIL)
+; (STORE-ARRAY-LEADER NIL MINI-PKT %ETHER-LEADER-THREAD)
+; (COPY-ARRAY-CONTENTS "" MINI-PKT) ;Fill with zero
+; (STORE (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-FREE-LIST) MINI-PKT)
+; (%ETHER-WAKEUP)
+; (DO ((N 2000. (1- N))) ;Give it time
+; ((OR (ZEROP N) (SYSTEM-COMMUNICATION-AREA %SYS-COM-ETHER-RECEIVE-LIST))))
+
+ MID
+ (SETQ IRQ (%xbus-read (+ +ether-regs-base+ #.sys:%ether-int-source-offset)))
+ (WHEN (ZEROP (LDB #.%%ether-int-rxb irq)) (GO MID))
+ (%xbus-write (+ +ether-regs-base+ #.sys:%ether-int-source-offset) irq)
+
+ (SETQ MINI-PKT-SIZE (LDB #.%%ether-desc-length (%XBUS-READ (+ +ETHER-DESCRIPTORS-BASE+ 200))))
+; (PRINT "MINI-NEXT-PKT: read " DEBUG-STREAM)
+; (PRINC MINI-PKT-SIZE DEBUG-STREAM)
+ (SELECT (DPB (AREF MINI-RECV-PKT 14) 1010 (AREF MINI-RECV-PKT 15))
+ (#x800 ; IPv4
+; (FORMAT DEBUG-STREAM "MINI-NEXT-PKT: IPv4 ~D~%" (AREF MINI-RECV-PKT 27))
+ (COND ((AND (= (AREF MINI-RECV-PKT 27) 21) ; UDP
+ (= (DPB (AREF MINI-RECV-PKT 44) 1010 (AREF MINI-RECV-PKT 45))
+ MINI-LOCAL-PORT)
+ (= (AREF MINI-RECV-PKT 53) 3) ; DATA
+ (= (DPB (AREF MINI-RECV-PKT 54) 1010 (AREF MINI-RECV-PKT 55))
+ MINI-PKT-NUMBER))
+ (WHEN (= MINI-PKT-NUMBER 1)
+ (SETQ MINI-REMOTE-PORT
+ (DPB (AREF MINI-RECV-PKT 42) 1010 (AREF MINI-RECV-PKT 43))))
+ (SETQ MINI-CH-IDX 56)
+; (PRINT "MINI-NEXT-PKT: RETURNING" DEBUG-STREAM)
+ (RETURN T)))
+ T)
+ (#x806 ; ARP
+; (FORMAT DEBUG-STREAM "MINI-NEXT-PKT: ARP~%")
+ T))
+
+ (GO TOP)))
+
+
+;Stream which does only 16-bit TYI
+(DEFUN MINI-BINARY-STREAM (OP &OPTIONAL ARG1)
+ (SELECTQ OP
+ (:WHICH-OPERATIONS '(:TYI))
+ (:TYI (COND (MINI-UNRCHF
+ (PROG1 MINI-UNRCHF (SETQ MINI-UNRCHF NIL)))
+ ((< MINI-CH-IDX MINI-PKT-SIZE)
+ (PROG1 (DPB (AREF MINI-RECV-PKT (1+ MINI-CH-IDX))
+ 1010 (AREF MINI-RECV-PKT MINI-CH-IDX))
+ (SETQ MINI-CH-IDX (+ MINI-CH-IDX 2))))
+ ((< MINI-PKT-SIZE 1056)
+ (MINI-SEND-ACK)
+ (SETQ MINI-EOF-SEEN T)
+ (AND ARG1 (ERROR ARG1))
+ NIL) ;and tell caller
+ (T ;Get another packet
+ (MINI-SEND-ACK) ;Acknowledge packet just processed
+ (MINI-NEXT-PKT T)
+ (MINI-BINARY-STREAM ':TYI))))
+ (:UNTYI (SETQ MINI-UNRCHF ARG1))
+; (:PATHNAME MINI-FASLOAD-FILENAME)
+; (:GENERIC-PATHNAME 'MINI-PLIST-RECEIVER)
+; (:INFO MINI-FILE-ID)
+; (:CLOSE (DO () (MINI-EOF-SEEN) (MINI-BINARY-STREAM ':TYI)))
+ (OTHERWISE (MINI-BARF "Unknown stream operation" OP))))
+
+(DEFUN MINI-ASCII-STREAM (OP &OPTIONAL ARG1)
+ (SELECTQ OP
+ (:WHICH-OPERATIONS '(:TYI :UNTYI))
+ (:TYI (COND (MINI-UNRCHF
+ (PROG1 MINI-UNRCHF (SETQ MINI-UNRCHF NIL)))
+ ((< MINI-CH-IDX MINI-PKT-SIZE)
+ (LET ((CH (AREF MINI-RECV-PKT MINI-CH-IDX)))
+ (SETQ MINI-CH-IDX (1+ MINI-CH-IDX))
+ (SELECT CH
+ (10 #\BS)
+ (11 #\TAB)
+ (12 #\LINE)
+ (14 #\FF)
+ (15 #\NEWLINE)
+ (177 #\RUBOUT)
+ (OTHERWISE CH))))
+ ((< MINI-PKT-SIZE 1056)
+ (MINI-SEND-ACK)
+ (SETQ MINI-EOF-SEEN T)
+ (AND ARG1 (ERROR ARG1))
+ NIL) ;and tell caller
+ (T ;Get another packet
+ (MINI-SEND-ACK) ;Acknowledge packet just processed
+ (MINI-NEXT-PKT T)
+ (MINI-ASCII-STREAM ':TYI))))
+ (:UNTYI (SETQ MINI-UNRCHF ARG1))
+; (:PATHNAME MINI-FASLOAD-FILENAME)
+; (:GENERIC-PATHNAME 'MINI-PLIST-RECEIVER)
+; (:INFO MINI-FILE-ID)
+; (:CLOSE (DO () (MINI-EOF-SEEN) (MINI-ASCII-STREAM ':TYI)))
+ (OTHERWISE (MINI-BARF "Unknown stream operation" OP))))
+
+(DEFUN MINI-BARF (&REST ARGS)
+ (SETQ MINI-OPEN-P NIL) ;Force re-open of connection
+ ;; If inside the cold load, this will be FERROR-COLD-LOAD, else make debugging easier
+ (LEXPR-FUNCALL #'FERROR 'MINI-BARF ARGS))
+
+;;; Higher-level stuff
+
+;;; Load a file alist as setup by the cold load generator
+(DEFUN MINI-LOAD-FILE-ALIST (ALIST)
+ (LOOP FOR (FILE PACK QFASLP) IN ALIST
+ DO (PRINT FILE)
+ DO (FUNCALL (IF QFASLP #'MINI-FASLOAD #'MINI-READFILE) FILE PACK)))
+
+(DECLARE (SPECIAL FASL-STREAM FASLOAD-FILE-PROPERTY-LIST-FLAG FASL-GROUP-DISPATCH
+ FASL-OPS FDEFINE-FILE-PATHNAME FASL-GENERIC-PATHNAME-PLIST
+ FASL-STREAM-BYPASS-P))
+
+(DECLARE (SPECIAL ACCUMULATE-FASL-FORMS))
+
+(DECLARE (SPECIAL *COLD-LOADED-FILE-PROPERTY-LISTS*))
+
+;This kludge simulates the behavior of PROPERTY-LIST-MIXIN.
+;It is used instead of the generic-pathname in fasloading and readfiling;
+;it handles the same messages that generic-pathnames are typically sent.
+(DEFUN MINI-PLIST-RECEIVER (OP &REST ARGS)
+ (SELECTQ OP
+ (:GET (GET MINI-PLIST-RECEIVER-POINTER (CAR ARGS)))
+ (:GETL (GETL MINI-PLIST-RECEIVER-POINTER (CAR ARGS)))
+ (:PUTPROP (PUTPROP MINI-PLIST-RECEIVER-POINTER (CAR ARGS) (CADR ARGS)))
+ (:REMPROP (REMPROP MINI-PLIST-RECEIVER-POINTER (CAR ARGS)))
+ (:PLIST (CAR MINI-PLIST-RECEIVER-POINTER))
+ (:PUSH-PROPERTY (PUSH (CAR ARGS) (GET MINI-PLIST-RECEIVER-POINTER (CADR ARGS))))
+ (OTHERWISE
+ (PRINT "Bad op to MINI-PLIST-RECEIVER ")
+ (PRINT OP)
+ (%HALT))))
+
+(DEFUN MINI-FASLOAD (FILE-NAME PKG
+ &AUX FASL-STREAM W1 W2 TEM TEM1
+ (FDEFINE-FILE-PATHNAME FILE-NAME) FASL-GENERIC-PATHNAME-PLIST
+ FASLOAD-FILE-PROPERTY-LIST-FLAG
+ (FASL-TABLE NIL) (FASL-STREAM-BYPASS-P NIL))
+
+ ;; Set it up so that file properties get remembered for when there are pathnames
+ (OR (SETQ TEM (ASSOC FILE-NAME *COLD-LOADED-FILE-PROPERTY-LISTS*))
+ (PUSH (SETQ TEM (NCONS FILE-NAME)) *COLD-LOADED-FILE-PROPERTY-LISTS*))
+
+ (SETQ FASL-GENERIC-PATHNAME-PLIST (LOCF TEM1))
+ (SETQ MINI-PLIST-RECEIVER-POINTER TEM)
+
+ (FASL-START)
+
+ ;;Open the input stream in binary mode, and start by making sure
+ ;;the file type in the first word is really SIXBIT/QFASL/.
+ (SETQ FASL-STREAM (MINI-OPEN-FILE FILE-NAME T))
+ (SETQ W1 (FUNCALL FASL-STREAM ':TYI)
+ W2 (FUNCALL FASL-STREAM ':TYI))
+ (COND ((AND (= W1 143150) (= W2 71660)) ;If magic ID checks,
+ (LET ((PACKAGE (IF (FBOUNDP 'INTERN-LOCAL) ;If packages exist now
+ (PKG-FIND-PACKAGE PKG)
+ NIL)))
+ ;; Read in the file property list in the wrong package list fasload does
+ (AND PACKAGE
+ (= (LOGAND (FASL-NIBBLE-PEEK) %FASL-GROUP-TYPE) FASL-OP-FILE-PROPERTY-LIST)
+ (FASL-FILE-PROPERTY-LIST))
+ ;; Call fasload to load it
+ (FASL-TOP-LEVEL) ;load it.
+ ;; Doesn't really read to EOF, must read rest to avoid getting out of phase
+ (DO () (MINI-EOF-SEEN)
+ (FUNCALL FASL-STREAM ':TYI))
+ ;; If package is NIL, will be fixed later
+ (SET-FILE-LOADED-ID 'MINI-PLIST-RECEIVER MINI-FILE-ID PACKAGE)))
+ ((FERROR NIL "~A is not a QFASL file" FILE-NAME))) ;Otherwise, barf out.
+ FILE-NAME)
+
+(DEFUN MINI-READFILE (FILE-NAME PKG &AUX (FDEFINE-FILE-PATHNAME FILE-NAME) TEM)
+ (LET ((EOF '(()))
+ (STANDARD-INPUT (MINI-OPEN-FILE FILE-NAME NIL))
+ (PACKAGE (PKG-FIND-PACKAGE PKG)))
+ (DO FORM (READ STANDARD-INPUT EOF) (READ STANDARD-INPUT EOF) (EQ FORM EOF)
+ (EVAL FORM))
+ (OR (SETQ TEM (ASSOC FILE-NAME *COLD-LOADED-FILE-PROPERTY-LISTS*))
+ (PUSH (SETQ TEM (NCONS FILE-NAME)) *COLD-LOADED-FILE-PROPERTY-LISTS*))
+ (SETQ MINI-PLIST-RECEIVER-POINTER TEM)
+ (SET-FILE-LOADED-ID 'MINI-PLIST-RECEIVER MINI-FILE-ID PACKAGE)))
+
+(DEFUN MINI-BOOT ()
+ (SETQ MINI-OPEN-P NIL)
+ (SETQ MINI-STARTED NIL)
+ (MAKUNBOUND 'MINI-PKT)
+ (MAKUNBOUND 'MINI-RECV-PKT))
+
+(ADD-INITIALIZATION "MINI" '(MINI-BOOT) '(WARM FIRST))
+
+;;; Ethernet device support
+
+
+;; Send a packet
+;;
+;; Just using the first descriptor for now.
+
+(defun mini-ether-send (pkt len &aux status)
+
+ (setq status (logior (dpb 1 #.%%ether-desc-tx-ready 0)
+ (dpb 1 #.%%ether-desc-tx-wrap 0)
+ (dpb 1 #.%%ether-desc-tx-pad 0)
+ (dpb 1 #.%%ether-desc-tx-crc 0)
+ (dpb len #.%%ether-desc-length 0)))
+ (%xbus-write (+ +ether-descriptors-base+ 1)
+ (%physical-address (+ (%pointer pkt) 1
+ (%p-ldb #.%%array-long-length-flag pkt))))
+ (%xbus-write +ether-descriptors-base+ status))
+
+(defun ether-start (&aux mode)
+ (setq mode (logior (dpb 1 #.%%ether-mode-crc-enable 0)
+ (dpb 1 #.%%ether-mode-tx-enable 0)
+ (dpb 1 #.%%ether-mode-rx-enable 0)))
+ (%xbus-write (+ +ether-regs-base+ #.sys:%ether-mode-offset) mode)
+ (setq mini-started t))
+
+(defun ether-init (&aux val)
+ ;; Should pick this up from an EEPROM
+ (aset #x00 MINI-MY-ETHERNET-ADDRESS 0)
+ (aset #x01 MINI-MY-ETHERNET-ADDRESS 1)
+ (aset #x02 MINI-MY-ETHERNET-ADDRESS 2)
+ (aset #x03 MINI-MY-ETHERNET-ADDRESS 3)
+ (aset #x04 MINI-MY-ETHERNET-ADDRESS 4)
+ (aset #x06 MINI-MY-ETHERNET-ADDRESS 5)
+
+ (setq val (aref MINI-MY-ETHERNET-ADDRESS 5))
+ (setq val (dpb (aref MINI-MY-ETHERNET-ADDRESS 4) 1010 val))
+ (setq val (dpb (aref MINI-MY-ETHERNET-ADDRESS 3) 2010 val))
+ (setq val (dpb (aref MINI-MY-ETHERNET-ADDRESS 2) 3010 val))
+ (%xbus-write (+ +ether-regs-base+ #.sys:%ether-mac-address0-offset) val)
+ (setq val (aref MINI-MY-ETHERNET-ADDRESS 1))
+ (setq val (dpb (aref MINI-MY-ETHERNET-ADDRESS 0) 1010 val))
+ (%xbus-write (+ +ether-regs-base+ #.sys:%ether-mac-address1-offset) val)
+
+ ;(fillarray MINI-BROADCAST-ADDRESS '(377 377 377 377 377 377))
+ ;(fillarray MINI-HIS-ETHERNET-ADDRESS '(#x00 33 #x21 #x34 #x55 #x62))
+ (aset #x00 MINI-HIS-ETHERNET-ADDRESS 0)
+ (aset 33 MINI-HIS-ETHERNET-ADDRESS 1)
+ (aset #x21 MINI-HIS-ETHERNET-ADDRESS 2)
+ (aset #x34 MINI-HIS-ETHERNET-ADDRESS 3)
+ (aset #x55 MINI-HIS-ETHERNET-ADDRESS 4)
+ (aset #x62 MINI-HIS-ETHERNET-ADDRESS 5)
+
+ (%xbus-write (+ +ether-descriptors-base+ 201)
+ (%physical-address (+ (%pointer MINI-RECV-PKT) 1
+ (%p-ldb #.%%array-long-length-flag MINI-RECV-PKT)))))
+
+
+;(defun ether-pkt-available ()
+; (plusp (ldb %%ether-int-rxb
+; (%xbus-read (+ +ether-regs-base+ sys:%ether-int-source-offset)))))
+
+(defun %ip-checksum (array sum start count odd-flag)
+ (let ((high-sum (logand 377 (ash sum -8)))
+ (low-sum (logand 377 sum))
+ (offset start)
+ (end (+ start count)))
+ (unless (zerop count)
+ (prog ()
+ (when odd-flag
+ (go get-low-byte))
+ top
+ (incf high-sum (aref array offset))
+ (incf offset)
+ get-low-byte
+ (unless (= offset end)
+ (incf low-sum (aref array offset))
+ (incf offset)
+ (unless (= offset end)
+ (go top)))))
+ (incf high-sum (ash low-sum -8))
+ (setq sum (dpb high-sum 1027 low-sum))
+ (+ (ldb 0020 sum) (ldb 2020 sum))))
+
+
Modified: trunk/lisp/sys/qfasl.lisp
==============================================================================
--- trunk/lisp/sys/qfasl.lisp Sun Nov 4 15:20:57 2012 (r320)
+++ trunk/lisp/sys/qfasl.lisp Sat Nov 17 17:46:14 2012 (r321)
@@ -242,13 +242,16 @@
;;; that package. The FILE-ID is in the CADR rather the CDR, for expansibility.
;Record the fact that a file has been loaded (in a certain package)
-(DEFUN SET-FILE-LOADED-ID (PATHNAME FILE-ID PKG &AUX TEM PROP PLIST)
- (SETQ PLIST (IF (LOCATIVEP PATHNAME)
- PATHNAME ;While using MINI
- (LOCF (FS:PATHNAME-PROPERTY-LIST PATHNAME))))
- (IF (SETQ TEM (ASSQ PKG (SETQ PROP (GET PLIST ':FILE-ID-PACKAGE-ALIST))))
+(DEFUN SET-FILE-LOADED-ID (ACCESS-PATHNAME FILE-ID PKG &AUX GENERIC-PATHNAME TEM)
+ (SETQ GENERIC-PATHNAME
+ (IF (TYPEP ACCESS-PATHNAME ':INSTANCE)
+ (FUNCALL ACCESS-PATHNAME ':GENERIC-PATHNAME)
+ ACCESS-PATHNAME))
+ (IF (SETQ TEM (ASSQ PKG (FUNCALL GENERIC-PATHNAME ':GET ':FILE-ID-PACKAGE-ALIST)))
(RPLACA (CDR TEM) FILE-ID)
- (PUTPROP PLIST (CONS (LIST PKG FILE-ID) PROP) ':FILE-ID-PACKAGE-ALIST)))
+ (FUNCALL GENERIC-PATHNAME ':PUSH-PROPERTY
+ (LIST PKG FILE-ID ACCESS-PATHNAME)
+ ':FILE-ID-PACKAGE-ALIST)))
;Get the version of a file that was loaded into a particular package, NIL if never loaded.
;If the package is given as NIL, the file's :PACKAGE property is used.
More information about the mit-cadr-cvs
mailing list