LMC

;;;Duretto Benito Francesco Antonio 829795
;;;Stampa il messaggio di errore corretto
(defun err* (err index)
  (cond
   ((= err 0)
    (format
     t
     "Error: File maximum contain 100 instruction,
 Instriction in this File are: ~S"
     index))
   ((= err 1)
    (format t "Error: Unexpected number of element, Line: ~S" index))
   ((= err 2)
    (format t "Error: Label cant be a number, Line: ~S" index))
   ((= err 3)
    (format t "Error: Instruction isnt valid, Line: ~S" index))
   ((= err 4)
    (format t "Error: Parameter value isnt between 0-999, Line: ~S" index))
   ((= err 5)
    (format
     t
     "Error: Unknow Parameter value, Integer or label required. Line: ~S"
     index))
   ((= err 6)
    (format t "Error: Parameter value isnt between 0-99, Line: ~S" index))
   ((= err 7)
    (format t "Error: An element cant be an instruction, Line: ~S" index))
   ((= err 8)
    (format t "Error: Label already defined, Line: ~S" index))
   ((= err 9)
    (format t "Error: Label not defined, Line: ~S" index))
   ((= err 11)
    (format t "Error: Value in memory Unexpected: Value ~S" index))
   ((= err 12)
    (format t "Error: The elements in the input list are not enough "))
   ((= err 13)
    (format t "Error: Illegal input: ~S" index))
   (t (format t "Unknown Error")))
  nil)

;;;leggo il file linea per linea
(defun get-file (filename)
  (with-open-file (stream filename)
    (labels ((read-recursively (read-so-far)
               (let ((line (read-line stream nil 'eof)))
                 (if (eq line 'eof)
                     (reverse read-so-far)
                   ;;creo una lista con tutte le linee del file ben formattate
                     (read-recursively (cons (filter line) read-so-far))))))
      (read-recursively ()))))

;;;elimino i commenti
(defun comment-remove (str)
  (let ((position (search "//" str)))
    (if position (subseq str 0 position) str)))

;;;filtro la linea togliendo
;;;gli spazi inutili e i caratteri speciali
(defun filter (line)
  (let ((str
         (string-trim
          '(#\Space )
          (comment-remove
           (string-downcase
            (string-trim
             '(#\Space #\Newline )
             (remove
              '(#\Newline #\Page #\Return #\Rubout #\Linefeed #\Backspace)
              (substitute #\Space #\Tab line))))))))
    (if (string= "" str) nil (flatten(splitter " " str)))))

;;;divido la stringa senza commenti
;;;in stringhe e formo una lista
(defun splitter (X str)
  (let ((position (search X str)))
    (if
        position
        (list
         (subseq str 0 position)
         (splitter X (string-trim X (subseq str (+ position 1)))))
      str)))


(defun flatten (lista)
  (cond
    ((null lista) nil)
    ((atom lista) (list lista))
    (t (append (flatten (car lista)) (flatten (cdr lista))))))

;;;carico un file e trasformo le istruzioni in codice macchina
(defun lmc-load (X)
  (let ((instructions (remove nil (get-file X)))
        (label-list (take-label nil (remove nil (get-file X)) 0)))
    ;;controllo se le label sono corrette
    (if (control-label-defined label-list 0)
        (let
            ((mem
              (delete-label-instruction
               label-list
               instructions)))
          ;;controllo se la lunghezza della memoria sia massimo
          ;;di 100 istruzioni
          (if (<= (length mem) 100)
              (if (control mem label-list 0)
                  (append
                   ;;traduco le istruzioni in linguaggio macchina
                   (assembler mem label-list 0)
                   (make-list (- 100 (length mem)) :initial-element '0))
                nil)
            (err* 0 (length mem))))
      nil)))

;;ritorna il valore macchina se l'elemento e' una istruzione
;;altrimenti nil
(defun is-instruction (Element)
  (cond
   ((string= Element "add") 100)
   ((string= Element "sub") 200)
   ((string= Element "sta") 300)
   ((string= Element "lda") 500)
   ((string= Element "bra") 600)
   ((string= Element "brz") 700)
   ((string= Element "brp") 800)
   ((string= Element "dat") 0)
   (T (is-instruction1 Element))))

(defun is-instruction1 (Element)
  (cond
   ((string= Element "inp") 901)
   ((string= Element "out") 902)
   ((string= Element "hlt") 0)
   (T nil)))



;;;prende il primo elemento di ogni istruzione
;;;con il rispettivo indice
;;;solo se non risulta essere un comando predefinito
;;;e crea una lista
(defun take-label (lista-label instructions index)
  (cond
   ((null instructions) nil)
   ((is-instruction (car (car instructions)))
    (take-label lista-label (cdr instructions) (+ index 1)))
   ((null (cdr instructions)) (list (list (car (car instructions)) index)))
   (t
    (append
     lista-label
     (list
      (list (car (car instructions)) index))
     (take-label lista-label (cdr instructions) (+ index 1))))))

;;;cerca una label nella lista delle label
;;;se presente ritorna il valore di indice
;;;altrimenti ritorna nil
(defun search-label-defined (label lista-label)
  (if lista-label
      (if (string= label (car (car lista-label)))
          (car(cdr (car lista-label)))
        (search-label-defined label (cdr lista-label)))
    nil))

;;;controlla se le label acquisite da take-label sono corrette
(defun control-label-defined (list1 index)
  (if list1
      (cond
       ;;controlla se la label e' un numero
       ((numberp (read-from-string (car (car list1)))) (err* 2 index))
       ;;controla se la label e' gia' stata definita
       ((search-label-defined
         (car (car list1))
         (cdr list1))(err* 8 index))
       (t (control-label-defined
           (cdr list1)
           (+ index 1))))
    t))

;;;elimina tutte le label nelle istruzioni
;;;per scremare il numero degli elementi
(defun delete-label-instruction (label-list instructions)
  (cond
   ((null label-list) instructions)
   ((search-label-defined
     (car (car instructions))
     label-list)
    (append
     (list (cdr (car instructions)))
     (delete-label-instruction
      (cdr label-list)
      (cdr instructions))))
   (t (append
       (list (car instructions))
       (delete-label-instruction label-list (cdr instructions))))))

;;;controlla tutte le istruzioni nella memoria
;;;quando l'istruzione e'
;;; da 2 elementi fa il controllo da 2 elementi
;;; da 1 elemento fa il controllo da 1 elemento
;;; altrimenti errore
(defun control (instructions label-list index)
  (cond
   ((null instructions) t)
   ((= (length (car instructions)) 2)
    (if (controllo2 (car instructions) label-list index)
        (control
         (cdr instructions)
         label-list
         (+ index 1)) nil))
   ((= (length (car instructions)) 1)
    (if (controllo1 (car instructions) index)
        (control
         (cdr instructions)
         label-list
         (+ index 1)) nil))
   (t (err* 1 index))))


;;;controlla che la istruzione da due elementi sia corretta
;;;ritorna true o err*
(defun controllo2 (instruction label-list index)
  (if (is-instruction (car instruction))
      (cond
       ;;controllo se il primo elemento e' una
       ;;istruzione che non preveda parametri
       ((is-instruction1
         (car instruction)) (err* 3 index))
       ;;quando il primo elemento è dat
       ;;il secondo deve necessariamente essere un numero compreso tra 0 e 999
       ((string= (car instruction) "dat")
          (if (numberp
               (read-from-string (car (cdr instruction))))
              ;;then
              (if (and
                   (< (read-from-string (car (cdr instruction))) 1000)
                   (>= (read-from-string (car (cdr instruction))) 0))
                  t (err* 4 index))
            (err* 3 index)))
       ;;il primo elemento e' una una istruzione
       ;;che prevede parametro ed e' diversa da dat
       (t (if
              ;;se la label e' definita ritorna true
              (search-label-defined (car (cdr instruction)) label-list)
              t
            ;;se il parametro e' un numero deve essere necessariamente
            ;;essere compreso tra 0 e 99
            (if (numberp
                 (read-from-string (car (cdr instruction))))
                (if (and
                     (< (read-from-string (car (cdr instruction))) 100)
                     (>= (read-from-string (car (cdr instruction))) 0))
                    t (err* 6 index))
              (err* 9 index))))) (err* 3 index)))

;;;Quando l'istruzione ha un solo elemento, questo deve essere
;;; necessariamente una istruzione che non preveda parametri
(defun controllo1 (instruction index)
  (if (or
       (is-instruction1 (car instruction))
       (string= (car instruction) "dat"))
      t (err* 3 index)))

;;;converte la lista di istruzioni in codice macchina
;;;quando una istruzione ha due elementi fa la somma
;;;is-instruction + numero o is-instruction + index di label
;;;quando l'istruzione è singola traduce l'istruzione in codice macchina
;;;con is-instruction.
(defun assembler (instructions label-list index)
  (cond
   ((= (length (car instructions)) 2)
    (append
     (list
      (+ (is-instruction (car (car instructions)))
         (label-or-number (car(cdr (car instructions))) label-list)))
     (assembler (cdr instructions) label-list (+ index 1))))
   ((= (length (car instructions)) 1)
    (append
     (list
      (is-instruction (car (car instructions))))
     (assembler (cdr instructions) label-list (+ index 1))))
   (t nil)))

;;;se l'elemento e' un numero ritorna il numero
;;;se l'elemento e' una label ritorna la posizione
;;;indicata dalla label
(defun label-or-number (element label-list)
 (if (numberp (read-from-string element))
     (read-from-string element)
   (search-label-defined element label-list)))


;;;inizializza lo stato e avvia l'esecuzione
(defun lmc-run (file input)
  (compile 'execution-loop);per non generare stack-overflow nel terzo file asm.
  (let ((mem (lmc-load file)))
    (if mem
        (execution-loop
         (list 'state
               :acc 0
               :pc 0
               :mem mem
               :in input
               :out nil
               :flag 'noflag)))))

(defun lmc-run* (file input)
  ((lambda (mem)
  (if mem
      (execution-loop
       (list 'state
             :acc 0
             :pc 0
             :mem mem
             :in input
             :out nil
             :flag 'noflag)))
      ) (lmc-load file))
    )



;;;esegue one-instruction fino a quando non viene ritornato
;;;un errore o uno stato bloccato con halted-state
(defun execution-loop (initial-state)
  (labels ((execution-cicle (state)
             (cond
              ((null state) nil)
              ((eq (car state) 'halted-state) state)
              (t (execution-cicle (one-instruction state))))))
    (let ((final-state (execution-cicle initial-state)))
      (if final-state
          (format
           nil
           "Execution has been completed succesfully, Output: ~S"
           (if (null (nth (+ (position :out final-state) 1) final-state))
               'empty
             (nth (+ (position :out final-state) 1) final-state))) nil))))

;;;esegue l'istruzione indicata dal Program counter
;;;altrimenti ritorna errore
(defun one-instruction (state)
  (labels ((get-value (keyword)
             (nth (+ (position keyword state) 1) state))
           (set-value (keyword value)
             (setf (nth (+ 1 (position keyword state)) state) value)))
    (let* ((pc (get-value ':pc));program counter
           (mem (get-value ':mem));la memoria nello stato
           (code (floor (nth pc mem) 100));op_code dell'istruzione
           (arg (mod (nth pc mem) 100));argomento dell'istruzione
           (acc (get-value ':acc));accumulatore
           (in (get-value ':in));lista di input
           (out (get-value ':out));lista di output
           (flag (get-value ':flag));flag di attivazione eventi
           (pc++ (mod (+ pc 1) 100)));incremento pc
      (cond
       ;;istruzione: hlt
       ((= code 0) (append (list 'halted-state) (cdr state)))
       ;;istruzione: add
       ((= code 1)
        (let* ((increment-acc (+ acc (nth arg mem)))
               (set-flag (if (> increment-acc 999) 'flag 'noflag)))
          (set-value :acc (mod increment-acc 1000))
          (set-value :pc pc++)
          (set-value :flag set-flag) state))
       ;;istruzione: sub
       ((= code 2)
        (let* ((decrement-acc (- acc (nth arg mem)))
               (set-flag (if (< decrement-acc 0) 'flag 'noflag)))
          (set-value :acc (mod decrement-acc 1000))
          (set-value :pc pc++)
          (set-value :flag set-flag) state))
       ;;istruzione: sta (store)
       ((= code 3)
        (progn
          (set-value :mem (append
                           (subseq mem 0 arg)
                           (list acc) (subseq mem (+ arg 1))))
          (set-value :pc pc++) state))
       ;;istruzione: lda (load)
       ((= code 5)
        (progn
          (set-value :acc (nth arg mem))
          (set-value :pc pc++) state))
       ;;istruzione: bra (branch)
       ((= code 6)
        (progn (set-value :pc arg) state))
       ;;istruzione: brz (branch if zero)
       ((= code 7)
        (progn (set-value :pc (if (and (= acc 0) (eq flag 'noflag))
                                  arg pc++)) state))
       ;;istruzione: brp (branch if positive)
       ((= code 8)
        (progn (set-value :pc (if (eq flag 'noflag) arg pc++))) state)
       ;;istruzione: inp (input)
       ((and (= code 9) (= arg 1))
        (if (null in) (err* 12 0) ;controllo se la lista di input e' vuota
          (if (and (numberp (car in)) (>= (car in) 0) (< (car in) 1000))
              (progn
                (set-value :pc pc++)
                (set-value :acc (car in))
                (set-value :in (cdr in)) state)
            (err* 13 (car in)))))
       ;;istruzione: out (output)
       ((and (= code 9) (= arg 2))
        (progn
          (set-value :pc pc++)
          (set-value :out (append out (list acc))) state))
       (t (err* 11 (+ (* code 100) arg)))))))


(defun f (x y)
   ((lambda (a b)
      (+ (* x (quadrato a))
             (* y b)
             (* a b)))
    (+ 1 (* x y))
    (- 1 y)))

(defun f (x y)
   (let ((a (+ 1 (* x y)))
         (b (- 1 y))
         )
    (+ (* x (quadrato a))
       (* y b)
     (* a b))))

(defun f (x y)
((lambda (a b)
  (+ (* x (quadrato a))
      (* y b)
      (*a b))
  ) (+ 1 (* x y)) (- 1 y))

)


(defun reduce* (x y)
  (cond
    ((atom y) y)
    (t (reduce* x (funcall x (car y) (when (cdr y) (reduce* x (cdr y))))))
  ))

  (defun nopred* (x y)
    (cond
      ((null y) nil)
      ((atom y) (if (ignore-errors (funcall x y)) nil (list y)))
      (t (append (nopred* x (car y)) (nopred* x (cdr y))))))


const char a = 'a';
char* p = a*;