;; -*- Mode: Lisp; -*- ;; --------------------------------------------------------------------------- ;; Title: Manchester Baby Emulator ;; Created: 2025-07-22 ;; Author: Gilbert Baumann ;; License: MIT style (see below) ;; --------------------------------------------------------------------------- ;;; (c) copyright 2025 by Gilbert Baumann ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the ;; "Software"), to deal in the Software without restriction, including ;; without limitation the rights to use, copy, modify, merge, publish, ;; distribute, sublicense, and/or sell copies of the Software, and to ;; permit persons to whom the Software is furnished to do so, subject to ;; the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (defpackage :baby (:use :cl)) (in-package :baby) (define-symbol-macro +order-byte+ (byte 3 13)) (define-symbol-macro +addr-byte+ (byte 13 0)) (defparameter +order-names+ '#(jmp jrp ldn sto sub sub* cmp stp)) (defun sldb (byte-spec value) (- (logand (1- (ash 1 (byte-size byte-spec))) (+ (ldb byte-spec value) (ash 1 (1- (byte-size byte-spec))))) (ash 1 (1- (byte-size byte-spec))))) ;;;; -- Emulation ----------------------------------------------------------------------------- (defun run (tube &rest args) (setq tube (copy-seq tube)) (loop for (s v) on args by #'cddr do (setf (aref tube s) v)) (let ((pc 0) (ac 0) (nsto 0) (nlod 0)) (labels ((sto (s v) (incf nsto) '(format t "~& STO ~D ← ~D~%" s v) (setf (aref tube s) v)) (lod (s) (incf nlod) '(format t "~& LOD ~D = ~D~%" s (ignore-errors (sldb (byte 32 0) (aref tube s)))) (aref tube s))) (declare (inline sto lod)) (let ((ic (loop for ic from 0 do (progn '(when (zerop (mod ic 1000)) (when (zerop (mod ic 72000)) (terpri)) (princ "#") (force-output)) (let ((order (aref tube (incf pc)))) '(print (list pc (disas-one order) order)) (let ((o (ldb +order-byte+ order)) (s (ldb +addr-byte+ order))) (case o (0 (setq pc (aref tube s))) (1 (setq pc (+ pc (sldb (byte 32 0) (lod s))))) (2 (setq ac (ldb (byte 32 0) (- (lod s))))) (3 (sto s ac)) ((4 5) (setf ac (ldb (byte 32 0) (- ac (aref tube s))))) (6 (incf pc (ldb (byte 1 31) ac))) (7 (return ic))))))))) (format t "~&; ~:D orders executed, ~:D stores, ~:D loads~%" ic nsto nlod) (format t "~&; ~:D (order + store + load)~%" (+ ic nsto nlod)) (values tube ic nsto))))) ;;;; -- Tiny Assembler ------------------------------------------------------------------------ (defun asm (text) ;; Two pass (let ((defs (make-hash-table)) (pc 0) (tube (make-array 32 :adjustable t :fill-pointer 32))) (labels ((asm-one (order) (cond ((symbolp order) (setf (gethash order defs) pc)) ((integerp order) (emit order)) ((typep order '(cons (member EQU))) (destructuring-bind (sym val) (cdr order) (setf (gethash sym defs) val))) ((typep order '(cons (member ORG))) (destructuring-bind (w) (cdr order) (setq pc (ev w)))) ((typep order '(cons (member PROGN))) (mapc #'asm-one (cdr order))) (t (emit order)))) (emit (expr) (when (<= (array-dimension tube 0) pc) (setq tube (adjust-array tube (max (1+ pc) (ceiling (array-dimension tube 0) 2/3)) :initial-element 0))) (setf (aref tube (1- (incf pc))) expr) (setf (fill-pointer tube) (max (fill-pointer tube) pc))) (ev (x &aux k) (cond ((integerp x) x) ((symbolp x) (multiple-value-bind (val win) (gethash x defs) (unless win (error "Undefined symbol in assembly: ~S" x)) (ev val))) ((setq k (position (car x) +order-names+)) (destructuring-bind (&optional (arg 0)) (cdr x) (dpb k +order-byte+ (ldb +addr-byte+ (ev arg))))) ((member (car x) '(+ - * floor ceiling logior logxor logand lognot ash)) (apply (car x) (mapcar #'ev (cdr x)))) ((eq (car x) 'dpb) (destructuring-bind (n b v) (cdr x) (dpb (ev n) b (ev v)))) ((eq (car x) 'ldb) (destructuring-bind (b v) (cdr x) (ldb b (ev v)))) (t (error "Bad expression - ~S" x))))) (mapc #'asm-one text) (map '(simple-array (unsigned-byte 32)) #'(lambda (x) (ldb (byte 32 0) (ev x))) tube)))) ;;;; -- Teeny Disassembler -------------------------------------------------------------------- (defun disas-one (x) (let ((o (ldb +order-byte+ x)) (s (sldb +addr-byte+ x))) (list (elt +order-names+ o) s))) (defun disas (tube) `(progn ,@(map 'list #'disas-one tube))) ;;;; -- Most simple test program -------------------------------------------------------------- (defparameter +p/add+ ;; '(progn (org 1) ;; Program Explanation (LDN 10) ;Load into the Accumulator the number found on line 10, ; changing its sign. The Accumulator becomes -136. (SUB 11) ;Subtracts the number on line 11 from the Accumulator. ;Subtract 478 from -136 leaving the answer, -614 in the ;Accumulator (STO 15) ;Copy the number in the Accumulator to line 15 Copy -614 onto ;line 15 (LDN 15) ;Copy into the Accumulator the number on line 15 and change ;its sign. We now have 614 in the Accumulator. (STO 15) ;Copy the number in the Accumulator to line 15. The answer ;(614) is now on line 15. (STP) ;Stop. (org 10) 136 ;One of the numbers to be added 478 ;The other number to be added. )) ;;;; -- The Original Program ------------------------------------------------------------------ ;; This is from ;; Original program ran on the Manchester Baby. Finds the highest factor of a ;; number. ;; Input: Line 23: Number whose factor is searched ;; Line 24: First divisor to test ;; Output: Line 27: Highest factor (defvar +factor-bin+) (defun factor (&optional (n 262144)) ;; expected answer: 131072 (let ((tube +factor-bin+)) (setq tube (run +factor-bin+ 23 (- n) 24 (1- n))) (aref tube 27))) (defparameter +factor-bin+ ;; The original program (map 'vector (lambda (x) (parse-integer (reverse x) :radix 2)) '("00000000000000000000000000000000" "00011000000000100000000000000000" "01011000000001100000000000000000" "01011000000000100000000000000000" "11011000000001100000000000000000" "11101000000000100000000000000000" "11011000000000010000000000000000" "00000000000000110000000000000000" "00101000000001000000000000000000" "01011000000000010000000000000000" "10011000000001100000000000000000" "10011000000000100000000000000000" "00000000000000110000000000000000" "00000000000001110000000000000000" "01011000000000100000000000000000" "10101000000000010000000000000000" "11011000000001100000000000000000" "11011000000000100000000000000000" "01011000000001100000000000000000" "01101000000000000000000000000000" "10111111111111111111111111111111" "10000000000000000000000000000000" "00100000000000000000000000000000" "00000000000000000011111111111111" "11111111111111111100000000000000" "00000000000000000000000000000000" "00000000000000000000000000000000" "00000000000000000000000000000000" "00000000000000000000000000000000" "00000000000000000000000000000000" "00000000000000000000000000000000" "00000000000000000000000000000000")))