-
Notifications
You must be signed in to change notification settings - Fork 7
/
helpers.lisp
126 lines (107 loc) · 5.02 KB
/
helpers.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
;;; -*- Syntax: Common-Lisp; Base: 10 -*-
;;;
;;; Copyright (c) 2024 Gary Palter
;;;
;;; Licensed under the MIT License;
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;; https://opensource.org/license/mit
(in-package #:forth)
;;; Functions used as the code for some of the words defined by Forth 2012
(defun push-parameter-as-cell (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(stack-push data-stack (parameters-p1 parameters))))
(defun push-parameter-as-double-cell (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(stack-push-double data-stack (parameters-p1 parameters))))
(defun push-value (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(let ((address (parameters-p1 parameters))
(type (parameters-p2 parameters)))
(case type
(:value
(stack-push data-stack (memory-cell memory address)))
(:2value
(stack-push-double data-stack (memory-double-cell memory address)))
(:fvalue
(stack-push float-stack (memory-native-float memory address)))))))
(defun push-parameter-as-float (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(stack-push float-stack (parameters-p1 parameters))))
(defun execute-parameter (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(when (null (parameters-p1 parameters))
(forth-exception :defer-not-set))
(execute execution-tokens (parameters-p1 parameters) fs)))
(defun do-marker (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(execute-marker word-lists execution-tokens files (parameters-p1 parameters))))
(defun replace-top-of-search-order-with-parameter (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(replace-top-of-search-order word-lists (parameters-p1 parameters))))
;;; Structure (BEGIN-STRUCTURE) helpers
(defstruct (forth-structure (:conc-name #:fs-))
(size 0)
(word nil)
(named? nil)
(fields nil))
(defun add-structure-field (fs name field-size &optional (align? t))
(with-forth-system (fs)
(let* ((original-offset (stack-pop data-stack))
(offset (cond ((zerop (mod original-offset (max field-size 1)))
original-offset)
(align?
(+ original-offset (- field-size (mod original-offset field-size))))
(t
original-offset)))
(struct (stack-cell data-stack 0))
(name (if (fs-named? struct)
(format nil "~A.~A" (word-name (fs-word struct)) name)
name))
(word (make-word name #'push-field-address-from-parameter :smudge? t :parameters (make-parameters offset))))
(push word (fs-fields struct))
(add-and-register-word fs word)
(stack-push data-stack (+ offset field-size)))))
(defun push-structure-size-from-parameter (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(stack-push data-stack (fs-size (parameters-p1 parameters)))))
(defun push-field-address-from-parameter (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(stack-push data-stack (+ (stack-pop data-stack) (parameters-p1 parameters)))))
;;; Helpers for FFI words
(defun push-parameter-as-global-pointer (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(let* ((name (parameters-p1 parameters))
(forth-name (parameters-p2 parameters))
(library (library-ffi-library (parameters-p3 parameters)))
(pointer (cffi:foreign-symbol-pointer name :library library)))
(if (null pointer)
(forth-exception :undefined-foreign-global "Foreign global ~A~@[ (AS ~A)~] is not defined~@[ ~A~]"
name forth-name #+LispWorks (library-name (ffi-current-library ffi)) #-LispWorks nil)
(stack-push data-stack (native-address memory pointer))))))
(defun push-parameter-as-callback-ptr (fs parameters)
(declare (type forth-system fs) (type parameters parameters)
(optimize (speed 3) (safety 0)))
(with-forth-system (fs)
(stack-push data-stack (native-address memory (cffi:get-callback (parameters-p1 parameters))))))